Cassetete.pas

Un article de Wikipedia.

program pieceboite;
{$i PalmAPI.pas}
{$i PPlib.pas}
{$i Menu.pas}
{$i CPDBSTD4PP.pas}
const nx = 5;
      ny = 5;
      nz = 5;
      bd = 'CasseteteCPDB';
      DBCreator = $54455354; //TEST
type etat = (vide,occupe);
     tboite = array [1..nx,1..ny,1..nz] of etat;
     //byte = 0..255;
     tdimpiece = record
      dx,dy,dz:byte;
     end;
     plpiece = ^tlpiece;
     tlpiece = record
      genre : byte;
      piece : tdimpiece;
      suivant : plpiece;
     end;
     plgenre = ^tlgenre;
     tlgenre = record
      genre : byte;
      nombre : byte;
      suivant : plgenre;
     end;
     tposition = record
      px,py,pz : byte;
     end;
var boite : tboite;
    listepiece : plpiece;
    listegenre : plgenre;
    operation : integer;
    sauvegarder,calculer : boolean;
    genre : integer;
function convertint(h,l:Int16):integer;
var resultat:integer;
begin
 resultat := h;
 resultat := (resultat shl 15) + l;
 convertint := resultat;
end;
function bdexiste:boolean;
begin
  if CPDB_DatabaseExist(bd)= CPDB_ERR_NOEXIST then
   bdexiste := false
  else
   bdexiste := true;
end;
procedure creerbd;
var Error : Err;
begin
 if not bdexiste then
 begin
   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;');
 end;
end;
function genreexistebd:boolean;
var Error : Err;
    iHandle : UInt8;
    g : integer;
    gh,gl : Int16;
    trouve : boolean;
begin
 trouve := false;
 creerbd;
 Error:=CPDB_Open(0,bd,dmModeReadOnly,iHandle);
 Error:=CPDB_ReadFirst(iHandle);
 while (Error=0) and (not trouve) do
 begin
  Error:=CPDB_ReadInt(iHandle,'GH',gh);
  Error:=CPDB_ReadInt(iHandle,'GL',gl);
  g := convertint(gh,gl);
  if g = genre then
   trouve := true;
  Error:=CPDB_ReadNext(iHandle);
 end;
 Error:=CPDB_Close(iHandle);
 genreexistebd := trouve;
end;
procedure effacerentree;
var Error : Err;
    iHandle : UInt8;
    g : integer;
    gh,gl : Int16;
    trouve : boolean;
begin
 while genreexistebd do
 begin
  Error:=CPDB_Open(0,bd,dmModeReadWrite,iHandle);
  Error:=CPDB_ReadFirst(iHandle);
  while Error=0 do
  begin
   Error:=CPDB_ReadInt(iHandle,'GH',gh);
   Error:=CPDB_ReadInt(iHandle,'GL',gl);
   g := convertint(gh,gl);
   if g = genre then
   begin
    CPDB_DeleteRecord(iHandle);
   end;
   Error:=CPDB_ReadNext(iHandle);
  end;
  Error:=CPDB_Close(iHandle);
 end;
end;
procedure ajouterbd(piece:plpiece;pos:tposition);
var Error : Err;
    iHandle :UInt8;
begin
 if piece <> nil then
 begin
 creerbd;
  Error:=CPDB_Open(0,bd,dmModeReadWrite,iHandle);
  Error:=CPDB_AddRecord(iHandle);
  with pos,piece^.piece do
  begin
   Error:=CPDB_WriteInt(iHandle,'GH',genre shr 15);
   Error:=CPDB_WriteInt(iHandle,'GL',genre mod 32768);
   Error:=CPDB_WriteInt(iHandle,'NH',operation shr 15);
   Error:=CPDB_WriteInt(iHandle,'NL',operation mod 32768);
   Error:=CPDB_WriteInt(iHandle,'DUREE',0);
   Error:=CPDB_WriteShortInt(iHandle,'PX',px);
   Error:=CPDB_WriteShortInt(iHandle,'PY',py);
   Error:=CPDB_WriteShortInt(iHandle,'PZ',pz);
   Error:=CPDB_WriteShortInt(iHandle,'DX',dx);
   Error:=CPDB_WriteShortInt(iHandle,'DY',dy);
   Error:=CPDB_WriteShortInt(iHandle,'DZ',dz);
  end;
  Error:=CPDB_UpdateRecord(iHandle);
  Error:=CPDB_Close(iHandle);
 end;
