DUzun's Web
Programare, proiecte personale, divertisment

unit USudoku;

interface

    uses crt, dos, windos;

​

    const n=3;

​

    type domen=0..n*n;

​

    var tabla: array[domen,domen,domen] of byte;

        ex, ey, mx, my, i, j, h: byte;

        x, y, z: domen;

        all, gres, complet: boolean;

        k: char;

        cl: array[1..25] of word;

​

    Function HexChr(x:domen):char;

    Function ChrHex(c:char):integer;

    Procedure PCs(n,ex,ey,x,y,z:byte;cl:word);

    Procedure Fereastra(n,ex,ey:byte);

    Function px(p,pp:byte):byte;

    Function py(p,pp:byte):byte;

    Procedure gresax(z,ng:byte;c:char;var g1,g2:byte);

    Function unicax(x,y:byte;c:char):byte;

    Function unicp(p,z:byte):byte;

    Procedure at(x,y,z:domen);

    Procedure bif(x,y,z:domen;cl:word);

    procedure bifp(p,pp,z,cl:byte);

    Procedure Anula;

    Procedure Delete;

    Procedure gresp(p,z:byte;var g1,g2:byte);

    Procedure vergres;

    Procedure verunic;

    Procedure verdubl;

    Function Comp:boolean;

    Procedure rezolva;

    Function fonc(cl:word):word;

​

implementation

​

Function HexChr(x:domen):char;

begin

  case x of

    0:HexChr:=chr(32);

    1..9:HexChr:=chr(x+48);

    10..n*n:HexChr:=chr(x+55);

  end;

end;

​

Function ChrHex(c:char):integer;

begin

  case upcase(c) of

    '1'..'9':ChrHex:=ord(c)-48;

    'A'..'Z':ChrHex:=ord(c)-55;

    ' ','0':ChrHex:=0;

  end;

end;

​

Procedure PCs(n,ex,ey,x,y,z:byte;cl:word);

  var lc: word;

begin

  lc:=textattr;

  textattr:=cl;

  gotoxy(ex-n*n+2*x,ey-n*n+2*y);write(HexChr(z));

  textattr:=lc;

end;

​

Procedure Fereastra(n,ex,ey:byte);

  var e: array[0..24] of char;

      x, y: array[1..100] of byte;

      i, j: byte;

​

  procedure writeif(x,y:byte;c:char);

    var mx,my:byte;

  begin

    mx:=lo(windmax)+1;my:=hi(windmax)+1;

    if (x in [1..mx])and(y in [1..my])and(x+y<mx+my)then begin gotoxy(x,y);write(c);end;

  end;

​

begin

    e[0]:=#201; e[5]:=#186; e[10]:=#199; e[15]:=#204; e[20]:=#200;

    e[1]:=#205; e[6]:=#32;  e[11]:=#196; e[16]:=#205; e[21]:=#205;

    e[2]:=#209; e[7]:=#179; e[12]:=#197; e[17]:=#216; e[22]:=#207;

    e[3]:=#203; e[8]:=#186; e[13]:=#215; e[18]:=#206; e[23]:=#202;

    e[4]:=#187; e[9]:=#186; e[14]:=#182; e[19]:=#185; e[24]:=#188;

​

    for i:=1 to 2*n*n do

    begin

        x[i] := ((i-1) mod 2) + 1 + (((i-1) mod (2*n)) + 1) div (2*n)+i div (2*n*n);

        y[i] := 5*x[i];

    end;

    writeif(ex-n*n+1,ey-n*n+1,e[0]);

​

    for i:=1 to 2*n*n do

    begin

        writeif(ex-n*n+i+1,ey-n*n+1,e[x[i]]);

        writeif(ex-n*n+1,ey-n*n+i+1,e[y[i]]);

    end;

​

    for i:=1 to 2*n*n do

        for j:=1 to 2*n*n do

            writeif(ex-n*n+i+1,ey-n*n+j+1,e[x[i]+y[j]]);

