Sudoku.pas

Un article de Wikipedia.

(Différences entre les versions)
(Nouvelle page : <code pascal n> </code> Category:Source Category:Logiciel Category:Pascal Category:Palm)
Version actuelle (22 mars 2008 à 10:20) (modifier) (défaire)
 
(Une révision intermédiaire masquée)
Ligne 1 : Ligne 1 :
 +
[[Sudoku]]
<code pascal n>
<code pascal n>
 +
program sudoku;
 +
{$i PalmAPI.pas}
 +
{$i PPlib.pas}
 +
{$i Menu.pas}
 +
{$i CPDBSTD4PP.pas}
 +
const numbergrids = 12;
 +
NoError = 0;
 +
// SYSTRAP = $4E4F;
 +
type
 +
// byte = 0..255;
 +
numbers = 1..9;
 +
setnumbers = set of numbers;
 +
possible = record
 +
values : setnumbers;
 +
used : boolean;
 +
end;
 +
grid = array[1..9,1..9] of byte;
 +
cgrid = array[1..9,1..9] of possible;
 +
debug = (nodebug,griddebug,cgriddebug,alldebug);
 +
var g:grid;
 +
cg:cgrid;
 +
solutions:array[1..2] of grid;
 +
solutionindex:byte;
 +
d:debug;
 +
s:string;
 +
newdb:boolean;
 +
//function StrAToI(const S:string):integer; inline(SYSTRAP,$a0ce);
 +
function isvalidindex(index:byte):boolean;
 +
begin
 +
if ( (index >= 1) and (index <= 9) ) then
 +
isvalidindex:=true
 +
else
 +
isvalidindex:=false;
 +
end;
 +
function isvalidvalue(value:byte):boolean;
 +
begin
 +
if ( (value >= 0) and (value <= 9) ) then
 +
isvalidvalue:=true
 +
else
 +
isvalidvalue:=false;
 +
end;
 +
function getvalue(g:grid;raw,column:byte):byte;
 +
begin
 +
if ( isvalidindex(raw) and isvalidindex(column) ) then
 +
getvalue:=g[raw][column]
 +
else
 +
getvalue:=0;
 +
end;
 +
procedure setvalue(var g:grid;raw,column,value:byte);
 +
begin
 +
if ( isvalidindex(raw) and isvalidindex(column) and isvalidvalue(value) ) then
 +
begin
 +
g[raw][column]:=value;
 +
end;
 +
end;
 +
procedure gridprint(g:grid);
 +
var r,c,t:byte;
 +
begin
 +
write('|');
 +
for c:= 1 to 23 do
 +
write('-');
 +
writeln('|');
 +
for r:= 1 to 9 do
 +
begin
 +
write('| ');
 +
for c:= 1 to 9 do
 +
begin
 +
t:=getvalue(g,r,c);
 +
if ( t<>0 ) then
 +
write(t)
 +
else
 +
write(' ');
 +
write(' ');
 +
if ( c mod 3 = 0 ) then
 +
write('| ');
 +
end;
 +
writeln;
 +
if ( r mod 3 = 0 ) then
 +
begin
 +
write('|');
 +
for c:= 1 to 23 do
 +
write('-');
 +
writeln('|');
 +
end;
 +
end;
 +
end;
 +
procedure cgridprint(cg:cgrid);
 +
var r,c,n:byte;
 +
t:setnumbers;
 +
begin
 +
for r:=1 to 9 do
 +
begin
 +
for c:=1 to 9 do
 +
begin
 +
t:=cg[r][c].values;
 +
for n:=1 to 9 do
 +
if n in t then
 +
write(n);
 +
if c<>9 then
 +
write('|');
 +
end;
 +
writeln;
 +
end;
 +
end;
 +
procedure init(var g:grid);
 +
var r,c:byte;
 +
begin
 +
for r:= 1 to 9 do
 +
begin
 +
for c:= 1 to 9 do
 +
begin
 +
setvalue(g,r,c,0);
 +
end;
 +
end;
 +
end;
 +
function count(g:grid):byte;
 +
var r,c,n:byte;
 +
begin
 +
n:=0;
 +
for r:= 1 to 9 do
 +
begin
 +
for c:= 1 to 9 do
 +
begin
 +
if ( getvalue(g,r,c) <> 0 ) then
 +
n:=n+1;
 +
end;
 +
end;
 +
count:=n;
 +
end;
 +
function size(s:setnumbers):byte;
 +
var t,n:byte;
 +
begin
 +
n:=0;
 +
for t:=1 to 9 do
 +
begin
 +
if (t in s) then
 +
n:=n+1;
 +
end;
 +
size:=n;
 +
end;
 +
procedure sample(var g:grid;n:byte);
 +
var s:array [1..9] of string[9];
 +
r,c:byte;
 +
iHandle:UInt8;
 +
Error:Err;
 +
address:MemHandle;
 +
t:string;
 +
function num(c:char):byte;
 +
begin
 +
num:=ord(c)-ord('0');
 +
end;
 +
function readstring(name:string):string;
 +
var line:^string;
 +
temp:string;
 +
begin
 +
Error:=CPDB_ReadString(iHandle,name,address);
 +
line:=MemHandleLock(address);
 +
temp:=line^;
 +
Error:=MemHandleUnlock(address);
 +
Error:=MemHandleFree(address);
 +
readstring:=temp;
 +
end;
 +
begin
 +
if not newdb then
 +
begin
 +
Error:=CPDB_Open(0,'SudokuCPDB',dmModeReadOnly,iHandle);
 +
Error:=CPDB_SeekDirect(iHandle,n);
 +
s[1]:=readstring('S1');
 +
s[2]:=readstring('S2');
 +
s[3]:=readstring('S3');
 +
s[4]:=readstring('S4');
 +
s[5]:=readstring('S5');
 +
s[6]:=readstring('S6');
 +
s[7]:=readstring('S7');
 +
s[8]:=readstring('S8');
 +
s[9]:=readstring('S9');
 +
Error:=CPDB_Close(iHandle);
 +
end;
 +
if newdb then
 +
begin
 +
case n of
 +
1:
 +
begin
 +
s[1]:='087060310';
 +
s[2]:='200501006';
 +
s[3]:='016387450';
 +
s[4]:='002906700';
 +
s[5]:='075000690';
 +
s[6]:='000030005';
 +
s[7]:='001209500';
 +
s[8]:='403010900';
 +
s[9]:='750000080';
 +
end;
 +
2:
 +
begin
 +
s[1]:='006730020';
 +
s[2]:='870090000';
 +
s[3]:='400000800';
 +
