Sudoku.pas

Un article de Wikipedia.

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.