Listing SAH.PAS Program game; const ni='game.in'; no='game.out'; type board=array [1..4,1..4] of Word; vector=array [1..12870] of Word; pvector=^vector; var f:Text; c:array [1..16,0..16] of Word; v,t:vector; s:pvector; drum:array [1..48] of Word; n,i,j,k,codini,codfin,p,u,l,aux: Word; a,ini,fin,now,next:board; ch:Char; eg,found:boolean; procedure load; begin Assign(f,ni); Reset(f); for i:=1 to 4 do begin for j:=1 to 4 do begin Read(f,ch); if ch='1' then ini[i,j]:=1 else ini[i,j]:=0 end; Readln(f) end; Readln(f); for i:=1 to 4 do begin for j:=1 to 4 do begin Read(f,ch); if ch='1' then fin[i,j]:=1 else fin[i,j]:=0 end; Readln(f) end; Close(f) end; procedure egale; begin eg:=true; for i:=1 to 4 do for j:=1 to 4 do if ini[i,j]<>fin[i,j] then eg:=false; if eg then begin Assign(f,no); Rewrite(f); Writeln(f,0); Close(f); Halt end end; procedure calc_comb; begin c[1,0]:=1; c[1,1]:=1; for i:=2 to 16 do begin c[i,0]:=1; c[i,i]:=1; for j:=1 to i-1 do c[i,j]:=c[i-1,j-1]+c[i-1,j] end end; procedure board_to_number(a:board; var n:Word); var i,j,s,u:Word; begin s:=16; u:=8; n:=0; for i:=1 to 4 do for j:=1 to 4 do begin if a[i,j]=0 then n:=n+c[s-1,u-1] else u:=u-1; s:=s-1; if u=0 then begin j:=4; i:=4 end end; n:=n+1 end; procedure number_to_board(n:Word; var a:board); var i,j,s,u:Word; begin s:=16; u:=8; for i:=1 to 4 do for j:=1 to 4 do a[i,j]:=0; for i:=1 to 4 do for j:=1 to 4 do if not ((i=4) and (j=4)) then begin if n>c[s-1,u-1] then n:=n-c[s-1,u-1] else begin a[i,j]:=1; u:=u-1 end; s:=s-1; if u=0 then begin j:=4; i:=4; end end else if n>0 then a[i,j]:=1 else a[i,j]:=0 end; procedure init; begin New(s); for i:=1 to c[16,8] do s^[i]:=0; board_to_number(ini,n); v[1]:=n; t[1]:=0; s^[n]:=1; p:=1; u:=1; board_to_number(ini,n); codini:=n; board_to_number(fin,n); codfin:=n end; procedure move; begin for i:=1 to 4 do for j:=1 to 3 do if a[i,j]<>a[i,j+1] then begin a[i,j]:=1-a[i,j]; a[i,j+1]:=1-a[i,j+1]; board_to_number(a,n); a[i,j]:=1-a[i,j]; a[i,j+1]:=1-a[i,j+1]; if s^[n]=0 then begin s^[n]:=1; u:=u+1; v[u]:=n; t[u]:=p; if n=codfin then begin found:=true; j:=3; i:=4 end; end; end; if not found then for i:=1 to 3 do for j:=1 to 4 do if a[i,j]<>a[i+1,j] then begin a[i,j]:=1-a[i,j]; a[i+1,j]:=1-a[i+1,j]; board_to_number(a,n); a[i,j]:=1-a[i,j]; a[i+1,j]:=1-a[i+1,j]; if s^[n]=0 then begin s^[n]:=1; u:=u+1; v[u]:=n; t[u]:=p; if n=codfin then begin found:=true; j:=4; i:=3 end end end end; procedure work; begin found:=false; while (p<=u) and (not found) do begin n:=v[p]; number_to_board(n,a); move; if not found then p:=p+1 else write end end; procedure reconst; begin l:=0; while u>0 do begin l:=l+1; drum[l]:=v[u]; u:=t[u] end; p:=1; u:=l; while p<u do begin aux:=drum[p]; drum[p]:=drum[u]; drum[u]:=aux; p:=p+1; u:=u-1 end end; procedure scrie; begin Assign(f,no); Rewrite(f); Writeln(f,l-1); for k:=1 to l-1 do begin n:=drum[k]; number_to_board(n,a); now:=a; n:=drum[k+1]; number_to_board(n,a); next:=a; for i:=1 to 4 do for j:=1 to 4 do if now[i,j]<>next[i,j] then write(f,i,' ',j,' '); Writeln(f) end; Close(f) end; Begin Load; egale; calc_comb; init; work; reconst; scrie End. [cuprins] |