Umiestnenie súboru www.TrSek.com/pas/sudoku.pas{ 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;
{ 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);