Program na riešenie obľúbenej hry sudoku v pascale

{ SUDOKU.PAS                Copyright (c) TrSek alias Zdeno Sekerak }
{ Program na riesenie hry sudoku                                    }
{ Umoznuje zadat cisla a uchovava v subore aktualne riesenia.       }
{                                                                   }
{ Datum:20.7.2005                              http://www.trsek.com }
 
program sudoku;
uses crt;
 
const LEFT  = 14;
      UP    = 4;
      SPACE = ' ';
   DAT_FILE = 'sudoku.dat';
       COL1 = DARKGRAY;
       COL2 = LIGHTGRAY;
      COLBG = BLACK;
 
var   s: array[1..9,1..9,0..9] of byte;
    x,y: integer;
     ch: char;
 
 
procedure writexy(x,y:integer; s:string);
begin
  gotoxy(x,y);
  write(s);
end;
 
 
{ view plain of sudoku }
procedure ViewSudoku;
begin
  textcolor(COL1);
  writexy( LEFT, UP   ,  '+---+---+---+---+---+---+---+---+---+' );
  writexy( LEFT, UP+ 1,  '|   |   |   I   |   |   I   |   |   |' );
  writexy( LEFT, UP+ 2,  '+---+---+---+---+---+---+---+---+---+' );
  writexy( LEFT, UP+ 3,  '|   |   |   I   |   |   I   |   |   |' );
  writexy( LEFT, UP+ 4,  '+---+---+---+---+---+---+---+---+---+' );
  writexy( LEFT, UP+ 5,  '|   |   |   I   |   |   I   |   |   |' );
  writexy( LEFT, UP+ 6,  '+===+===+===+===+===+===+===+===+===+' );
  writexy( LEFT, UP+ 7,  '|   |   |   I   |   |   I   |   |   |' );
  writexy( LEFT, UP+ 8,  '+---+---+---+---+---+---+---+---+---+' );
  writexy( LEFT, UP+ 9,  '|   |   |   I   |   |   I   |   |   |' );
  writexy( LEFT, UP+10,  '+---+---+---+---+---+---+---+---+---+' );
  writexy( LEFT, UP+11,  '|   |   |   I   |   |   I   |   |   |' );
  writexy( LEFT, UP+12,  '+===+===+===+===+===+===+===+===+===+' );
  writexy( LEFT, UP+13,  '|   |   |   I   |   |   I   |   |   |' );
  writexy( LEFT, UP+14,  '+---+---+---+---+---+---+---+---+---+' );
  writexy( LEFT, UP+15,  '|   |   |   I   |   |   I   |   |   |' );
  writexy( LEFT, UP+16,  '+---+---+---+---+---+---+---+---+---+' );
  writexy( LEFT, UP+17,  '|   |   |   I   |   |   I   |   |   |' );
  writexy( LEFT, UP+18,  '+---+---+---+---+---+---+---+---+---+' );
  textcolor(COL2);
end;
 
 
procedure ViewHelp;
begin
  writexy(2, 2,'SuDoKu resolver ver.1.0             Software by Zdeno Sekerak, www.trsek.com');
  writexy(2, 5,'x=  y=');
  writexy(2, 7,'Choice=');
  writexy(2,24,'F1-Help F2-Save F3-Load F5-Resolve F8-Clear Arrows-Move ESC-Finish');
 
  writexy(54,19,'Venovane mojmu synovi');
  writexy(54,20,'  Zdenkovi Sekerakovi');
end;
 
 
{ view help of sudoku }
procedure Help;
begin
end;
 
 
{ move to position and write number }
{ write possible number for this }
procedure Kurzor(x,y,c:integer);
var xr,yr:integer;
    i:integer;
begin
  gotoxy(4,5); write(x);
  gotoxy(8,5); write(y);
 
  { view choice }
  gotoxy(2,8);
  for i:=1 to 9 do
    if( s[x,y,i]=0 )then
       write(SPACE)
    else
       write(i);
 
  { calc real position }
  xr:=LEFT + x*4 -2;
  yr:=UP + y*2 -1;
 
  gotoxy(xr,yr);
  textbackground(c);
 
  if( s[x,y,0]=0 )then
     write( SPACE )
  else
     write(s[x,y,0]);
 
  gotoxy(xr,yr);
end;
 
 
{ clear area }
procedure Clear;
var xc,yc,i: integer;
begin
  for xc:=1 to 9 do
    for yc:=1 to 9 do
    begin
      for i:=0 to 9 do
         s[xc,yc,i]:=i;
 
      Kurzor(xc,yc,COLBG);
    end;
end;
 
 
{ save to file }
procedure Save;
var f: file of byte;
    xc,yc: integer;
begin
  Assign(f, DAT_FILE);
  ReWrite(f);
 
  for xc:=1 to 9 do
    for yc:=1 to 9 do
      Write(f, s[xc,yc,0]);
 
  Close(f);
end;
 
 
{ load from file }
procedure Load;
var f: file of byte;
    xc,yc: integer;
begin
  Clear;
 
  {$I-}
  Assign(f, DAT_FILE);
  ReSet(f);
  {$I+}
 
  { if file exist }
  if( IOResult=0 )then
  begin
    for xc:=1 to 9 do
      for yc:=1 to 9 do
      begin
        Read(f, s[xc,yc,0]);
        Kurzor(xc,yc,COLBG);
      end;
    Close(f);
  end;
end;
 
 
{ if only one kind than it's a resolve }
function GetSingle(x,y: integer):byte;
var i: integer;
    w: integer;
begin
  w:=0;
 
  for i:=1 to 9 do
    if( s[x,y,i]<>0 ) then
    begin
      if( w=0 )then w:=i
               else w:=-1;
    end;
 
  { result }
  if( w>0 )then GetSingle:=w
           else GetSingle:=0;
end;
 
 
{ cross test of use some number }
function KrossTest(xc,yc:integer):byte;
var x,y: integer;
  xs,ys: integer;
      i: integer;
    poc: integer;
begin
  KrossTest:=0;
 
  for i:=1 to 9 do
    if( s[xc,yc,i]<>0 )then
    begin
      poc:=0;
 
      { left to right }
      for x:=1 to 9 do
        if(( s[x,yc,i]=i ) and (s[x,yc,0]=0 ))then
           inc(poc);
 
      { single? }
      if( poc=1 )then
          KrossTest:=i;
 
      poc:=0;
      { up to down }
      for y:=1 to 9 do
        if(( s[xc,y,i]=i ) and (s[xc,y,0]=0 ))then
           inc(poc);
 
      { single }
      if( poc=1 )then
          KrossTest:=i;
 
      { in square }
      poc:=0;
      xs:=(xc-1) div 3;
      ys:=(yc-1) div 3;
 
      for x:=1 to 3 do
        for y:=1 to 3 do
          if(( s[3*xs+x,3*ys+y,i]=i ) and (s[3*xs+x,3*ys+y,0]=0 ))then
               inc(poc);
 
      { single }
      if( poc=1 )then
          KrossTest:=i;
    end;
end;
 
 
{ make resolve }
function Resolve:boolean;
var xc,yc: integer;
    xs,ys: integer;
    xi,yi: integer;
      c,i: integer;
begin
  Resolve:=false;
 
  for xc:=1 to 9 do
    for yc:=1 to 9 do
      if( s[xc,yc,0]=0 )then
       begin
         { resolve this }
         c:=s[xc,yc,0];
 
         { x-axis }
         for i:=1 to 9 do
           s[xc,yc, s[i,yc,0]]:=0;
 
         { y-axis }
         for i:=1 to 9 do
           s[xc,yc, s[xc,i,0]]:=0;
 
         { do square }
         xs:=(xc-1) div 3;
         ys:=(yc-1) div 3;
 
         for xi:=1 to 3 do
           for yi:=1 to 3 do
             s[xc,yc, s[3*xs+xi,3*ys+yi,0]] := 0;
 
         { resolve of simply test }
         s[xc,yc,0]:=GetSingle(xc,yc);
 
         { simply test without result try cross test }
         if( s[xc,yc,0]=0 )then
             s[xc,yc,0]:=KrossTest(xc,yc);
 
         Kurzor(xc,yc,COLBG);
 
         { if find resolve }
         if( s[xc,yc,0]<>c )then
             Resolve:=true;
       end;
end;
 
 
BEGIN
  TextBackGround(COLBG);
  ClrScr;
 
  ViewSudoku;
  ViewHelp;
  Load;
 
  x:=1; y:=1;
 
  repeat
    { move kurzor }
    Kurzor(x,y,COLBG);
 
    { get char from keyb }
    ch:=readkey;
 
    if( ch=#0 )then
        ch:=readkey;
 
    { F1, F2, F3, F5, F8 keys }
    if( ch=#59 ) then Help;
    if( ch=#60 ) then Save;
    if( ch=#61 ) then Load;
    if( ch=#63 ) then while (Resolve) do;
    if( ch=#66 ) then Clear;
 
    { space as zero }
    if( ch=' ' )then ch:='0';
 
    { insert number }
    if( ch in ['0'..'9']) then
      begin
        s[x,y,0]:=ord(ch) - ord('0');
        Kurzor(x,y,COLBG);
        x:=x+1;
      end;
 
    { arrows }
    if( ch=#75 ) then x:=x-1;
    if( ch=#77 ) then x:=x+1;
    if( ch=#72 ) then y:=y-1;
    if( ch=#80 ) then y:=y+1;
 
    { home - end }
    if( ch=#71 ) then x:=1;
    if( ch=#79 ) then x:=9;
 
    { pageup - pagedown }
    if( ch=#73 ) then y:=1;
    if( ch=#81 ) then y:=9;
 
    { check position }
    if( x<1 ) then x:=9;
    if( x>9 ) then begin x:=1; y:=y+1; end;
    if( y<1 ) then y:=9;
    if( y>9 ) then y:=1;
 
  until (ch=#27);	{ ESC }
 
  { for safe }
  Save;
END.