s[4]:='000200010';
 +
s[5]:='060040050';
 +
s[6]:='080003000';
 +
s[7]:='004000009';
 +
s[8]:='000050076';
 +
s[9]:='020079300';
 +
end;
 +
3:
 +
begin
 +
s[1]:='050002004';
 +
s[2]:='000000010';
 +
s[3]:='000007506';
 +
s[4]:='200030900';
 +
s[5]:='087060130';
 +
s[6]:='006080005';
 +
s[7]:='309500000';
 +
s[8]:='020000000';
 +
s[9]:='400900080';
 +
end;
 +
end;
 +
end;
 +
 +
init(g);
 +
for r:=1 to 9 do
 +
begin
 +
for c:=1 to 9 do
 +
begin
 +
setvalue(g,r,c,num(s[r][c]));
 +
end;
 +
end;
 +
end;
 +
procedure extract(cg:cgrid;var g:grid);
 +
var r,c,n:byte;
 +
t:setnumbers;
 +
begin
 +
init(g);
 +
for r:=1 to 9 do
 +
begin
 +
for c:=1 to 9 do
 +
begin
 +
t:= cg[r][c].values;
 +
if ( size(t) = 1 ) then
 +
begin
 +
for n:= 1 to 9 do
 +
if ( n in t ) then
 +
setvalue(g,r,c,n);
 +
end
 +
else
 +
setvalue(g,r,c,0);
 +
end;
 +
end;
 +
end;
 +
procedure printdebug(cg:cgrid;g:grid;s:string);
 +
var c:string;
 +
begin
 +
if d in [griddebug,cgriddebug,alldebug] then
 +
begin
 +
writeln(s);
 +
extract(cg,g);
 +
end;
 +
if d in [griddebug,alldebug] then
 +
begin
 +
gridprint(g);
 +
read(c);
 +
end;
 +
if d in [cgriddebug,alldebug] then
 +
begin
 +
cgridprint(cg);
 +
read(c);
 +
end;
 +
end;
 +
procedure applyrules(var cg:cgrid;r,c:byte);
 +
var v:setnumbers;
 +
n,gr,gc,nr,nc:byte;
 +
begin
 +
if (isvalidindex(r) and isvalidindex(c)) then
 +
begin
 +
if ( size(cg[r][c].values) = 1 ) then
 +
begin
 +
cg[r][c].used:=true;
 +
v:=cg[r][c].values;
 +
// raw
 +
for n:=1 to 9 do
 +
begin
 +
if n <> c then
 +
begin
 +
cg[r][n].values:=cg[r][n].values - v;
 +
end;
 +
end;
 +
// column
 +
for n:=1 to 9 do
 +
begin
 +
if n <> r then
 +
begin
 +
cg[n][c].values:=cg[n][c].values - v;
 +
end;
 +
end;
 +
// grid
 +
gr:=((r-1) div 3)*3;
 +
gc:=((c-1) div 3)*3;
 +
for nr:=1+gr to 3+gr do
 +
begin
 +
for nc:=1+gc to 3+gc do
 +
begin
 +
if (nr <> r) and (nc <> c) then
 +
begin
 +
cg[nr][nc].values:=cg[nr][nc].values - v;
 +
end;
 +
end;
 +
end;
 +
end;
 +
end;
 +
end;
 +
procedure cinit(var cg:cgrid;g:grid);
 +
var r,c,t:byte;
 +
begin
 +
for r:= 1 to 9 do
 +
begin
 +
for c:= 1 to 9 do
 +
begin
 +
cg[r][c].values:=[1..9];
 +
cg[r][c].used:=false;
 +
end;
 +
end;
 +
for r:= 1 to 9 do
 +
begin
 +
for c:= 1 to 9 do
 +
begin
 +
if ( getvalue(g,r,c) <> 0 ) then
 +
begin
 +
cg[r][c].values:=[getvalue(g,r,c)];
 +
applyrules(cg,r,c);
 +
end;
 +
end;
 +
end;
 +
end;
 +
procedure userules(var cg:cgrid);
 +
var r,c,n:byte;
 +
begin
 +
repeat
 +
n:=0;
 +
for r:=1 to 9 do
 +
begin
 +
for c:=1 to 9 do
 +
begin
 +
if ( (not cg[r][c].used) and (size(cg[r][c].values) = 1) ) then
 +
begin
 +
n:=n+1;
 +
applyrules(cg,r,c);
 +
end;
 +
end;
 +
end;
 +
until n = 0;
 +
end;
 +
procedure unique(var cg:cgrid);
 +
var stat:array[1..9] of byte;
 +
r,c,n,gr,gc,count:byte;
 +
t:setnumbers;
 +
s:string;
 +
begin
 +
repeat
 +
count:=0;
 +
//raw
 +
for r:=1 to 9 do
 +
begin
 +
for n:=1 to 9 do
 +
stat[n]:=0;
 +
for c:=1 to 9 do
 +
begin
 +
t:=cg[r][c].values;
 +
if not cg[r][c].used then
 +
for n:=1 to 9 do
 +
if n in t then
 +
stat[n]:=stat[n]+1;
 +
end;
 +
for n:=1 to 9 do
 +
if stat[n] = 1 then
 +
begin
 +
count:=count+1;
 +
for c:=1 to 9 do
 +
if n in cg[r][c].values then
 +
begin
 +
cg[r][c].values:=[n];
 +
applyrules(cg,r,c);
 +
end;
 +
end;
 +
end;
 +
printdebug(cg,g,'raw');
 +
//line
 +
for c:=1 to 9 do
 +
begin
 +
for n:=1 to 9 do
 +
stat[n]:=0;
 +
for r:=1 to 9 do
 +
begin
 +
t:=cg[r][c].values;
 +
if not cg[r][c].used then
 +
for n:=1 to 9 do
 +
if n in t then
 +
stat[n]:=stat[n]+1;
 +
end;
 +
for n:=1 to 9 do
 +
if stat[n] = 1 then
 +
begin
 +
count:=count+1;
 +
for r:=1 to 9 do
 +
if n in cg[r][c].values then
 +
begin
 +
cg[r][c].values:=[n];
 +
applyrules(cg,r,c);
 +
end;
 +
end;
 +
end;
 +
printdebug(cg,g,'line');
 +
//grid
 +
for gr:=0 to 2 do
 +
begin
 +
for gc:=0 to 2 do
 +
begin
 +
for n:=1 to 9 do
 +
stat[n]:=0;
 +
for r:=1+gr*3 to 3+gr*3 do
 +
for c:=1+gc*3 to 3+gc*3 do
 +
