track.pas

PASCAL光盘资料PASCAL光盘资料PASCAL光盘资料

program track;
const yd1:string[5]=' A B '; 
      yd2:string[5]=' A C ';
      yd3:string[5]=' A D ';
      yd4:string[5]=' B C ';
      yd5:string[5]=' B D ';
      yd6:string[5]=' C D ';
type arr=array[1..26] of string[6];
var sa,sb,sc,sd:string;  
    so,s:arr;              
    n,lena,lenb,lenc:byte; 
    step,b,bs:word;       
    flag:boolean;        
    input,output:text;

procedure init;
begin
 assign(input,'track.in'); reset(input);
 readln(input,n); readln(input,sd); close(input);
 sa:=copy('abcdefghijklmnopqrstuvwxyz',1,n);  
 sb:=copy('                          ',1,n);
 sc:=sb;
 lena:=n;  lenb:=0;lenc:=0; step:=65535; flag:=false;
end;

procedure work(i:byte);
var j,k,bstemp,atemp,btemp,ctemp:word; 
    m,t:longint;
    satemp,sbtemp,sctemp:string;
    a:array[1..25] of 0..1; 
procedure check;  
 begin
 if i=1 then
     begin
      flag:=true;
      if bs<step then begin
                        step:=bs;
                        for b:=1 to bs do so[b]:=s[b];
                       end;
     end
     else work(i-1) 
 end;
begin
  if pos(sd[i],sa)>0 then 
   begin
    k:=pos(sd[i],sa);
    if k<lena then  
     begin
      bstemp:=bs; atemp:=lena;btemp:=lenb; ctemp:=lenc;
      satemp:=sa;sbtemp:=sb;sctemp:=sc;  
    t:=1; for j:=k+1 to lena do t:=t*2; 
      while t>0 do 
        begin
        t:=t-1; m:=t; j:=0;
        bs:=bstemp;lena:=atemp;lenb:=btemp;lenc:=ctemp;
        sa:=satemp;sb:=sbtemp;sc:=sctemp;
        for j:=1 to lena-k do begin  a[j]:=m mod 2; m:=m div 2;end;
        for j:=1 to lena-k do
          begin
           inc(bs);
           if a[j]=1 then begin                 
                       s[bs]:=sa[lena+1-j]+yd1;
                       inc(lenb); sb[lenb]:=sa[lena+1-j];
                     end
                 else 
                     begin
                      s[bs]:=sa[lena+1-j]+yd2;
                      inc(lenc); sc[lenc]:=sa[lena+1-j];
                     end;
          end; {for}
         inc(bs);s[bs]:=sd[i]+yd3;
         delete(sa,k,lena+1-k);lena:=k-1;
         work(i-1);
       end; {while t>0}
       end {if k<lena}
else 
begin
inc(bs);s[bs]:=sd[i]+yd3;
          delete(sa,k,1);lena:=k-1;
          check;
         end
     end {if pos(d[i],sa)>0}
     else if pos(sd[i],sb)>0 then
          begin
           k:=pos(sd[i],sb);
           for j:=lenb downto k+1 do
            begin
             inc(bs);s[bs]:=sb[j]+yd4;
             inc(lenc);sc[lenc]:=sb[j];
            end;
            inc(bs);s[bs]:=sd[i]+yd5; 
            delete(sb,k,lenb+1-k);lenb:=k-1;
            check;
          end
          else
           if pos(sd[i],sc)=lenc then begin
                                     inc(bs);s[bs]:=sd[i]+yd6;
                                     delete(sc,lenc,1);
                                     dec(lenc);
                                     check;
                                     end
                                   else exit; 
end;

procedure print;
begin
 assign(output,'track.out');
 rewrite(output);
 if flag then for b:=1 to step do writeln(output,so[b])
         else writeln(output,'NO');
 close(output)
end;

begin  {main}
 init; work(n); print
end.