第二题　方阵填数

program Fill_Array;
{$B-}
const    MaxN=100;
var
   a:array[1..MaxN,1..MaxN] of integer;
   x,y,direc,N,M:integer;
begin
   write('Enter N: '); readln(N);
   if (N<=0) or (N>MaxN) then exit;
   for y:=1 to N do
     for x:=1 to N do
        a[x,y]:=0;

   direc:=0;  x:=N;  y:=0; M:=0;
   repeat
      case direc of
       0:   if (y+1>N) or (a[x,y+1]<>0) then
              begin
                 direc:=(direc+1) mod 4;
                 continue;
              end
             else y:=y+1;
       1:   if (x-1<=0) or (a[x-1,y]<>0) then
              begin
                 direc:=(direc+1) mod 4;
                 continue;
              end
             else x:=x-1;
       2:   if (y-1<=0) or (a[x,y-1]<>0) then
              begin
                 direc:=(direc+1) mod 4;
                 continue;
              end
             else y:=y-1;
       3:   if (x+1>N) or (a[x+1,y]<>0) then
              begin
                 direc:=(direc+1) mod 4;
                 continue;
              end
             else x:=x+1;
       end;
       M:=M+1;
       a[x,y]:=M;
   until M=N*N;

   for y:=1 to N do
     begin
        for x:=1 to N do
             write(a[x,y]:4);
        writeln;
     end;
end.

第三题 求出1～1000之中（包括1与1000），全部A、B两类数的个数。

program Calc_AB_Type;
var
   i,A,B:integer;

function TypeA(n:integer):boolean;
var
   sum1,sum0: integer;
begin
  if n<0 then exit;
  sum1:=0; sum0:=0;
  repeat
     if (n and 1) = 1 then  sum1:=sum1+1
       else   sum0:=sum0+1;
      n:=n shr 1;
  until n=0;
  if sum1>sum0 then TypeA:=true
    else  TypeA:=false;
end;

begin
    A:=0; B:=0;
    for i:=1 to 1000 do
       if TypeA(i) then A:=A+1
         else B:=B+1;
    writeln('A=',A:4,' B=',B:4);
end.

其它两题还没看。

第四题　编码问题
program encode_decode;
const  MaxN=100;
var
   a,b,temp:array[0..MaxN-1] of integer;
   i,N,select:integer;

procedure prn;
var
   i:integer;
begin
  for i:=0 to n-1 do write(b[i]:4);
  writeln;
end;


procedure encode;
var
    i,j,m:integer;
begin
    b[0]:=0;
    for i:=1 to N-1 do
      begin
         m:=0;
         for j:=0 to i-1 do if a[j]<a[i] then  m:=m+1;
         b[i]:=m ;
      end;
end;

procedure decode;
var
    i,j,sum:integer;

begin
    for i:=0 to N-1 do temp[i]:=i;
    for i:=N-1 downto 0 do
      begin
          b[i]:=temp[a[i]];
          for j:=a[i] to N-2 do temp[j]:=temp[j+1];
      end;
end;

begin
  repeat
      writeln;
      writeln('1:  Encode');
      writeln('2:  Decode');
      writeln('3:  Quit');
      write('Enter select:');
      readln(select);

      case  select of
      1:    begin
              write('Encode:   Enter N= '); readln(N);
              if (N<1) or (N>MaxN) then continue;
              write('Enter array to encode: ');
              for i:=0 to N-1 do read(a[i]);
              encode;
              prn;
            end;
      2:    begin
              write('Decode:   Enter N= '); readln(N);
              if (N<1) or (N>MaxN) then continue;
              write('Enter array to decode: ');
              for i:=0 to N-1 do read(a[i]);
              decode;
              prn;
            end;
       end;
  until select=3;
end.

你可以到书店买一本
[fly]《全国青少年信息学（计算机）奥林匹克分区联赛试题解析（中学）》[/fly]
这上面题目很全！

program e2;
const
   w:array[1..4,1..2]of integer
    =((1,0),(0,-1),(-1,0),(0,1));
var
   a:array [0..20,0..20]of integer;
   n,l,t,i,j,x,y,p:integer;
begin
  repeat
    readln(n);
  until (n<20) and (n>1);
  p:=2;
  if n>3 then p:=p+1;
  if n>9 then p:=p+1;
  l:=1;
  x:=1;y:=n;
  t:=1;
  for i:=1 to n do begin
    a[0,i]:=-1;
    a[i,0]:=-1;
    a[i,n+1]:=-1;
    a[n+1,i]:=-1;
  end;
  repeat
    a[x,y]:=l;
    l:=l+1;
    if a[x+w[t,1],y+w[t,2]]<>0 then t:=t+1;
    if t=5 then t:=1;
    x:=x+w[t,1];
    y:=y+w[t,2];
  until l>n*n;
  for i:=1 to n do begin
   for j:=1 to n do
     write(a[j,n-i+1]:p);
   writeln;
   writeln;
  end;
  readln;
end.