begin
 +
t:=cg[r][c].values;
 +
if not cg[r][c].used then
 +
begin
 +
for n:=1 to 9 do
 +
begin
 +
if n in t then
 +
stat[n]:=stat[n]+1;
 +
end;
 +
end;
 +
end;
 +
for n:=1 to 9 do
 +
begin
 +
if stat[n] = 1 then
 +
begin
 +
count:=count+1;
 +
for r:=1+gr*3 to 3+gr*3 do
 +
begin
 +
for c:=1+gc*3 to 3+gc*3 do
 +
begin
 +
if n in cg[r][c].values then
 +
begin
 +
cg[r][c].values:=[n];
 +
applyrules(cg,r,c);
 +
end;
 +
end;
 +
end;
 +
end;
 +
end;
 +
end;
 +
end;
 +
printdebug(cg,g,'grid');
 +
userules(cg);
 +
printdebug(cg,g,'rules');
 +
until count = 0;
 +
end;
 +
function isvalidgrid(cg:cgrid):boolean;
 +
var r,c:byte;
 +
begin
 +
userules(cg);
 +
isvalidgrid:=true;
 +
for r:=1 to 9 do
 +
for c:=1 to 9 do
 +
if size(cg[r][c].values) = 0 then
 +
isvalidgrid:=false;
 +
end;
 +
procedure guess(g:grid);
 +
var cg:cgrid;
 +
gt:grid;
 +
r,c,gr,gc,n:byte;
 +
found:boolean;
 +
v:setnumbers;
 +
s:string;
 +
procedure info(r,c:byte;v:setnumbers);
 +
var n:byte;
 +
begin
 +
write('(',r,',',c,')=[');
 +
for n:=1 to 9 do
 +
if n in v then
 +
write(n);
 +
write('] ');
 +
end;
 +
begin
 +
if count(g) = 81 then
 +
begin
 +
if solutionindex = 0 then
 +
solutions[1] := g
 +
else
 +
if solutionindex = 1 then
 +
solutions[2] := g;
 +
solutionindex := solutionindex+1;
 +
end
 +
else
 +
begin
 +
cinit(cg,g);
 +
found:=false;
 +
for r:=1 to 9 do
 +
for c:=1 to 9 do
 +
if (not found) and (size(cg[r][c].values) > 1) then
 +
begin
 +
found:=true;
 +
gr:=r;
 +
gc:=c;
 +
v:=cg[r][c].values;
 +
end;
 +
for n:=1 to 9 do
 +
if (n in v) and (solutionindex < 2) then
 +
begin
 +
gt:=g;
 +
cinit(cg,gt);
 +
cg[gr][gc].values:=[n];
 +
userules(cg);
 +
unique(cg);
 +
if isvalidgrid(cg) then
 +
begin
 +
if d in [griddebug,cgriddebug,alldebug] then
 +
begin
 +
info(gr,gc,v);
 +
writeln('+',n);
 +
read(s);
 +
end;
 +
extract(cg,gt);
 +
guess(gt);
 +
end
 +
else
 +
if d in [griddebug,cgriddebug,alldebug] then
 +
begin
 +
info(gr,gc,v);
 +
writeln('-',n);
 +
read(s);
 +
end;
 +
end;
 +
end;
 +
end;
 +
procedure selectdebug;
 +
var select:integer;
 +
m:menu;
 +
procedure selected(state:debug);
 +
begin
 +
if state = d then
 +
write('*');
 +
writeln;
 +
end;
 +
begin
 +
initmenu(m);
 +
titlemenu(m,'Debug');
 +
addmenuitem(m,'Sans debug');
 +
addmenuitem(m,'Affichage des grilles');
 +
addmenuitem(m,'Affichage des possibilites');
 +
addmenuitem(m,'Deux affichages precedents');
 +
select:=selectmenu(m);
 +
case select of
 +
1:d:=nodebug;
 +
2:d:=griddebug;
 +
3:d:=cgriddebug;
 +
4:d:=alldebug;
 +
end;
 +
end;
 +
function selectgrid:integer;
 +
var m:menu;
 +
Error:Err;
 +
iHandle:UInt8;
 +
name:^string;
 +
address:MemHandle;
 +
begin
 +
initmenu(m);
 +
titlemenu(m,'Grilles');
 +
Error:=CPDB_Open(0,'SudokuCPDB',dmModeReadOnly,iHandle);
 +
Error:=CPDB_ReadFirst(iHandle);
 +
while Error=NoError do begin
 +
Error:=CPDB_ReadString(iHandle,'NOM',address);
 +
name:=MemHandleLock(address);
 +
writeln(memhandlesize(address));
 +
addmenuitem(m,name^);
 +
MemHandleUnlock(address);
 +
MemHandleFree(address);
 +
Error:=CPDB_ReadNext(iHandle);
 +
end;
 +
// delay(5000);
 +
Error:=CPDB_Close(iHandle);
 +
selectgrid:=selectmenu(m);
 +
end;
 +
procedure solvegrid;
 +
var n:integer;
 +
begin
 +
n:=selectgrid;
 +
if n <> 0 then
 +
begin
 +
clrscr;
 +
sample(g,n);
 +
gridprint(g);
 +
read(s);
 +
clrscr;
 +
cinit(cg,g);
 +
printdebug(cg,g,'init');
 +
userules(cg);
 +
printdebug(cg,g,'rules');
 +
unique(cg);
 +
extract(cg,g);
 +
if count(g) = 81 then
 +
begin
 +
gridprint(g);
 +
if d in [cgriddebug,alldebug] then
 +
cgridprint(cg);
 +
writeln('solution unique');
 +
end
 +
else
 +
begin
 +
if isvalidgrid(cg) then
 +
begin
 +
solutionindex:=0;
 +
guess(g);
 +
if solutionindex = 2 then
 +
begin
 +
gridprint(solutions[1]);
 +
writeln('solutions multiples : 1');
 +
read(s);
 +
gridprint(solutions[2]);
 +
writeln('solutions multiples : 2');
 +
end
 +
else
 +
if solutionindex = 1 then
 +
begin
 +
gridprint(solutions[1]);
 +
writeln('solution unique');
 +
end
 +
else
 +
begin
 +
gridprint(g);
 +
if d in [cgriddebug,alldebug] then
 +
cgridprint(cg);
 +
writeln('aucune solution trouvee');
 +
end;
 +
end
 +
else
 +
begin
 +
gridprint(g);
 +
if d in [cgriddebug,alldebug] then
 +
cgridprint(cg);
 +
writeln('pas de solution; grille erronee');
 +