end;

​

Function px(p,pp:byte):byte;

begin

    px := ((p-1) mod n)*n + ((pp-1) mod n) + 1;

end;

​

Function py(p,pp:byte):byte;

begin

    py := ((p-1) div n)*n + ((pp-1) div n)+1;

end;

​

Procedure gresax(z,ng:byte;c:char;var g1,g2:byte);

    var i,v:byte;

begin

    g1:=0;

    g2:=0;

    for i:=1 to n*n do

    begin

        case c of

            'x': v := tabla[ng,i,z];

            'y': v := tabla[i,ng,z];

        end;

        if v=1 then if g1=0 then

            g1 := i

        else begin

            gres := true;

            g2 := i;

        end;

    end;

end;

​

Function unicax(x,y:byte;c:char):byte;

    var i,z,ng,v:byte;

begin

    z:=0;

    ng:=0;

    for i:=1 to n*n do

    begin

        case c of

            'x': v:= tabla[i,x,y];

            'y': v:= tabla[y,i,x];

            'z': v:= tabla[x,y,i];

        end;

        if v=2 then begin

            if z=0 then z:=i;ng:=i;

        end;

        if z=ng then unicax := z

        else unicax :=0 ;

    end;

end;

​

Function unicp(p,z:byte):byte;

    var pp,v,i,t:byte;

begin

    pp := 0;

    v  := 0;

    for i := 1 to n*n do begin

        t := tabla[px(p,i),py(p,i),z];

        if t=2 then begin

            if pp=0 then pp:=i;

            v:=i;

        end;

    end;

   if pp=v then unicp := pp

   else unicp := 0;

end;

​

​

Function ix(x,y,i:byte):byte;

    var nx:byte;

begin

     nx:=((x-1)div n)*n;

     ix:=nx+(x+i-nx)mod n+1;

end;

​

Function iy(x,y,i:byte):byte;

    var nx,ny:byte;

begin

     nx:=((x-1) div n)*n;

     ny:=((y-1) div n)*n;

     iy:=ny+((x+i-nx) div n+y-1-ny) mod n+1;

end;

​

Procedure at(x,y,z:domen);

   var i:byte;

begin

    for i:=0 to n*n-2 do begin

        if tabla[(x+i) mod (n*n)+1,y,z]=2 then tabla[(x+i)mod(n*n)+1,y,z]:=0;

        if tabla[x,(y+i) mod (n*n)+1,z]=2 then tabla[x,(y+i)mod(n*n)+1,z]:=0;

        if tabla[x,y,(z+i) mod (n*n)+1]=2 then tabla[x,y,(z+i)mod(n*n)+1]:=0;

        if tabla[ix(x,y,i),iy(x,y,i),z]=2 then tabla[ix(x,y,i),iy(x,y,i),z]:=0;

    end;

    tabla[x,y,z]:=1;

    all:=false;

end;

​

Procedure bif(x,y,z:domen;cl:word);

Begin

      at(x,y,z);

      PCs(n,ex,ey,x,y,z,cl);

End;

​

procedure bifp(p,pp,z,cl:byte);

begin

    bif(px(p,pp),py(p,pp),z,cl);

end;

​

Procedure Anula;

    var i, j, h: domen;

begin

    for i:=1 to n*n do

        for j:=1 to n*n do

            for h:=1 to n*n do

                tabla[i,j,h]:=2;

end;

​

Procedure Delete;

    var i, j, h: domen;

Begin

    for i:=1 to n*n do

        for j:=1 to n*n do

            PCs(n,ex,ey,i,j,0,cl[3]);

End;

​

Procedure gresp(p,z:byte;var g1,g2:byte);

    var i:domen;

begin

    g1:=0;

    g2:=0;

    for i:=1 to n*n do

        if tabla[px(p,i),py(p,i),z]=1 then

            if g1=0 then g1 := i

            else g2 := i;

end;