end;
procedure ajouterbd2(g,n,d:integer);
var Error : Err;
    iHandle : UInt8;
    gbd : integer;
    gh,gl : Int16;
begin
 creerbd;
 Error:=CPDB_Open(0,bd,dmModeReadWrite,iHandle);
 Error:=CPDB_ReadFirst(iHandle);
 while Error=0 do
 begin
  Error:=CPDB_ReadInt(iHandle,'GH',gh);
  Error:=CPDB_ReadInt(iHandle,'GL',gl);
  gbd := convertint(gh,gl);
  if gbd = g then
  begin
   Error:=CPDB_WriteInt(iHandle,'DUREE',d);
   Error:=CPDB_WriteInt(iHandle,'NH',n shr 15);
   Error:=CPDB_WriteInt(iHandle,'NL',n mod 32768);
   Error:=CPDB_UpdateRecord(iHandle);
  end;
  Error:=CPDB_ReadNext(iHandle);
 end;
 Error:=CPDB_Close(iHandle);
end;
function maximum(a,b:integer):integer;
begin
 if a >= b then
  maximum := a
 else
  maximum := b;
end;
function minimum(a,b:integer):integer;
begin
 if a <= b then
  minimum := a
 else
  minimum := b;
end;
function nombre:integer;
var x,y,z : byte;
    n : integer;
begin
 n := 0;
 for z := 1 to nz do
  for y := 1 to ny do
    for x := 1 to nx do
       if boite[x,y,z] = vide then
         n := n+1;
 nombre := n;
end;
procedure definirpiece(quantite:byte;dimx,dimy,dimz:byte);
var x,y,z : byte;
    templgenre : plgenre;
    tempngenre : byte;
procedure orientation(dimx,dimy,dimz:byte);
var templpiece : plpiece;
begin
 if listepiece = nil then
 begin
  new(listepiece);
  templpiece := listepiece;
 end
 else
 begin
  templpiece := listepiece;
  while templpiece^.suivant <> nil do
   templpiece := templpiece^.suivant;
  new(templpiece^.suivant);
  templpiece := templpiece^.suivant;
 end;
 templpiece^.genre := templgenre^.genre;
 templpiece^.suivant := nil;
 with templpiece^.piece do
 begin
  dx := dimx;
  dy := dimy;
  dz := dimz; 
 end;
end;
begin
 if listegenre = nil then
 begin
  new(listegenre);
  with listegenre^ do
  begin
   genre := 1;
   nombre := quantite;
   suivant := nil;
  end;
  templgenre := listegenre;
 end
 else
 begin
  templgenre := listegenre;
  while templgenre^.suivant <> nil do
   templgenre := templgenre^.suivant;
  tempngenre := templgenre^.genre;
  new(templgenre^.suivant);
  templgenre := templgenre^.suivant;
  with templgenre^ do
  begin
   genre := tempngenre+1;
   nombre := quantite;
   suivant := nil;
  end;
 end;
 x := dimx;
 y := dimy;
 z := dimz;
 if dimy = dimz then
 begin
  x := dimz;
  z := dimx;
 end;
 if dimx = dimz then
 begin
  y := dimz;
  z := dimy;
 end;
 if x = y then
  if y = z then orientation(x,x,x)
  else
  begin
   orientation(x,x,z);
   orientation(x,z,x);
   orientation(z,x,x);
  end
 else
 begin
  orientation(x,y,z);
  orientation(x,z,y);
  orientation(y,z,x);
  orientation(y,x,z);
  orientation(z,x,y);
  orientation(z,y,x);
 end;
end;
procedure position(var pos:tposition; x,y,z:byte);
begin
 pos.px := x;
 pos.py := y;
 pos.pz := z;