end;
 +
end;
 +
read(s);
 +
end;
 +
end;
 +
procedure adddb(ihandle:UInt8;name:string;g:grid);
 +
var r,c:integer;
 +
s: array [1..9] of string[10];
 +
Error: Err;
 +
begin
 +
for r:=1 to 9 do
 +
begin
 +
for c:=1 to 9 do
 +
begin
 +
s[r][c]:=Chr(getvalue(g,r,c)+ord('0'));
 +
end;
 +
s[r][10]:=Chr(0);
 +
end;
 +
Error:=CPDB_AddRecord(iHandle);
 +
Error:=CPDB_WriteString(iHandle,'NOM',name);
 +
Error:=CPDB_WriteString(iHandle,'S1',s[1]);
 +
Error:=CPDB_WriteString(iHandle,'S2',s[2]);
 +
Error:=CPDB_WriteString(iHandle,'S3',s[3]);
 +
Error:=CPDB_WriteString(iHandle,'S4',s[4]);
 +
Error:=CPDB_WriteString(iHandle,'S5',s[5]);
 +
Error:=CPDB_WriteString(iHandle,'S6',s[6]);
 +
Error:=CPDB_WriteString(iHandle,'S7',s[7]);
 +
Error:=CPDB_WriteString(iHandle,'S8',s[8]);
 +
Error:=CPDB_WriteString(iHandle,'S9',s[9]);
 +
Error:=CPDB_UpdateRecord(iHandle);
 +
end;
 +
procedure creatdb;
 +
const DBCreator = $54455354; //TEST
 +
var Error: Err;
 +
iHandle: UInt8;
 +
g:grid;
 +
s:string;
 +
begin
 +
if CPDB_DatabaseExist('SudokuCPDB')= CPDB_ERR_NOEXIST then begin
 +
newdb := true;
 +
writeln('Creating SudokuCPDB');
 +
Error:=CPDB_CreateDatabase(0,'SudokuCPDB',DBCreator,'NOM=STRING[41];S1=STRING[10];S2=STRING[10];S3=STRING[10];S4=STRING[10];S5=STRING[10];S6=STRING[10];S7=STRING[10];S8=STRING[10];S9=STRING[10];');
 +
writeln('Opening SudokuCPDB in Read/Write');
 +
Error:=CPDB_Open(0,'SudokuCPDB',dmModeReadWrite,iHandle);
 +
sample(g,1);
 +
adddb(iHandle,'Grille simple',g);
 +
sample(g,2);
 +
adddb(iHandle,'Grille intermediaire',g);
 +
sample(g,3);
 +
adddb(iHandle,'Grille difficile',g);
 +
writeln('Closing SudokuCPDB');
 +
newdb := false;
 +
Error:=CPDB_Close(iHandle);
 +
end;
 +
end;
 +
procedure newgrid;
 +
var m:menu;
 +
select,r,c:integer;
 +
g:grid;
 +
cg:cgrid;
 +
title,t:string;
 +
Error:Err;
 +
iHandle:UInt8;
 +
s:array [1..9] of string;
 +
quit:boolean;
 +
begin
 +
quit:=false;
 +
title:='Sans titre';
 +
init(g);
 +
initmenu(m);
 +
titlemenu(m,'Nouvelle grille');
 +
addmenuitem(m,'Voir');
 +
addmenuitem(m,'Titre');
 +
addmenuitem(m,'Lignes');
 +
addmenuitem(m,'Sauvegarder');
 +
repeat
 +
select:=selectmenu(m);
 +
case select of
 +
0:quit:=true;
 +
1:begin
 +
clrscr;
 +
writeln(' ':5,title);
 +
writeln;
 +
gridprint(g);
 +
read(t);
 +
end;
 +
2:begin
 +
writeln;
 +
write(' Titre : ');
 +
read(title);
 +
end;
 +
3:begin
 +
for r:=1 to 9 do
 +
begin
 +
write(' Ligne '+InTtoString(r)+' : ');
 +
read(s[r]);
 +
c:=1;
 +
while (c <= 9) and (c <= length(s[r])) do
 +
begin
 +
if s[r][c] in ['0'..'9'] then
 +
begin
 +
setvalue(g,r,c,ord(s[r][c])-ord('0'));
 +
end;
 +
c:=c+1;
 +
end;
 +
end;
 +
end;
 +
4:begin
 +
cinit(cg,g);
 +
if isvalidgrid(cg) then
 +
begin
 +
Error:=CPDB_Open(0,'SudokuCPDB',dmModeReadWrite,iHandle);
 +
if Error = 0 then
 +
adddb(iHandle,title,g);
 +
Error:=CPDB_Close(iHandle);
 +
quit:=true;
 +
end
 +
else
 +
begin
 +
writeln;
 +
writeln(' Grille invalide !');
 +
read(t);
 +
end;
 +
end;
 +
end;
 +
until quit = true;
 +
end;
 +
procedure menu2;
 +
var select:integer;
 +
m:menu;
 +
begin
 +
initmenu(m);
 +
titlemenu(m,'Menu');
 +
addmenuitem(m,'Grille');
 +
addmenuitem(m,'Debug');
 +
addmenuitem(m,'Nouvelle grille');
 +
repeat
 +
select:=selectmenu(m);
 +
case select of
 +
1:solvegrid;
 +
2:selectdebug;
 +
3:newgrid;
 +
end;
 +
until select = 0;
 +
clrscr;
 +
writeln;
 +
writeln;
 +
writeln;
 +
writeln(' ':5,'A bientot');
 +
end;
 +
begin
 +
CPDB_OPENLIB;
 +
newdb := false;
 +
creatdb;
 +
// nodebug
 +
// griddebug
 +
// cgriddebug
 +
// alldebug
 +
d:=nodebug;
 +
menu2;
 +
CPDB_CLOSELIB;
 +
end.
</code>
</code>
[[Category:Source]]
[[Category:Source]]

Version actuelle

