Best Sudoku resolver

Kategorija: KMP (Programy mladňakoch

Zrobil: Carl Skipworth
Program: Sudokurslvr.pas
Subor exe: Sudokurslvr.exe

{ SUDOKU.PAS                Copyright (c) TrSek alias Zdeno Sekerak }
{                                                and Carl Skipworth }
{ Sudoku resolver. Modification by Carl Skipworth.                  }
{                                                                   }
{ Datum:30.10.2008                             http://www.trsek.com }
 
program sudokuresolver;
 
  uses
    Crt;
 
  const
    LEFT  = 14;
    UP    = 4;
    SPACE = ' ';
    DAT_FILE = 'sudoku.dat';
    CLR1 = DARKGRAY;
    CLR2 = LIGHTGRAY;
    CLRBG = BLACK;
 
  var
    s    : array[1..9,1..9,0..9] of byte;
    x, y : integer;
    ch   : char;
    f    : file of byte;
 
  procedure writexy ( x, y : integer; s : string );
 
    begin
      gotoxy( x, y );
      write( s )
    end;
 
  procedure ViewSudoku;
 
    const
      TOPL = 'ÉÍÍÍŃÍÍÍŃÍÍÍËÍÍÍŃÍÍÍŃÍÍÍËÍÍÍŃÍÍÍŃÍÍÍť';
      MIDL = 'ş   ł   ł   ş   ł   ł   ş   ł   ł   ş';
      SEPL = 'ÇÄÄÄĹÄÄÄĹÄÄÄ×ÄÄÄĹÄÄÄĹÄÄÄ×ÄÄÄĹÄÄÄĹÄÄÄś';
      GRPL = 'ĚÍÍÍŘÍÍÍŘÍÍÍÎÍÍÍŘÍÍÍŘÍÍÍÎÍÍÍŘÍÍÍŘÍÍÍš';
      BOTL = 'ČÍÍÍĎÍÍÍĎÍÍÍĘÍÍÍĎÍÍÍĎÍÍÍĘÍÍÍĎÍÍÍĎÍÍÍź';
 
    var
      upy  : integer;
 
    begin
      textcolor( CLR1 );
      upy := UP;
 
      repeat
        if odd( upy ) then
          writexy( LEFT, upy, MIDL )
        else
          case upy of
             4                     : writexy( LEFT, upy, TOPL );
             6,  8, 12, 14, 18, 20 : writexy( LEFT, upy, SEPL );
            10, 16                 : writexy( LEFT, upy, GRPL );
            22                     : writexy( LEFT, upy, BOTL )
          end;
        Inc( upy )
      until upy = 23;
 
      TextColor( CLR2 )
    end;
 
  procedure ViewHelp;
 
    begin
      writexy(2, 2,'SuDoKu resolver ver. 2.0     Software by Zdeno Sekerak and Carl Skipworth');
      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(2,24,'        F2-Save F3-Load F5-Resolve F8-Clear  Arrows-Move  ESC-Finish')
    end;
 
  procedure Kurzor ( x, y, c : integer );  { move to position and write number }
                                           { write possible number for this }
    var
      xr, yr : integer;
      i      : integer;
      ch     : char;
      bch    : byte absolute ch;
 
    begin
      gotoxy( 4, 5 );  write( x );
      gotoxy( 8, 5 );  write( y );
 
      gotoxy( 2, 8 );           { view choice }
 
      for i := 1 to 9 do begin
        if s[x,y,i] = 0 then
          ch := SPACE
        else
          bch := ord('0') + i;
        write( ch )
      end;
 
      xr := LEFT + x * 4 - 2;   { calc real position }
      yr := UP   + y * 2 - 1;
 
      gotoxy( xr, yr );
      TextBackground( c );
      if s[x,y,0] = 0 then
        ch := SPACE
      else
        bch := ord('0') + s[x,y,0];
      write( ch );
      gotoxy( xr, yr )
    end;
 
  procedure Clear;              { clear area }
 
    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, CLRBG )
        end
    end;
 
  procedure Save;       { save to file }
 
    var
      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;
 
  procedure Load;       { load from file }
 
    var
      xc, yc : integer;
 
    begin
      Clear;
 
      {$I-}
      Assign( f, DAT_FILE );
      ReSet( f );
      {$I+}
 
      if IOResult = 0 then begin        { if file exist }
 
        for xc := 1 to 9 do
          for yc := 1 to 9 do begin
            Read( f, s[xc,yc,0] );
            Kurzor( xc, yc, CLRBG )
          end;
 
        Close( f )
      end
    end;
 
  function GetSingle ( x, y : integer ) : byte;
                                        { if only one kind then it's a resolve }
    var
      i     : integer;
      w     : integer;
      count : integer;
 
    begin
      count := 0;
 
      for i := 1 to 9 do
        if s[x,y,i] <> 0 then begin
          w := i;
          Inc( count )
        end;
 
 
      if count <> 1 then                { result }
        w := 0;
      GetSingle := w
    end;
 
  function KrossTest ( xc, yc : integer ) : byte;
                                        { cross test of use some number }
    var
      x, y     : integer;
      xs, ys   : integer;
      xsx, ysy : integer;
      i        : integer;
      poc      : integer;
      KT       : byte;
 
    procedure poccheck;
 
      begin
        if poc = 1 then                 { single? }
          KT := i;
        poc := 0
      end;
 
    begin
      KT := 0;
 
      for i := 1 to 9 do
        if s[xc,yc,i] <> 0 then begin
          poc := 0;
 
          for x := 1 to 9 do            { left to right }
            if ( s[x,yc,i] = i ) and ( s[x,yc,0] = 0 ) then
              Inc( poc );
 
          poccheck;
 
          for y := 1 to 9 do            { up to down }
            if ( s[xc,y,i] = i ) and ( s[xc,y,0] = 0 ) then
              Inc( poc );
 
          poccheck;
          xs := (( xc - 1 ) div 3) * 3; { in square }
          ys := (( yc - 1 ) div 3) * 3;
 
          for x := 1 to 3 do begin
            xsx := xs + x;
 
            for y := 1 to 3 do begin
              ysy := ys + y;
              if ( s[xsx,ysy,i] = i ) and ( s[xsx,ysy,0] = 0 ) then
                Inc( poc )
            end
 
          end;
 
          poccheck;
        end;
 
      KrossTest := KT
    end;
 
  function Resolve : boolean;           { make resolve }
 
    var
      xc, yc : integer;
      xs, ys : integer;
      xi, yi : integer;
      i      : integer;
      R      : boolean;
 
    begin
      R := false;
 
      for xc := 1 to 9 do
        for yc := 1 to 9 do
          if s[xc,yc,0] = 0 then begin
 
            for i := 1 to 9 do           { x-axis }
              s[xc,yc, s[i,yc,0]] := 0;
 
            for i := 1 to 9 do           { y-axis }
              s[xc,yc, s[xc,i,0]] := 0;
 
            xs := (( xc - 1 ) div 3) * 3;       { do square }
            ys := (( yc - 1 ) div 3) * 3;
 
            for xi := 1 to 3 do
              for yi := 1 to 3 do
                s[xc,yc, s[xs+xi,ys+yi,0]] := 0;
 
            s[xc,yc,0] := GetSingle( xc, yc ); { resolve of simply test }
 
            if s[xc,yc,0] = 0 then  { simply test without result try cross test }
              s[xc,yc,0] := KrossTest( xc, yc );
 
            Kurzor( xc, yc, CLRBG );
            R := s[xc,yc,0] <> 0        { if find resolve }
          end;
 
      Resolve := R
    end;
 
begin
  TextBackGround( CLRBG );
  ClrScr;
 
  ViewSudoku;
  ViewHelp;
  Load;
 
  x := 1; y := 1;
 
  repeat
    Kurzor( x, y, CLRBG );      { move kurzor }
 
    ch := readkey;              { get char from keyb }
 
    if ch = #0 then
      ch := readkey;
 
    case ch of
                        { F1, F2, F3, F5, F8 keys }
{     #59 : Help;  }
      #60 : Save;
      #61 : Load;
      #63 : while Resolve do;
      #66 : Clear;
                        { arrows }
      #75 : Dec( x );
      #77 : Inc( x );
      #72 : Dec( y );
      #80 : Inc( y );
                        { home - end }
      #71 : x := 1;
      #79 : x := 9;
                        { pageup - pagedown }
      #73 : y := 1;
      #81 : y := 9;
    else
      if ch = ' ' then  { space as zero }
        ch := '0';
      if ch in ['0'..'9'] then begin    { insert number }
        s[x,y,0] := ord(ch) - ord('0');
        Kurzor( x, y, CLRBG );
        Inc( x )
      end
    end;
                        { check position }
    if x < 1 then begin
      x := 9;
      Dec( y )
    end;
    if x > 9 then begin
      x := 1;
      Inc( y )
    end;
    if y < 1 then
      y := 9;
    if y > 9 then
      y := 1
  until ch = #27;	{ ESC }
 
  Save
end.