end;
function peutplacerpiece(piece:plpiece; pos:tposition):boolean;
var x,y,z:byte;
begin
 if piece <> nil then
 begin
  peutplacerpiece := true;
  with pos,piece^.piece do
   if (pz+dz-1 <= nz) and (py+dy-1 <= ny) and (px+dx-1 <= nx) then
   begin
    for z := pz to pz+dz-1 do
     for y := py to py+dy-1 do
      for x := px to px+dx-1 do
       if boite[x,y,z] = occupe then
         peutplacerpiece := false;
   end
   else
    peutplacerpiece := false;
 end
 else
  peutplacerpiece := false;
end;
procedure cherchepiece(var piece:plpiece; pos:tposition);
var lp : plpiece;
    lg : plgenre;
    trouve : boolean;
begin
 if piece <> nil then
 begin
  trouve := false;
  lp := piece;
  repeat
   lg := listegenre;
   while lg^.genre <> lp^.genre do
    lg := lg^.suivant;
   if lg^.nombre <> 0 then
    trouve := peutplacerpiece(lp,pos);
   if not trouve then
    lp := lp^.suivant;
  until (lp = nil) or trouve;
  piece := lp;
 end;
end;
procedure placepiece(p:plpiece;pos:tposition);
var x,y,z : byte;
    lg : plgenre;
begin
 with pos,p^.piece do
 begin
  for z:=pz to pz+dz-1 do
   for y:=py to py+dy-1 do
    for x:=px to px+dx-1 do
     boite[x,y,z] := occupe;
 end;
 lg:=listegenre;
 while lg^.genre <> p^.genre do
  lg := lg^.suivant;
 lg^.nombre := lg^.nombre-1;
end;
procedure enlevepiece(p:plpiece;pos:tposition);
var x,y,z : byte;
    lg : plgenre;
begin
 with pos,p^.piece do
 begin
  for z:=pz to pz+dz-1 do
   for y:=py to py+dy-1 do
    for x:=px to px+dx-1 do
     boite[x,y,z] := vide;
 end;
 lg:=listegenre;
 while lg^.genre <> p^.genre do
  lg := lg^.suivant;
 lg^.nombre := lg^.nombre+1;
end;
procedure affichepiece2(px,py,pz,dx,dy,dz:byte);
begin
  writeln('   Piece : [',dx,',',dy,',',dz,'] en (',px,',',py,',',pz,')');
end;
 
procedure affichepiece(p:plpiece;pos:tposition);
begin
 with pos,p^.piece do
  affichepiece2(px,py,pz,dx,dy,dz);
end;
procedure afficheoperation;
begin
 gotoxy(16,5);
 writeln(operation:10);
 writeln;
end;
function placeautres:boolean;
var x,y,z : byte;
    trouve,fin : boolean;
    pos : tposition;
    piece : plpiece;
begin
 placeautres := false;
 trouve := false;
 piece := listepiece;
 for z:=1 to nz do
  for y:=1 to ny do
   for x:=1 to nx do
    if (boite[x,y,z] = vide) and (not trouve) then
    begin
     position(pos,x,y,z);
     trouve := true;
    end;
 if trouve then
 begin
  fin := false;
  while (piece <> nil) and (not fin) do
  begin
   cherchepiece(piece,pos);
   if piece <> nil then
   begin
    placepiece(piece,pos);
    operation := operation+1;
    if (operation mod 1000) = 0 then
     afficheoperation;
    if not placeautres then
    begin
     enlevepiece(piece,pos);
     piece := piece^.suivant;
     operation := operation+1;
     if (operation mod 1000) = 0 then
      afficheoperation;
    end
    else
    begin
     placeautres := true;
     fin := true;
     if sauvegarder then
      ajouterbd(piece,pos);
    // affichepiece(piece,pos);
    end;
   end
   else
    placeautres := false;
  end;
 end
 else
  placeautres := true;
end;
procedure afficherprogression;
var resultat : boolean;
    duree : integer;
begin
 clrscr;
 writeln;
 writeln('  Resolution');
 writeln('  ----------');
 writeln;
 writeln('  Operations :');
 duree := TimGetSeconds;
 resultat := placeautres;
 duree := TimGetSeconds-duree;
 ajouterbd2(genre,operation,duree);
end;
procedure affichersolution;
var px,py,pz,dx,dy,dz : Int8;
    Error : Err;
    iHandle : UInt8;
    g : integer;
    gh,gl,nh,nl,d : Int16;
    s : string;