​

Procedure vergres;

    var z,ng:domen;g1,g2:byte;

begin

   for z:=1 to n*n do for ng:=1 to n*n do

    begin

        gresax(z,ng,'x',g1,g2);

        if (g1<>0)and(g2<>0) then

        begin

            pcs(n,ex,ey,ng,g1,z,cl[4]);

            pcs(3,ex,ey,ng,g2,z,cl[4]);

            gres:=true;

        end;

​

        gresax(z,ng,'y',g1,g2);

        if (g1<>0)and(g2<>0) then

        begin

            pcs(n,ex,ey,g1,ng,z,cl[4]);

            pcs(3,ex,ey,g2,ng,z,cl[4]);

            gres:=true;

        end;

​

        gresp(ng,z,g1,g2);

        if (g1<>0)and(g2<>0) then

        begin

            pcs(n,ex,ey,px(ng,g1),py(ng,g1),z,cl[4]);

            pcs(n,ex,ey,px(n,g2),py(ng,g2),z,cl[4]);

            gres:=true;

        end;

    end;

end;

​

Procedure verunic;

begin

    for x:=1 to n*n do for y:=1 to n*n do

    begin

        if unicax(x,y,'x')<>0 then begin bif(unicax(x,y,'x'),x,y,cl[3]);end;

        if unicax(x,y,'y')<>0 then begin bif(y,unicax(x,y,'y'),x,cl[3]);end;

        if unicax(x,y,'z')<>0 then begin bif(x,y,unicax(x,y,'z'),cl[3]);end;

    end;

​

    for x:=1 to n*n do

        for z:=1 to n*n do

            if unicp(x,z)<>0 then

            begin

                bifp(x,unicp(x,z),z,cl[3]);

            end;

end;

​

Procedure verdubl;

    label 1;

    var p, pp, z: byte;

        v: array[1..n] of byte;

​

    procedure bif6y(v:byte);

        var y:byte;

    begin

        for y:=1 to n*n-n do

            tabla[px(p,v),(((p+2) div n)*n+y-1) mod (n*n)+1,z]:=0;

    end;

​

    procedure bif6x(v:byte);

        var x:byte;

    begin

        for x:=1 to n*n-n do tabla[((p mod n)*n+x-1) mod (n*n)+1,py(p,v),z]:=0;

    end;

​

begin

    for z:=1 to n*n do for p:=1 to (n*n) do

    begin

        for pp:=1 to n do v[pp]:=0;

        for pp:=1 to (n*n) do

            if tabla[px(p,pp),py(p,pp),z]=2 then

                if v[1]=0 then v[1]:=pp else

                if v[2]=0 then v[2]:=pp else

                if v[3]=0 then v[3]:=pp else goto 1;

        if v[2]<>0 then begin

            if(px(p,v[1])=px(p,v[2]))and((px(p,v[3])=px(p,v[1]))or(v[3]=0)) then bif6y(v[1]);

            if(py(p,v[1])=py(p,v[2]))and((py(p,v[3])=py(p,v[1]))or(v[3]=0)) then bif6x(v[1]);

        end;

      1:

    end;

end;

​

Function Comp:boolean;

    var ver: boolean;

begin

    for x:=1 to n*n do for y:=1 to n*n do

    begin

        ver := false;

        for z:=1 to n*n do

            if tabla[x,y,z]=1 then ver := true;

        if not ver then Comp := ver;

    end;

end;

​

Procedure rezolva;

begin

    repeat

        all:=true;

        If keypressed then k:=readkey;

        verunic;

        verdubl;

    until (k=#27) or all or gres;

end;

​

Function fonc(cl:word):word;

begin

    fonc:=(cl div 16)*16;

end;

​

begin

    textmode(258);

    mx := lo(windmax) + 1;

    my := hi(windmax) + 1;

    ex := mx div 2;

    ey := my div 2;

    anula;

    gres := false;

    complet := false;

end.

​

​