{ 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.