深度加广度做的一个解邮票问题的程序

var
f:text;
n,k,x,y,t,p,i,j,h,nb:integer;
mx,s:array[1..10000,1..2] of integer;
function connect:boolean;
 var
  tag:array[1..1000] of integer;
  b:array[1..1000] of integer;
  p,an,i,t:integer;
 begin
   fillchar(tag,sizeof(tag),0);
   b[1]:=1; p:=1; an:=1; tag[1]:=1;
   while (p<=an)and(an<k) do
     begin
       for i:=1 to k do
        if tag[i]=0 then
         begin
           t:=0;
           if (s[i,1]=s[b[p],1])and(s[i,2]+1=s[b[p],2]) then t:=1;
           if (s[i,1]+1=s[b[p],1])and(s[i,2]=s[b[p],2]) then t:=1;
           if (s[i,1]-1=s[b[p],1])and(s[i,2]=s[b[p],2]) then t:=1;
           if (s[i,1]=s[b[p],1])and(s[i,2]-1=s[b[p],2]) then t:=1;
           if t=1 then
             begin
               an:=an+1; b[an]:=i; tag[i]:=1;
             end;
         end;
       p:=p+1;
     end;
   if an=k then connect:=true
           else connect:=false;
 end;
begin
  read(n,k,x,y);
  assign(f,'stamp.txt');
  rewrite(f);
  j:=n; p:=n;
  for i:=k downto 1 do
    begin
      mx[i,1]:=j; mx[i,2]:=p;
      if j=1 then begin j:=n; p:=p-1; end
      else j:=j-1;
    end;
  s[1,1]:=1; s[1,2]:=1; p:=1; nb:=0;
  while p>0 do
    begin
      t:=0;
      while (p<k)and(t=0) do
        begin
          if (s[p,1]=x)and(s[p,2]=y) then t:=1;
          if t=0 then
            begin
              p:=p+1;
              if s[p-1,1]=n then begin s[p,1]:=1; s[p,2]:=s[p-1,2]+1;       end
                            else begin s[p,1]:=s[p-1,1]+1;s[p,2]:=s[p-1,2]; end;
            end;
        end;
      if t=0 then
        if (s[p,1]=x)and(s[p,2]=y) then t:=1
        else
          begin if not connect then t:=1; end;
      if t=0 then
        begin
          inc(nb);
          for i:=1 to n do
           begin
             for j:=1 to n do
               begin
                 t:=1;
                 for h:=1 to k do
                   if (s[h,1]=j)and(s[h,2]=i) then t:=0;
                 if t=0 then write(f,'*',' ')
                 else if (j=x)and(i=y) then write(f,'x',' ')
                 else write(f,'-',' ');
               end;
             writeln(f);
            end;
          writeln(f);
        end;
      while (p>0)and(s[p,1]=mx[p,1])and(s[p,2]=mx[p,2]) do p:=p-1;
      if p>0 then
        begin
          if s[p,1]=n then begin s[p,1]:=1;s[p,2]:=s[p,2]+1; end
                      else       s[p,1]:=s[p,1]+1;
        end;
   end;
  writeln(nb);
  write(f,nb);close(f);
end.