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.