Sudoku.pas

Un article de Wikipedia.

  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.