begin
 clrscr;
 writeln('   Solution');
 writeln('   --------');
 if genreexistebd then
 begin
  Error:=CPDB_Open(0,bd,dmModeReadOnly,iHandle);
  Error:=CPDB_ReadFirst(iHandle);
  while Error=0 do
  begin
   Error:=CPDB_ReadInt(iHandle,'GH',gh);
   Error:=CPDB_ReadInt(iHandle,'GL',gl);
   g := convertint(gh,gl);
   if g = genre then
   begin
    Error:=CPDB_ReadInt(iHandle,'DUREE',d);
    Error:=CPDB_ReadInt(iHandle,'NH',nh);
    Error:=CPDB_ReadInt(iHandle,'NL',nl);
    Error:=CPDB_ReadShortInt(iHandle,'PX',px);
    Error:=CPDB_ReadShortInt(iHandle,'PY',py);
    Error:=CPDB_ReadShortInt(iHandle,'PZ',pz);
    Error:=CPDB_ReadShortInt(iHandle,'DX',dx);
    Error:=CPDB_ReadShortInt(iHandle,'DY',dy);
    Error:=CPDB_ReadShortInt(iHandle,'DZ',dz);
    affichepiece2(px,py,pz,dx,dy,dz);
   end;
   Error:=CPDB_ReadNext(iHandle);
  end;
  Error:=CPDB_Close(iHandle);
  writeln('   Nombre operations : ',convertint(nh,nl));
  writeln('   Duree operations  : ',IntToString(d div 3600),':',IntToString((d div 60) mod 60),':',IntToString(d mod 60));
 end;
 read(s);
end;
procedure resoudre(un,deux,trois:byte);
var x,y,z : byte;
 pos : tposition;
begin
 genre:=(un*100+deux)*100+trois;
 
 for z:=1 to nz do
  for y:=1 to ny do
   for x:=1 to nx do
    boite[x,y,z] := vide;
 
 listepiece := nil;
 listegenre := nil;
 case un of
   1:definirpiece(5,1,1,1);
   8:definirpiece(6,1,2,4);
  12:definirpiece(6,2,2,3);
 end;
 case deux of
   1:definirpiece(5,1,1,1);
   8:definirpiece(6,1,2,4);
  12:definirpiece(6,2,2,3);
 end;
 case trois of
   1:definirpiece(5,1,1,1);
   8:definirpiece(6,1,2,4);
  12:definirpiece(6,2,2,3);
 end;
 
 operation :=0;
 
 if calculer then
  effacerentree;
 
 if genreexistebd then
  sauvegarder := false
 else
  sauvegarder := true;
 
 if sauvegarder then
  afficherprogression;
 
 affichersolution;
end;
procedure options;
var m : menu;
    selection : byte;
begin
 initmenu(m);
 titlemenu(m,'Options');
 if calculer then
 begin
 addmenuitem(m,'*Recalculer');
 addmenuitem(m,'Ne pas recalculer');
 end
 else
 begin
 addmenuitem(m,'Recalculer');
 addmenuitem(m,'*Ne pas recalculer');
 end;
 selection := selectmenu(m);
 case selection of
  1:calculer := true;
  2:calculer := false;
 end;
end;
procedure menuresoudre;
var m : menu;
    selection : byte;
begin
 initmenu(m);
 titlemenu(m,'Resolution Casse-tete');
 addmenuitem(m,'(1,8,12)');
 addmenuitem(m,'(1,12,8)');
 addmenuitem(m,'(8,1,12)');
 addmenuitem(m,'(8,12,1)');
 addmenuitem(m,'(12,1,8)');
 addmenuitem(m,'(12,8,1)');
 addmenuitem(m,'Options');
 repeat
  selection := selectmenu(m);
  case selection of
   1:resoudre(1,8,12);
   2:resoudre(1,12,8);
   3:resoudre(8,1,12);
   4:resoudre(8,12,1);
   5:resoudre(12,1,8);
   6:resoudre(12,8,1);
   7:options;
  end;
 until selection = 0;
end;
procedure salutations;
begin
 clrscr;
 writeln;
 writeln;
 writeln;
 writeln('   A bientot');
end;
begin
 CPDB_OPENLIB;
 calculer := false;
 menuresoudre;
 salutations;
 CPDB_CLOSELIB;
end.