Cassetete.pas

Un article de Wikipedia.

Casse-tête des blocs dans la boîte

  1. program pieceboite;
  2. {$i PalmAPI.pas}
  3. {$i PPlib.pas}
  4. {$i Menu.pas}
  5. {$i CPDBSTD4PP.pas}
  6. const nx = 5;
  7. ny = 5;
  8. nz = 5;
  9. bd = 'CasseteteCPDB';
  10. DBCreator = $54455354; //TEST
  11. type etat = (vide,occupe);
  12. tboite = array [1..nx,1..ny,1..nz] of etat;
  13. //byte = 0..255;
  14. tdimpiece = record
  15. dx,dy,dz:byte;
  16. end;
  17. plpiece = ^tlpiece;
  18. tlpiece = record
  19. genre : byte;
  20. piece : tdimpiece;
  21. suivant : plpiece;
  22. end;
  23. plgenre = ^tlgenre;
  24. tlgenre = record
  25. genre : byte;
  26. nombre : byte;
  27. suivant : plgenre;
  28. end;
  29. tposition = record
  30. px,py,pz : byte;
  31. end;
  32. var boite : tboite;
  33. listepiece : plpiece;
  34. listegenre : plgenre;
  35. operation : integer;
  36. sauvegarder,calculer : boolean;
  37. genre : integer;
  38. function convertint(h,l:Int16):integer;
  39. var resultat:integer;
  40. begin
  41. resultat := h;
  42. resultat := (resultat shl 15) + l;
  43. convertint := resultat;
  44. end;
  45. function bdexiste:boolean;
  46. begin
  47. if CPDB_DatabaseExist(bd)= CPDB_ERR_NOEXIST then
  48. bdexiste := false
  49. else
  50. bdexiste := true;
  51. end;
  52. procedure creerbd;
  53. var Error : Err;
  54. begin
  55. if not bdexiste then
  56. begin
  57. Error:=CPDB_CreateDatabase(0,bd,DBCreator,'GH=INT;GL=INT;NH=INT;NL=INT;DUREE=INT;PX=SHORTINT;PY=SHORTINT;PZ=SHORTINT;DX=SHORTINT;DY=SHORTINT;DZ=SHORTINT;');
  58. end;
  59. end;
  60. function genreexistebd:boolean;
  61. var Error : Err;
  62. iHandle : UInt8;
  63. g : integer;
  64. gh,gl : Int16;
  65. trouve : boolean;
  66. begin
  67. trouve := false;
  68. creerbd;
  69. Error:=CPDB_Open(0,bd,dmModeReadOnly,iHandle);
  70. Error:=CPDB_ReadFirst(iHandle);
  71. while (Error=0) and (not trouve) do
  72. begin
  73. Error:=CPDB_ReadInt(iHandle,'GH',gh);
  74. Error:=CPDB_ReadInt(iHandle,'GL',gl);
  75. g := convertint(gh,gl);
  76. if g = genre then
  77. trouve := true;
  78. Error:=CPDB_ReadNext(iHandle);
  79. end;
  80. Error:=CPDB_Close(iHandle);
  81. genreexistebd := trouve;
  82. end;
  83. procedure effacerentree;
  84. var Error : Err;
  85. iHandle : UInt8;
  86. g : integer;
  87. gh,gl : Int16;
  88. trouve : boolean;
  89. begin
  90. while genreexistebd do
  91. begin
  92. Error:=CPDB_Open(0,bd,dmModeReadWrite,iHandle);
  93. Error:=CPDB_ReadFirst(iHandle);
  94. while Error=0 do
  95. begin
  96. Error:=CPDB_ReadInt(iHandle,'GH',gh);
  97. Error:=CPDB_ReadInt(iHandle,'GL',gl);
  98. g := convertint(gh,gl);
  99. if g = genre then
  100. begin
  101. CPDB_DeleteRecord(iHandle);
  102. end;
  103. Error:=CPDB_ReadNext(iHandle);
  104. end;
  105. Error:=CPDB_Close(iHandle);
  106. end;
  107. end;
  108. procedure ajouterbd(piece:plpiece;pos:tposition);
  109. var Error : Err;
  110. iHandle :UInt8;
  111. begin
  112. if piece <> nil then
  113. begin
  114. creerbd;
  115. Error:=CPDB_Open(0,bd,dmModeReadWrite,iHandle);
  116. Error:=CPDB_AddRecord(iHandle);
  117. with pos,piece^.piece do
  118. begin
  119. Error:=CPDB_WriteInt(iHandle,'GH',genre shr 15);
  120. Error:=CPDB_WriteInt(iHandle,'GL',genre mod 32768);
  121. Error:=CPDB_WriteInt(iHandle,'NH',operation shr 15);
  122. Error:=CPDB_WriteInt(iHandle,'NL',operation mod 32768);
  123. Error:=CPDB_WriteInt(iHandle,'DUREE',0);
  124. Error:=CPDB_WriteShortInt(iHandle,'PX',px);
  125. Error:=CPDB_WriteShortInt(iHandle,'PY',py);
  126. Error:=CPDB_WriteShortInt(iHandle,'PZ',pz);
  127. Error:=CPDB_WriteShortInt(iHandle,'DX',dx);
  128. Error:=CPDB_WriteShortInt(iHandle,'DY',dy);
  129. Error:=CPDB_WriteShortInt(iHandle,'DZ',dz);
  130. end;
  131. Error:=CPDB_UpdateRecord(iHandle);
  132. Error:=CPDB_Close(iHandle);
  133. end;
  134. end;
  135. procedure ajouterbd2(g,n,d:integer);
  136. var Error : Err;
  137. iHandle : UInt8;
  138. gbd : integer;
  139. gh,gl : Int16;
  140. begin
  141. creerbd;
  142. Error:=CPDB_Open(0,bd,dmModeReadWrite,iHandle);
  143. Error:=CPDB_ReadFirst(iHandle);
  144. while Error=0 do
  145. begin
  146. Error:=CPDB_ReadInt(iHandle,'GH',gh);
  147. Error:=CPDB_ReadInt(iHandle,'GL',gl);
  148. gbd := convertint(gh,gl);
  149. if gbd = g then
  150. begin
  151. Error:=CPDB_WriteInt(iHandle,'DUREE',d);
  152. Error:=CPDB_WriteInt(iHandle,'NH',n shr 15);
  153. Error:=CPDB_WriteInt(iHandle,'NL',n mod 32768);
  154. Error:=CPDB_UpdateRecord(iHandle);
  155. end;
  156. Error:=CPDB_ReadNext(iHandle);
  157. end;
  158. Error:=CPDB_Close(iHandle);
  159. end;
  160. function maximum(a,b:integer):integer;
  161. begin
  162. if a >= b then
  163. maximum := a
  164. else
  165. maximum := b;
  166. end;
  167. function minimum(a,b:integer):integer;
  168. begin
  169. if a <= b then
  170. minimum := a
  171. else
  172. minimum := b;
  173. end;
  174. function nombre:integer;
  175. var x,y,z : byte;
  176. n : integer;
  177. begin
  178. n := 0;
  179. for z := 1 to nz do
  180. for y := 1 to ny do
  181. for x := 1 to nx do
  182. if boite[x,y,z] = vide then
  183. n := n+1;
  184. nombre := n;
  185. end;
  186. procedure definirpiece(quantite:byte;dimx,dimy,dimz:byte);
  187. var x,y,z : byte;
  188. templgenre : plgenre;
  189. tempngenre : byte;
  190. procedure orientation(dimx,dimy,dimz:byte);
  191. var templpiece : plpiece;
  192. begin
  193. if listepiece = nil then
  194. begin
  195. new(listepiece);
  196. templpiece := listepiece;
  197. end
  198. else
  199. begin
  200. templpiece := listepiece;
  201. while templpiece^.suivant <> nil do
  202. templpiece := templpiece^.suivant;
  203. new(templpiece^.suivant);
  204. templpiece := templpiece^.suivant;
  205. end;
  206. templpiece^.genre := templgenre^.genre;
  207. templpiece^.suivant := nil;
  208. with templpiece^.piece do
  209. begin
  210. dx := dimx;
  211. dy := dimy;
  212. dz := dimz;
  213. end;
  214. end;
  215. begin
  216. if listegenre = nil then
  217. begin
  218. new(listegenre);
  219. with listegenre^ do
  220. begin
  221. genre := 1;
  222. nombre := quantite;
  223. suivant := nil;
  224. end;
  225. templgenre := listegenre;
  226. end
  227. else
  228. begin
  229. templgenre := listegenre;
  230. while templgenre^.suivant <> nil do
  231. templgenre := templgenre^.suivant;
  232. tempngenre := templgenre^.genre;
  233. new(templgenre^.suivant);
  234. templgenre := templgenre^.suivant;
  235. with templgenre^ do
  236. begin
  237. genre := tempngenre+1;
  238. nombre := quantite;
  239. suivant := nil;
  240. end;
  241. end;
  242. x := dimx;
  243. y := dimy;
  244. z := dimz;
  245. if dimy = dimz then
  246. begin
  247. x := dimz;
  248. z := dimx;
  249. end;
  250. if dimx = dimz then
  251. begin
  252. y := dimz;
  253. z := dimy;
  254. end;
  255. if x = y then
  256. if y = z then orientation(x,x,x)
  257. else
  258. begin
  259. orientation(x,x,z);
  260. orientation(x,z,x);
  261. orientation(z,x,x);
  262. end
  263. else
  264. begin
  265. orientation(x,y,z);
  266. orientation(x,z,y);
  267. orientation(y,z,x);
  268. orientation(y,x,z);
  269. orientation(z,x,y);
  270. orientation(z,y,x);
  271. end;
  272. end;
  273. procedure position(var pos:tposition; x,y,z:byte);
  274. begin
  275. pos.px := x;
  276. pos.py := y;
  277. pos.pz := z;
  278. end;
  279. function peutplacerpiece(piece:plpiece; pos:tposition):boolean;
  280. var x,y,z:byte;
  281. begin
  282. if piece <> nil then
  283. begin
  284. peutplacerpiece := true;
  285. with pos,piece^.piece do
  286. if (pz+dz-1 <= nz) and (py+dy-1 <= ny) and (px+dx-1 <= nx) then
  287. begin
  288. for z := pz to pz+dz-1 do
  289. for y := py to py+dy-1 do
  290. for x := px to px+dx-1 do
  291. if boite[x,y,z] = occupe then
  292. peutplacerpiece := false;
  293. end
  294. else
  295. peutplacerpiece := false;
  296. end
  297. else
  298. peutplacerpiece := false;
  299. end;
  300. procedure cherchepiece(var piece:plpiece; pos:tposition);
  301. var lp : plpiece;
  302. lg : plgenre;
  303. trouve : boolean;
  304. begin
  305. if piece <> nil then
  306. begin
  307. trouve := false;
  308. lp := piece;
  309. repeat
  310. lg := listegenre;
  311. while lg^.genre <> lp^.genre do
  312. lg := lg^.suivant;
  313. if lg^.nombre <> 0 then
  314. trouve := peutplacerpiece(lp,pos);
  315. if not trouve then
  316. lp := lp^.suivant;
  317. until (lp = nil) or trouve;
  318. piece := lp;
  319. end;
  320. end;
  321. procedure placepiece(p:plpiece;pos:tposition);
  322. var x,y,z : byte;
  323. lg : plgenre;
  324. begin
  325. with pos,p^.piece do
  326. begin
  327. for z:=pz to pz+dz-1 do
  328. for y:=py to py+dy-1 do
  329. for x:=px to px+dx-1 do
  330. boite[x,y,z] := occupe;
  331. end;
  332. lg:=listegenre;
  333. while lg^.genre <> p^.genre do
  334. lg := lg^.suivant;
  335. lg^.nombre := lg^.nombre-1;
  336. end;
  337. procedure enlevepiece(p:plpiece;pos:tposition);
  338. var x,y,z : byte;
  339. lg : plgenre;
  340. begin
  341. with pos,p^.piece do
  342. begin
  343. for z:=pz to pz+dz-1 do
  344. for y:=py to py+dy-1 do
  345. for x:=px to px+dx-1 do
  346. boite[x,y,z] := vide;
  347. end;
  348. lg:=listegenre;
  349. while lg^.genre <> p^.genre do
  350. lg := lg^.suivant;
  351. lg^.nombre := lg^.nombre+1;
  352. end;
  353. procedure affichepiece2(px,py,pz,dx,dy,dz:byte);
  354. begin
  355. writeln(' Piece : [',dx,',',dy,',',dz,'] en (',px,',',py,',',pz,')');
  356. end;
  357.  
  358. procedure affichepiece(p:plpiece;pos:tposition);
  359. begin
  360. with pos,p^.piece do
  361. affichepiece2(px,py,pz,dx,dy,dz);
  362. end;
  363. procedure afficheoperation;
  364. begin
  365. gotoxy(16,5);
  366. writeln(operation:10);
  367. writeln;
  368. end;
  369. function placeautres:boolean;
  370. var x,y,z : byte;
  371. trouve,fin : boolean;
  372. pos : tposition;
  373. piece : plpiece;
  374. begin
  375. placeautres := false;
  376. trouve := false;
  377. piece := listepiece;
  378. for z:=1 to nz do
  379. for y:=1 to ny do
  380. for x:=1 to nx do
  381. if (boite[x,y,z] = vide) and (not trouve) then
  382. begin
  383. position(pos,x,y,z);
  384. trouve := true;
  385. end;
  386. if trouve then
  387. begin
  388. fin := false;
  389. while (piece <> nil) and (not fin) do
  390. begin
  391. cherchepiece(piece,pos);
  392. if piece <> nil then
  393. begin
  394. placepiece(piece,pos);
  395. operation := operation+1;
  396. if (operation mod 1000) = 0 then
  397. afficheoperation;
  398. if not placeautres then
  399. begin
  400. enlevepiece(piece,pos);
  401. piece := piece^.suivant;
  402. operation := operation+1;
  403. if (operation mod 1000) = 0 then
  404. afficheoperation;
  405. end
  406. else
  407. begin
  408. placeautres := true;
  409. fin := true;
  410. if sauvegarder then
  411. ajouterbd(piece,pos);
  412. // affichepiece(piece,pos);
  413. end;
  414. end
  415. else
  416. placeautres := false;
  417. end;
  418. end
  419. else
  420. placeautres := true;
  421. end;
  422. procedure afficherprogression;
  423. var resultat : boolean;
  424. duree : integer;
  425. begin
  426. clrscr;
  427. writeln;
  428. writeln(' Resolution');
  429. writeln(' ----------');
  430. writeln;
  431. writeln(' Operations :');
  432. duree := TimGetSeconds;
  433. resultat := placeautres;
  434. duree := TimGetSeconds-duree;
  435. ajouterbd2(genre,operation,duree);
  436. end;
  437. procedure affichersolution;
  438. var px,py,pz,dx,dy,dz : Int8;
  439. Error : Err;
  440. iHandle : UInt8;
  441. g : integer;
  442. gh,gl,nh,nl,d : Int16;
  443. s : string;
  444. begin
  445. clrscr;
  446. writeln(' Solution');
  447. writeln(' --------');
  448. if genreexistebd then
  449. begin
  450. Error:=CPDB_Open(0,bd,dmModeReadOnly,iHandle);
  451. Error:=CPDB_ReadFirst(iHandle);
  452. while Error=0 do
  453. begin
  454. Error:=CPDB_ReadInt(iHandle,'GH',gh);
  455. Error:=CPDB_ReadInt(iHandle,'GL',gl);
  456. g := convertint(gh,gl);
  457. if g = genre then
  458. begin
  459. Error:=CPDB_ReadInt(iHandle,'DUREE',d);
  460. Error:=CPDB_ReadInt(iHandle,'NH',nh);
  461. Error:=CPDB_ReadInt(iHandle,'NL',nl);
  462. Error:=CPDB_ReadShortInt(iHandle,'PX',px);
  463. Error:=CPDB_ReadShortInt(iHandle,'PY',py);
  464. Error:=CPDB_ReadShortInt(iHandle,'PZ',pz);
  465. Error:=CPDB_ReadShortInt(iHandle,'DX',dx);
  466. Error:=CPDB_ReadShortInt(iHandle,'DY',dy);
  467. Error:=CPDB_ReadShortInt(iHandle,'DZ',dz);
  468. affichepiece2(px,py,pz,dx,dy,dz);
  469. end;
  470. Error:=CPDB_ReadNext(iHandle);
  471. end;
  472. Error:=CPDB_Close(iHandle);
  473. writeln(' Nombre operations : ',convertint(nh,nl));
  474. writeln(' Duree operations  : ',IntToString(d div 3600),':',IntToString((d div 60) mod 60),':',IntToString(d mod 60));
  475. end;
  476. read(s);
  477. end;
  478. procedure resoudre(un,deux,trois:byte);
  479. var x,y,z : byte;
  480. pos : tposition;
  481. begin
  482. genre:=(un*100+deux)*100+trois;
  483.  
  484. for z:=1 to nz do
  485. for y:=1 to ny do
  486. for x:=1 to nx do
  487. boite[x,y,z] := vide;
  488.  
  489. listepiece := nil;
  490. listegenre := nil;
  491. case un of
  492. 1:definirpiece(5,1,1,1);
  493. 8:definirpiece(6,1,2,4);
  494. 12:definirpiece(6,2,2,3);
  495. end;
  496. case deux of
  497. 1:definirpiece(5,1,1,1);
  498. 8:definirpiece(6,1,2,4);
  499. 12:definirpiece(6,2,2,3);
  500. end;
  501. case trois of
  502. 1:definirpiece(5,1,1,1);
  503. 8:definirpiece(6,1,2,4);
  504. 12:definirpiece(6,2,2,3);
  505. end;
  506.  
  507. operation :=0;
  508.  
  509. if calculer then
  510. effacerentree;
  511.  
  512. if genreexistebd then
  513. sauvegarder := false
  514. else
  515. sauvegarder := true;
  516.  
  517. if sauvegarder then
  518. afficherprogression;
  519.  
  520. affichersolution;
  521. end;
  522. procedure options;
  523. var m : menu;
  524. selection : byte;
  525. begin
  526. initmenu(m);
  527. titlemenu(m,'Options');
  528. if calculer then
  529. begin
  530. addmenuitem(m,'*Recalculer');
  531. addmenuitem(m,'Ne pas recalculer');
  532. end
  533. else
  534. begin
  535. addmenuitem(m,'Recalculer');
  536. addmenuitem(m,'*Ne pas recalculer');
  537. end;
  538. selection := selectmenu(m);
  539. case selection of
  540. 1:calculer := true;
  541. 2:calculer := false;
  542. end;
  543. end;
  544. procedure menuresoudre;
  545. var m : menu;
  546. selection : byte;
  547. begin
  548. initmenu(m);
  549. titlemenu(m,'Resolution Casse-tete');
  550. addmenuitem(m,'(1,8,12)');
  551. addmenuitem(m,'(1,12,8)');
  552. addmenuitem(m,'(8,1,12)');
  553. addmenuitem(m,'(8,12,1)');
  554. addmenuitem(m,'(12,1,8)');
  555. addmenuitem(m,'(12,8,1)');
  556. addmenuitem(m,'Options');
  557. repeat
  558. selection := selectmenu(m);
  559. case selection of
  560. 1:resoudre(1,8,12);
  561. 2:resoudre(1,12,8);
  562. 3:resoudre(8,1,12);
  563. 4:resoudre(8,12,1);
  564. 5:resoudre(12,1,8);
  565. 6:resoudre(12,8,1);
  566. 7:options;
  567. end;
  568. until selection = 0;
  569. end;
  570. procedure salutations;
  571. begin
  572. clrscr;
  573. writeln;
  574. writeln;
  575. writeln;
  576. writeln(' A bientot');
  577. end;
  578. begin
  579. CPDB_OPENLIB;
  580. calculer := false;
  581. menuresoudre;
  582. salutations;
  583. CPDB_CLOSELIB;
  584. end.