Sudoku 

  1. program sudoku;
  2. {$i PalmAPI.pas}
  3. {$i PPlib.pas}
  4. {$i Menu.pas}
  5. {$i CPDBSTD4PP.pas}
  6. const numbergrids = 12;
  7.  NoError = 0;
  8. //  SYSTRAP = $4E4F;
  9. type
  10. // byte = 0..255;
  11.  numbers = 1..9;
  12.  setnumbers = set of numbers;
  13.  possible = record
  14.   values : setnumbers;
  15.   used : boolean;    
  16.  end;
  17.  grid = array[1..9,1..9] of byte;
  18.  cgrid = array[1..9,1..9] of possible;
  19.  debug = (nodebug,griddebug,cgriddebug,alldebug);
  20. var g:grid;
  21.  cg:cgrid;
  22.  solutions:array[1..2] of grid;
  23.  solutionindex:byte;
  24.  d:debug;
  25.  s:string;
  26.  newdb:boolean;
  27. //function StrAToI(const S:string):integer; inline(SYSTRAP,$a0ce);
  28. function isvalidindex(index:byte):boolean;
  29. begin
  30.  if ( (index >= 1) and (index <= 9) ) then
  31.   isvalidindex:=true
  32.  else
  33.   isvalidindex:=false;
  34. end;
  35. function isvalidvalue(value:byte):boolean;
  36. begin
  37.  if ( (value >= 0) and (value <= 9) ) then
  38.   isvalidvalue:=true
  39.  else
  40.   isvalidvalue:=false;
  41. end;
  42. function getvalue(g:grid;raw,column:byte):byte;
  43. begin
  44.  if ( isvalidindex(raw) and isvalidindex(column) ) then
  45.   getvalue:=g[raw][column]
  46.  else
  47.   getvalue:=0;
  48. end;
  49. procedure setvalue(var g:grid;raw,column,value:byte);
  50. begin
  51.  if ( isvalidindex(raw) and isvalidindex(column) and isvalidvalue(value) ) then
  52.  begin
  53.   g[raw][column]:=value;
  54.  end;
  55. end;
  56. procedure gridprint(g:grid);
  57. var r,c,t:byte;
  58. begin
  59.  write('|');
  60.  for c:= 1 to 23 do
  61.   write('-');
  62.  writeln('|');
  63.  for r:= 1 to 9 do
  64.  begin
  65.   write('| ');
  66.   for c:= 1 to 9 do
  67.   begin
  68.    t:=getvalue(g,r,c);
  69.    if ( t<>0 ) then
  70.     write(t)
  71.    else
  72.     write(' ');
  73.    write(' ');
  74.    if ( c mod 3 = 0 ) then
  75.     write('| ');
  76.   end;
  77.   writeln;
  78.   if ( r mod 3 = 0 ) then
  79.   begin
  80.     write('|');
  81.    for c:= 1 to 23 do
  82.     write('-');
  83.    writeln('|');
  84.   end;
  85.  end;
  86. end;
  87. procedure cgridprint(cg:cgrid);
  88. var r,c,n:byte;
  89.  t:setnumbers;
  90. begin
  91.  for r:=1 to 9 do
  92.  begin
  93.   for c:=1 to 9 do
  94.   begin
  95.    t:=cg[r][c].values;
  96.    for n:=1 to 9 do
  97.     if n in t then
  98.      write(n);
  99.    if c<>9 then
  100.     write('|');
  101.   end;
  102.   writeln;
  103.  end;
  104. end;
  105. procedure init(var g:grid);
  106. var r,c:byte;
  107. begin
  108.  for r:= 1 to 9 do
  109.  begin
  110.   for c:= 1 to 9 do
  111.   begin
  112.    setvalue(g,r,c,0);
  113.   end;
  114.  end;
  115. end;
  116. function count(g:grid):byte;
  117. var r,c,n:byte;
  118. begin
  119.  n:=0;
  120.  for r:= 1 to 9 do
  121.  begin
  122.   for c:= 1 to 9 do
  123.   begin
  124.    if ( getvalue(g,r,c) <> 0 ) then
  125.     n:=n+1;
  126.   end;
  127.  end;
  128.  count:=n;
  129. end;
  130. function size(s:setnumbers):byte;
  131. var t,n:byte;
  132. begin
  133.  n:=0;
  134.  for t:=1 to 9 do
  135.  begin
  136.   if (t in s) then
  137.    n:=n+1;
  138.  end;
  139.  size:=n;
  140. end;
  141. procedure sample(var g:grid;n:byte);
  142. var s:array [1..9] of string[9];
  143.  r,c:byte;
  144.  iHandle:UInt8;
  145.  Error:Err;
  146.  address:MemHandle;
  147.  t:string;
  148. function num(c:char):byte;
  149. begin
  150.  num:=ord(c)-ord('0');
  151. end;
  152. function readstring(name:string):string;
  153. var line:^string;
  154.  temp:string;
  155. begin
  156.  Error:=CPDB_ReadString(iHandle,name,address);
  157.  line:=MemHandleLock(address);
  158.  temp:=line^;
  159.  Error:=MemHandleUnlock(address);
  160.  Error:=MemHandleFree(address);
  161.  readstring:=temp;
  162. end;
  163. begin
  164.  if not newdb then
  165.  begin
  166.  Error:=CPDB_Open(0,'SudokuCPDB',dmModeReadOnly,iHandle);
  167.  Error:=CPDB_SeekDirect(iHandle,n);
  168.  s[1]:=readstring('S1');
  169.  s[2]:=readstring('S2');
  170.  s[3]:=readstring('S3');
  171.  s[4]:=readstring('S4');
  172.  s[5]:=readstring('S5');
  173.  s[6]:=readstring('S6');
  174.  s[7]:=readstring('S7');
  175.  s[8]:=readstring('S8');
  176.  s[9]:=readstring('S9');
  177.  Error:=CPDB_Close(iHandle);
  178.  end;
  179.  if newdb then
  180.  begin
  181.  case n of
  182.   1:
  183.   begin
  184.    s[1]:='087060310';
  185.    s[2]:='200501006';
  186.    s[3]:='016387450';
  187.    s[4]:='002906700';
  188.    s[5]:='075000690';
  189.    s[6]:='000030005';
  190.    s[7]:='001209500';
  191.    s[8]:='403010900';
  192.    s[9]:='750000080';
  193.   end;
  194.   2:
  195.   begin
  196.    s[1]:='006730020';
  197.    s[2]:='870090000';
  198.    s[3]:='400000800';
  199.    s[4]:='000200010';
  200.    s[5]:='060040050';
  201.    s[6]:='080003000';
  202.    s[7]:='004000009';
  203.    s[8]:='000050076';
  204.    s[9]:='020079300';
  205.   end;
  206.   3:
  207.   begin
  208.    s[1]:='050002004';
  209.    s[2]:='000000010';
  210.    s[3]:='000007506';
  211.    s[4]:='200030900';
  212.    s[5]:='087060130';
  213.    s[6]:='006080005';
  214.    s[7]:='309500000';
  215.    s[8]:='020000000';
  216.    s[9]:='400900080';
  217.   end;
  218.  end;
  219.  end;
  220.  
  221.    init(g);
  222.    for r:=1 to 9 do
  223.    begin
  224.     for c:=1 to 9 do
  225.     begin
  226.      setvalue(g,r,c,num(s[r][c]));
  227.     end;
  228.    end;
  229. end;
  230. procedure extract(cg:cgrid;var g:grid);
  231. var r,c,n:byte;
  232.  t:setnumbers;
  233. begin
  234.  init(g);
  235.  for r:=1 to 9 do
  236.  begin
  237.   for c:=1 to 9 do
  238.   begin
  239.    t:= cg[r][c].values;
  240.    if ( size(t) = 1 ) then
  241.    begin
  242.     for n:= 1 to 9 do
  243.      if ( n in t ) then
  244.       setvalue(g,r,c,n);
  245.    end
  246.    else
  247.     setvalue(g,r,c,0);
  248.   end;
  249.  end;
  250. end;
  251. procedure printdebug(cg:cgrid;g:grid;s:string);
  252. var c:string;
  253. begin
  254.  if d in [griddebug,cgriddebug,alldebug] then
  255.  begin
  256.   writeln(s);
  257.   extract(cg,g);
  258.  end;
  259.  if d in [griddebug,alldebug] then
  260.  begin
  261.   gridprint(g);
  262.   read(c);
  263.  end;
  264.  if d in [cgriddebug,alldebug] then
  265.  begin
  266.   cgridprint(cg);
  267.   read(c);
  268.  end;
  269. end;
  270. procedure applyrules(var cg:cgrid;r,c:byte);
  271. var v:setnumbers;
  272.  n,gr,gc,nr,nc:byte;
  273. begin
  274.  if (isvalidindex(r) and isvalidindex(c)) then
  275.  begin
  276.   if ( size(cg[r][c].values) = 1 ) then
  277.   begin
  278.    cg[r][c].used:=true;
  279.    v:=cg[r][c].values;
  280.    // raw
  281.    for n:=1 to 9 do
  282.    begin
  283.     if n <> c then
  284.     begin
  285.      cg[r][n].values:=cg[r][n].values - v;
  286.     end;
  287.    end;
  288.    // column
  289.    for n:=1 to 9 do
  290.    begin
  291.     if n <> r then
  292.     begin
  293.      cg[n][c].values:=cg[n][c].values - v;
  294.     end;
  295.    end;
  296.    // grid
  297.    gr:=((r-1) div 3)*3;
  298.    gc:=((c-1) div 3)*3;
  299.    for nr:=1+gr to 3+gr do
  300.    begin
  301.     for nc:=1+gc to 3+gc do
  302.     begin
  303.      if (nr <> r) and (nc <> c) then
  304.      begin
  305.       cg[nr][nc].values:=cg[nr][nc].values - v;
  306.      end;     
  307.     end;
  308.    end;
  309.   end; 
  310.  end;
  311. end;
  312. procedure cinit(var cg:cgrid;g:grid);
  313. var r,c,t:byte;
  314. begin
  315.  for r:= 1 to 9 do
  316.  begin
  317.   for c:= 1 to 9 do
  318.   begin
  319.    cg[r][c].values:=[1..9];
  320.    cg[r][c].used:=false;
  321.   end;
  322.  end;
  323.  for r:= 1 to 9 do
  324.  begin
  325.   for c:= 1 to 9 do
  326.   begin
  327.    if ( getvalue(g,r,c) <> 0 ) then
  328.    begin
  329.     cg[r][c].values:=[getvalue(g,r,c)];    
  330.     applyrules(cg,r,c);
  331.    end;
  332.   end;
  333.  end;
  334. end;
  335. procedure userules(var cg:cgrid);
  336. var r,c,n:byte;
  337. begin
  338.  repeat
  339.   n:=0;
  340.   for r:=1 to 9 do
  341.   begin
  342.    for c:=1 to 9 do
  343.    begin
  344.     if ( (not cg[r][c].used) and (size(cg[r][c].values) = 1) ) then
  345.     begin
  346.      n:=n+1;
  347.      applyrules(cg,r,c);
  348.     end;
  349.    end;
  350.   end;
  351.  until n = 0;
  352. end;
  353. procedure unique(var cg:cgrid);
  354. var stat:array[1..9] of byte;
  355.  r,c,n,gr,gc,count:byte;
  356.  t:setnumbers;
  357.  s:string;
  358. begin
  359. repeat
  360.  count:=0;
  361.  //raw
  362.  for r:=1 to 9 do
  363.  begin
  364.   for n:=1 to 9 do
  365.    stat[n]:=0;
  366.   for c:=1 to 9 do
  367.   begin
  368.    t:=cg[r][c].values;
  369.    if not cg[r][c].used then
  370.     for n:=1 to 9 do
  371.      if n in t then
  372.       stat[n]:=stat[n]+1;
  373.   end;
  374.   for n:=1 to 9 do
  375.    if stat[n] = 1 then
  376.    begin
  377.     count:=count+1;
  378.     for c:=1 to 9 do
  379.      if n in cg[r][c].values then
  380.      begin
  381.       cg[r][c].values:=[n];
  382.       applyrules(cg,r,c);
  383.      end;
  384.    end;
  385.  end;
  386.  printdebug(cg,g,'raw');
  387.  //line
  388.  for c:=1 to 9 do
  389.  begin
  390.   for n:=1 to 9 do
  391.    stat[n]:=0;
  392.   for r:=1 to 9 do
  393.   begin
  394.    t:=cg[r][c].values;
  395.    if not cg[r][c].used then
  396.     for n:=1 to 9 do
  397.      if n in t then
  398.       stat[n]:=stat[n]+1;
  399.   end;
  400.   for n:=1 to 9 do
  401.    if stat[n] = 1 then
  402.    begin
  403.     count:=count+1;
  404.     for r:=1 to 9 do
  405.      if n in cg[r][c].values then
  406.      begin
  407.       cg[r][c].values:=[n];
  408.       applyrules(cg,r,c);
  409.      end;
  410.    end;
  411.  end;
  412.  printdebug(cg,g,'line');
  413.  //grid
  414.  for gr:=0 to 2 do
  415.  begin
  416.   for gc:=0 to 2 do
  417.   begin
  418.    for n:=1 to 9 do
  419.     stat[n]:=0;
  420.    for r:=1+gr*3 to 3+gr*3 do
  421.     for c:=1+gc*3 to 3+gc*3 do
  422.     begin
  423.      t:=cg[r][c].values;
  424.      if not cg[r][c].used then
  425.      begin
  426.       for n:=1 to 9 do
  427.       begin
  428.        if n in t then
  429.         stat[n]:=stat[n]+1;
  430.       end;
  431.      end;
  432.     end;
  433.    for n:=1 to 9 do
  434.    begin
  435.     if stat[n] = 1 then
  436.     begin
  437.      count:=count+1;
  438.      for r:=1+gr*3 to 3+gr*3 do
  439.      begin
  440.       for c:=1+gc*3 to 3+gc*3 do
  441.       begin
  442.        if n in cg[r][c].values then
  443.        begin
  444.         cg[r][c].values:=[n];
  445.         applyrules(cg,r,c);
  446.        end;
  447.       end;
  448.      end;
  449.     end;
  450.    end;
  451.   end;
  452.  end;
  453.  printdebug(cg,g,'grid');
  454.  userules(cg);
  455.  printdebug(cg,g,'rules');
  456. until count = 0;
  457. end;
  458. function isvalidgrid(cg:cgrid):boolean;
  459. var r,c:byte;
  460. begin
  461.  userules(cg);
  462.  isvalidgrid:=true;
  463.  for r:=1 to 9 do
  464.   for c:=1 to 9 do
  465.    if size(cg[r][c].values) = 0 then
  466.      isvalidgrid:=false;
  467. end;
  468. procedure guess(g:grid);
  469. var cg:cgrid;
  470.  gt:grid;
  471.  r,c,gr,gc,n:byte;
  472.  found:boolean;
  473.  v:setnumbers;
  474.  s:string;
  475. procedure info(r,c:byte;v:setnumbers);
  476. var n:byte;
  477. begin
  478.   write('(',r,',',c,')=[');
  479.   for n:=1 to 9 do
  480.    if n in v then
  481.     write(n);
  482.   write('] ');
  483. end;
  484. begin
  485.  if count(g) = 81 then
  486.  begin
  487.   if solutionindex = 0 then
  488.    solutions[1] := g
  489.   else
  490.    if solutionindex = 1 then
  491.     solutions[2] := g;
  492.   solutionindex := solutionindex+1;
  493.  end
  494.  else
  495.  begin
  496.   cinit(cg,g);
  497.   found:=false;
  498.   for r:=1 to 9 do
  499.    for c:=1 to 9 do
  500.     if (not found) and (size(cg[r][c].values) > 1) then
  501.     begin
  502.      found:=true;
  503.      gr:=r;
  504.      gc:=c;
  505.      v:=cg[r][c].values;
  506.     end;
  507.   for n:=1 to 9 do
  508.    if (n in v) and (solutionindex < 2) then
  509.    begin
  510.     gt:=g;
  511.     cinit(cg,gt);
  512.     cg[gr][gc].values:=[n];
  513.     userules(cg);
  514.     unique(cg);
  515.     if isvalidgrid(cg) then
  516.     begin
  517.      if d in [griddebug,cgriddebug,alldebug] then
  518.      begin
  519.       info(gr,gc,v);
  520.       writeln('+',n);
  521.       read(s);
  522.      end;
  523.      extract(cg,gt);
  524.      guess(gt);
  525.     end
  526.     else
  527.      if d in [griddebug,cgriddebug,alldebug] then
  528.      begin
  529.       info(gr,gc,v);
  530.       writeln('-',n);
  531.       read(s);
  532.      end;
  533.    end;
  534.  end;
  535. end;
  536. procedure selectdebug;
  537. var select:integer;
  538.  m:menu;
  539. procedure selected(state:debug);
  540. begin
  541.  if state = d then
  542.   write('*');
  543.  writeln;
  544. end;
  545. begin
  546.  initmenu(m);
  547.  titlemenu(m,'Debug');
  548.  addmenuitem(m,'Sans debug');
  549.  addmenuitem(m,'Affichage des grilles');
  550.  addmenuitem(m,'Affichage des possibilites');
  551.  addmenuitem(m,'Deux affichages precedents');
  552.  select:=selectmenu(m);
  553.  case select of
  554.   1:d:=nodebug;
  555.   2:d:=griddebug;
  556.   3:d:=cgriddebug;
  557.   4:d:=alldebug;
  558.  end;
  559. end;
  560. function selectgrid:integer;
  561. var m:menu;
  562.  Error:Err;
  563.  iHandle:UInt8;
  564.  name:^string;
  565.  address:MemHandle;
  566. begin
  567.  initmenu(m);
  568.  titlemenu(m,'Grilles');
  569.  Error:=CPDB_Open(0,'SudokuCPDB',dmModeReadOnly,iHandle);
  570.  Error:=CPDB_ReadFirst(iHandle);
  571.  while Error=NoError do begin
  572.   Error:=CPDB_ReadString(iHandle,'NOM',address);
  573.   name:=MemHandleLock(address);
  574.   writeln(memhandlesize(address));
  575.   addmenuitem(m,name^);
  576.   MemHandleUnlock(address);
  577.   MemHandleFree(address);
  578.   Error:=CPDB_ReadNext(iHandle);
  579.  end;
  580. // delay(5000);
  581.  Error:=CPDB_Close(iHandle);
  582.  selectgrid:=selectmenu(m);
  583. end;
  584. procedure solvegrid;
  585. var n:integer;
  586. begin
  587.  n:=selectgrid;
  588.  if n <> 0 then
  589.  begin
  590.  clrscr;
  591.  sample(g,n);
  592.  gridprint(g);
  593.  read(s);
  594.  clrscr;
  595.  cinit(cg,g);
  596.  printdebug(cg,g,'init');
  597.  userules(cg);
  598.  printdebug(cg,g,'rules');
  599.  unique(cg);
  600.  extract(cg,g);
  601.  if count(g) = 81 then
  602.  begin
  603.   gridprint(g);
  604.   if d in [cgriddebug,alldebug] then 
  605.    cgridprint(cg);
  606.   writeln('solution unique');
  607.  end
  608.  else
  609.  begin
  610.   if isvalidgrid(cg) then
  611.   begin
  612.    solutionindex:=0;
  613.    guess(g);
  614.    if solutionindex = 2 then
  615.    begin
  616.     gridprint(solutions[1]);
  617.     writeln('solutions multiples : 1');
  618.     read(s);
  619.     gridprint(solutions[2]);    
  620.     writeln('solutions multiples : 2');
  621.    end
  622.    else
  623.     if solutionindex = 1 then
  624.     begin
  625.      gridprint(solutions[1]);
  626.      writeln('solution unique');
  627.     end
  628.     else
  629.     begin
  630.      gridprint(g);
  631.      if d in [cgriddebug,alldebug] then 
  632.       cgridprint(cg);
  633.      writeln('aucune solution trouvee');
  634.     end;
  635.   end
  636.   else
  637.   begin
  638.    gridprint(g);
  639.    if d in [cgriddebug,alldebug] then 
  640.     cgridprint(cg);
  641.    writeln('pas de solution; grille erronee');
  642.   end;
  643.  end;
  644.  read(s);
  645.  end;
  646. end;
  647. procedure adddb(ihandle:UInt8;name:string;g:grid);
  648. var r,c:integer;
  649.  s: array [1..9] of string[10];
  650.  Error: Err;
  651. begin
  652.  for r:=1 to 9 do
  653.  begin
  654.   for c:=1 to 9 do
  655.   begin
  656.    s[r][c]:=Chr(getvalue(g,r,c)+ord('0'));
  657.   end;
  658.   s[r][10]:=Chr(0);
  659.  end; 
  660.  Error:=CPDB_AddRecord(iHandle);
  661.  Error:=CPDB_WriteString(iHandle,'NOM',name);
  662.  Error:=CPDB_WriteString(iHandle,'S1',s[1]);
  663.  Error:=CPDB_WriteString(iHandle,'S2',s[2]);
  664.  Error:=CPDB_WriteString(iHandle,'S3',s[3]);
  665.  Error:=CPDB_WriteString(iHandle,'S4',s[4]);
  666.  Error:=CPDB_WriteString(iHandle,'S5',s[5]);
  667.  Error:=CPDB_WriteString(iHandle,'S6',s[6]);
  668.  Error:=CPDB_WriteString(iHandle,'S7',s[7]);
  669.  Error:=CPDB_WriteString(iHandle,'S8',s[8]);
  670.  Error:=CPDB_WriteString(iHandle,'S9',s[9]);
  671.  Error:=CPDB_UpdateRecord(iHandle);
  672. end;
  673. procedure creatdb;
  674. const DBCreator = $54455354; //TEST
  675. var Error: Err;
  676.  iHandle: UInt8;
  677.  g:grid;
  678.  s:string;
  679. begin
  680.   if CPDB_DatabaseExist('SudokuCPDB')= CPDB_ERR_NOEXIST then begin
  681.    newdb := true;
  682.    writeln('Creating SudokuCPDB');
  683.    Error:=CPDB_CreateDatabase(0,'SudokuCPDB',DBCreator,'NOM=STRING[41];S1=STRING[10];S2=STRING[10];S3=STRING[10];S4=STRING[10];S5=STRING[10];S6=STRING[10];S7=STRING[10];S8=STRING[10];S9=STRING[10];');
  684.    writeln('Opening SudokuCPDB in Read/Write');
  685.    Error:=CPDB_Open(0,'SudokuCPDB',dmModeReadWrite,iHandle);
  686.    sample(g,1);
  687.    adddb(iHandle,'Grille simple',g);
  688.    sample(g,2);
  689.    adddb(iHandle,'Grille intermediaire',g);
  690.    sample(g,3);
  691.    adddb(iHandle,'Grille difficile',g);
  692.    writeln('Closing SudokuCPDB');
  693.    newdb := false;
  694.    Error:=CPDB_Close(iHandle);
  695.  end;
  696. end;
  697. procedure newgrid;
  698. var m:menu;
  699.  select,r,c:integer;
  700.  g:grid;
  701.  cg:cgrid;
  702.  title,t:string;
  703.  Error:Err;
  704.  iHandle:UInt8;
  705.  s:array [1..9] of string;
  706.  quit:boolean;
  707. begin
  708.  quit:=false;
  709.  title:='Sans titre';
  710.  init(g);
  711.  initmenu(m);
  712.  titlemenu(m,'Nouvelle grille');
  713.  addmenuitem(m,'Voir');
  714.  addmenuitem(m,'Titre');
  715.  addmenuitem(m,'Lignes');
  716.  addmenuitem(m,'Sauvegarder');
  717.  repeat
  718.   select:=selectmenu(m);
  719.   case select of
  720.    0:quit:=true;
  721.    1:begin
  722.     clrscr;
  723.     writeln(' ':5,title);
  724.     writeln;
  725.     gridprint(g);
  726.     read(t);
  727.    end;
  728.    2:begin
  729.     writeln;
  730.     write('     Titre : ');
  731.     read(title);
  732.    end;
  733.    3:begin
  734.     for r:=1 to 9 do
  735.     begin
  736.      write('     Ligne '+InTtoString(r)+' : ');
  737.      read(s[r]);
  738.      c:=1;
  739.      while (c <= 9) and (c <= length(s[r])) do
  740.      begin
  741.       if s[r][c] in ['0'..'9'] then
  742.       begin
  743.        setvalue(g,r,c,ord(s[r][c])-ord('0'));
  744.       end;
  745.       c:=c+1;
  746.      end;
  747.     end;
  748.    end;
  749.    4:begin
  750.     cinit(cg,g);
  751.     if isvalidgrid(cg) then
  752.     begin
  753.      Error:=CPDB_Open(0,'SudokuCPDB',dmModeReadWrite,iHandle);
  754.      if Error = 0 then
  755.       adddb(iHandle,title,g);
  756.      Error:=CPDB_Close(iHandle);
  757.      quit:=true;
  758.     end
  759.     else
  760.     begin
  761.      writeln;
  762.      writeln('     Grille invalide !');
  763.      read(t);
  764.     end;
  765.    end;
  766.   end;
  767.  until quit = true;
  768. end;
  769. procedure menu2;
  770. var select:integer;
  771.  m:menu;
  772. begin
  773.  initmenu(m);
  774.  titlemenu(m,'Menu');
  775.  addmenuitem(m,'Grille');
  776.  addmenuitem(m,'Debug');
  777.  addmenuitem(m,'Nouvelle grille');
  778.  repeat
  779.   select:=selectmenu(m);
  780.   case select of
  781.    1:solvegrid;
  782.    2:selectdebug;
  783.    3:newgrid;
  784.   end;
  785.  until select = 0;
  786.  clrscr;
  787.  writeln;
  788.  writeln;
  789.  writeln;
  790.  writeln(' ':5,'A bientot');
  791. end;
  792. begin
  793.  CPDB_OPENLIB;
  794.  newdb := false;
  795.  creatdb;
  796.  // nodebug
  797.  // griddebug
  798.  // cgriddebug
  799.  // alldebug
  800.  d:=nodebug;
  801.  menu2;
  802.  CPDB_CLOSELIB;
  803. end.
Récupérée de « http://zigloo.ch/index.php/Sudoku.pas »