Traffic.pas

Un article de Wikipedia.

program traffic;
{$i PalmAPI.pas}
{$i PPlib.pas}
{$i Menu.pas}
{$i CPDBSTD4PP.pas}
type position = record
             x,y:byte;
            end;
 direction = (verti,hori);
 taille = (deux,trois);
 genre = (normal,principal);
 pbloc = ^bloc;
 bloc = record
         pos:position;
         dir:direction;
           t:taille;
           g:genre;
          end;
 plistebloc = ^listebloc;
 listebloc = record
           pb:pbloc;
     suivant:plistebloc;
              end;
 pcoup = ^coup;
 coup = record
         pde,pa:pbloc;
        end;
 plistecoup = ^listecoup;
 listecoup = record
              pc:pcoup;
           suivant:plistecoup;
             end;
 pgrille = ^grille;
 grille = array [1..6,1..6] of byte;
 plistelien = ^listelien;
 listelien = record
                plb:plistebloc;
                via:plistelien;
                pc:pcoup;
           suivant:plistelien;
               end;
var c:char;
 // pg est globale car le garbage
 // collector semble inactif
 pg:pgrille;
procedure bip;
begin
 SndPlaySystemSound(snderror);
end;
function memebloc(pba,pbb:pbloc):boolean;
begin
 memebloc := false;
 if (pba <> nil) and (pbb <> nil) then
 begin
  if pba^.pos.x = pbb^.pos.x then
   if pba^.pos.y = pbb^.pos.y then
    if pba^.dir = pbb^.dir then
     if pba^.t = pbb^.t then
      if pba^.g = pbb^.g then
       memebloc := true;
 end
 else
  if (pba = nil) and (pbb = nil) then
   memebloc := true;
end;
function memelistebloc(pla,plb:plistebloc):boolean;
var aa,ab:plistebloc;
begin
 if (pla <> nil) and (plb <> nil) then
 begin
  aa := pla;
  ab := plb;
  memelistebloc := true;
  while (aa^.suivant <> nil) and (ab^.suivant <> nil) do
  begin
   if not memebloc(aa^.pb,ab^.pb) then
    memelistebloc := false;
   aa := aa^.suivant;
   ab := ab^.suivant;
  end;
  if not memebloc(aa^.pb,ab^.pb) then
   memelistebloc := false;
 end
 else
  if (pla = nil) and (plb = nil) then
   memelistebloc := true
  else
   memelistebloc := false;
end;
procedure jouercoup(plb:plistebloc;pc:pcoup);
var actuel:plistebloc;
 trouve:boolean;
begin
 if (plb <> nil) and (pc <> nil) then
 begin
  actuel := plb;
  trouve := false;
  while (actuel^.suivant <> nil) and (not trouve) do
  begin
   if memebloc(actuel^.pb,pc^.pde) then
    trouve := true
   else
    actuel := actuel^.suivant;
  end;
  if not trouve then
   if memebloc(actuel^.pb,pc^.pde) then
    trouve := true;
  if trouve then
   actuel^.pb := pc^.pa
  else
  begin
   writeln('Erreur : le bloc est introuvab, aucun mouvement');
   read(c);
  end;
 end
 else
 begin
  writeln('Erreur : arguments non transmis');
  read(c);
 end;
end;
function copierlistebloc(plb:plistebloc):plistebloc;
var aa,ab:plistebloc;
begin
 if plb <> nil then
 begin
  new(ab);
  copierlistebloc := ab;  
  aa := plb;
  while aa^.suivant <> nil do
  begin
   ab^.pb := aa^.pb;
   new(ab^.suivant);
   ab := ab^.suivant;
   aa := aa^.suivant;
  end;
  ab^.pb := aa^.pb;
  ab^.suivant := nil;
 end
 else
  copierlistebloc := nil;
end;
function creerbloc(x,y:byte;d:direction;te:taille;ge:genre):pbloc;
var piece:pbloc;
begin
 new(piece);
 with piece^ do
 begin
  pos.x := x;
  pos.y := y;
  dir := d;
  t := te;
  g := ge;
 end;
 creerbloc := piece;
end;
function ajouterbloc(plb:plistebloc;pbl:pbloc):plistebloc;
var actuel:plistebloc;
begin
 actuel := plb;
 if actuel <> nil then
 begin
  while actuel^.suivant <> nil do
   actuel := actuel^.suivant;
  new(actuel^.suivant);
  with actuel^.suivant^ do
  begin
   pb := pbl;
   suivant := nil;
  end;
  ajouterbloc := plb;
  end
 else
  begin
   new(actuel);
   actuel^.pb := pbl;
   actuel^.suivant := nil;
   ajouterbloc := actuel;
  end;
end;
function ajoutercoup(plc:plistecoup;pcde,pca:pbloc):plistecoup;
var actuel:plistecoup;
begin
 actuel := plc;
 if actuel <> nil then
 begin
  while actuel^.suivant <> nil do
   actuel := actuel^.suivant;
  new(actuel^.suivant);
  with actuel^.suivant^ do
  begin
   new(pc);
   pc^.pde := pcde;
   pc^.pa := pca;
   suivant := nil;
  end;
  ajoutercoup := plc;
 end
 else
  begin
   new(actuel);
   new(actuel^.pc);
   actuel^.pc^.pde := pcde;
   actuel^.pc^.pa := pca;
   actuel^.suivant := nil;
   ajoutercoup := actuel;
  end;
end;
function ajouterlien(plla:plistelien;plba:plistebloc;v:plistelien;vc:pcoup):plistelien;
var actuel:plistelien;
begin
 if (plla <> nil) and (plba <> nil) then
 begin
  actuel := plla;
  while actuel^.suivant <> nil do
   actuel := actuel^.suivant;
  new(actuel^.suivant);
  with actuel^.suivant^ do
  begin
   plb := plba;
   via := v;
   pc := vc;
   suivant := nil;
  end;
  ajouterlien := plla;
 end
 else
  if plla = nil then
  begin
   new(actuel);
   with actuel^ do
   begin
    plb := plba;
    via := v;
    pc := vc;
    suivant := nil;
   end;
   ajouterlien := actuel;
  end
  else
   ajouterlien := plla;
end;
function ajouterliendebut(plla:plistelien;plba:plistebloc;v:plistelien;vc:pcoup):plistelien;
var actuel:plistelien;
begin
 if plba <> nil then
 begin
  new(actuel);
  with actuel^ do
  begin
   plb := plba;
   via := v;
   pc := vc;
   suivant := plla;
  end;
  ajouterliendebut := actuel;
 end
 else
  ajouterliendebut := plla;
end;
procedure creergrille(plb:plistebloc);
var actuel:plistebloc;
 l,c,n,valeur:byte;
procedure ajoute(b:bloc;v:byte);
var px,py,dx,dy,n,nombre:byte;
begin
 case b.dir of
  verti:begin
         dx := 0;
         dy := 1;
        end;
  hori:begin
         dx := 1;
         dy := 0;
        end;
 end;
 case b.t of
  deux: nombre := 2;
  trois: nombre := 3;
 end;
 case b.g of
  normal: valeur := v;
  principal: valeur := 255; 
 end;
 px := b.pos.x;
 py := b.pos.y;
 for n:=1 to nombre do
 begin
  pg^[px,py] := valeur;
  px := px+dx;
  py := py+dy;
 end;
end;
begin
 if pg = nil then
  new(pg);
 for l:=1 to 6 do
  for c:=1 to 6 do
   pg^[c,l] := 0;
 actuel := plb;
 if actuel <> nil then
 begin
  n:=1;
  ajoute(actuel^.pb^,n);
  while actuel^.suivant <> nil do
  begin
   n := n+1;
   actuel := actuel^.suivant;
   ajoute(actuel^.pb^,n);
  end;
 end;
end;
procedure affichelistebloc(plb:plistebloc);
var actuel:plistebloc;
 l,c,n,d1,d2,valeur,mult:byte;
begin
 mult := 1;
 creergrille(plb);
  write('|');
  for d1 := 1 to mult*6 do
   write('-');
  writeln('|');
  for l := 6 downto 1 do
   for d1 := 1 to mult do
   begin
    write('|');
    for c := 1 to 6 do
     for d2 := 1 to mult do
      case pg^[c,l] of
       0:write(' ');
       255:write('X');
      else
       write(chr(pg^[c,l]+64));
      end;
    write('|');
    writeln;
   end;
  write('|');
  for d1 := 1 to mult*6 do
   write('-');
  writeln('|');
end;
procedure affichecoup(coup:pcoup);
begin
 if coup <> nil then
  writeln('(',coup^.pde^.pos.x,',',coup^.pde^.pos.y,')->(',coup^.pa^.pos.x,',',coup^.pa^.pos.y,')')
 else
  writeln('Aucun coup specifie.');
end;
procedure affichelistecoup(plc:plistecoup);
var actuel:plistecoup;
begin
 if plc <> nil then
 begin
  actuel := plc;
  while actuel^.suivant <> nil do
  begin
   affichecoup(actuel^.pc);
   actuel := actuel^.suivant;
  end;
  affichecoup(actuel^.pc);
 end
 else
  writeln('Liste vide');
end;
function coups(plb:plistebloc):plistecoup;
var lba:plistebloc;
    lca:plistecoup;
    pba,pbt:pbloc;
    dx,dy,px,py,nombre,n:byte;
    fini,trouve:boolean;
procedure ajoutercoups;
begin
   case pba^.dir of
    verti:begin
         dx := 0;
         dy := 1;
        end;
    hori:begin
         dx := 1;
         dy := 0;
        end;
   end;
   case pba^.t of
    deux: nombre := 2;
    trois: nombre := 3;
   end;
   // vers les coordonnees inferieures
   px := pba^.pos.x-dx;
   py := pba^.pos.y-dy;
   fini := false;
   while (px >= 1) and (py >= 1) and (not fini) do
   begin
    if pg^[px,py] = 0 then
    begin
     pbt := creerbloc(px,py,pba^.dir,pba^.t,pba^.g);
     lca := ajoutercoup(lca,pba,pbt);
    end
    else
     fini := true;
    px := px-dx;
    py := py-dy;    
   end;
   // vers les coordonnees superieures
   px := pba^.pos.x+nombre*dx;
   py := pba^.pos.y+nombre*dy;
   fini := false;
   while (px <= 6) and (py <= 6) and (not fini) do
   begin
    if pg^[px,py] = 0 then
    begin
     pbt := creerbloc(px-(nombre-1)*dx,py-(nombre-1)*dy,pba^.dir,pba^.t,pba^.g);
     lca := ajoutercoup(lca,pba,pbt);
    end
    else
     fini := true;
    px := px+dx;
    py := py+dy;    
   end;   
end;
begin 
 if plb <> nil then
 begin
  creergrille(plb);
  lca := nil;
  // verifier si termine ou
  // si possible de terminer
  lba := plb;
  trouve := false;
  while (lba^.suivant <> nil) and (not trouve) do
  begin
   if lba^.pb^.g = principal then
    trouve := true;
   lba := lba^.suivant;
  end;
  if lba^.pb^.g = principal then
   trouve := true;
  fini := false;
  if trouve then
  begin
   if lba^.pb^.pos.x = 5 then
   begin
    coups := nil;
    fini := true;
   end
   else
   begin
    nombre := 0;
    for n:= lba^.pb^.pos.x+2 to 6 do
     if pg^[n,4] = 0 then
      nombre := nombre+1;
    if nombre = (5-lba^.pb^.pos.x) then
    begin
     pbt := creerbloc(5,4,hori,deux,principal);
     lca := ajoutercoup(nil,lba^.pb,pbt);
     coups := lca;     
     fini := true;
    end;
   end; 
  end
  else
   writeln('Erreur : il manque le bloc principal.');
  if not fini then
  begin
   lba := plb;
   while lba^.suivant <> nil do
   begin
    pba := lba^.pb;
    ajoutercoups;
    lba := lba^.suivant;
   end;
   pba := lba^.pb;
   ajoutercoups;
   coups := lca;
  end;
 end
 else
   coups := nil;
end;
{$i trafficsamples.pas}
function existelistebloc(pll:plistelien;plba:plistebloc):boolean;
var actuel:plistelien;
 trouve:boolean;
begin
 if (pll <> nil) and (plba <> nil) then
 begin
  trouve := false;
  actuel := pll;
  while (actuel^.suivant <> nil) and (not trouve) do
  begin
   if memelistebloc(actuel^.plb,plba) then
    trouve := true
   else
    actuel := actuel^.suivant;
  end;
  if not trouve then
  begin
   if memelistebloc(actuel^.plb,plba) then
    trouve := true
  end;
  existelistebloc := trouve;  
 end
 else
  existelistebloc := false;
end;
function nbblocs(plba:plistebloc):integer;
var n:integer;
 plbc:plistebloc;
begin
 if plba <> nil then
 begin
  n := 1;
  plbc := plba;
  while plbc^.suivant <> nil do
  begin
   n := n+1;
   plbc := plbc^.suivant;
  end;
  nbblocs := n;
 end
 else
  nbblocs := 0;
end;
function nbliens(plla:plistelien):integer;
var n:integer;
 pllc:plistelien;
begin
 if plla <> nil then
 begin
  n := 1;
  pllc := plla;
  while pllc^.suivant <> nil do
  begin
   n := n+1;
   pllc := pllc^.suivant;
  end;
  nbliens := n;
 end
 else
  nbliens := 0;
end;
function zero(n:integer):string;
begin
 if n > 9 then
  zero:=IntToString(n)
 else
  zero:='0'+IntToString(n);
end;
function temps(duree:integer):string;
begin
 temps:=zero((duree div 3600) mod 100)+':'+zero((duree div 60) mod 60)+':'+zero(duree mod 60);
end;
function existe(n:integer):string;
var nom:string;
begin
 nom:='TrafCPDB'+zero(n);
 if CPDB_DatabaseExist(nom) = CPDB_ERR_NOEXIST then
  existe:=''
 else
  existe:='+';
end;
procedure restaure(n:integer;var psol:plistelien;var dur,nbg:integer);
const NoError = 0;
var Error: Err;
 iHandle: UInt8;
 nom:string;
 t,v1,v2,v3:Int8;
 ta:taille;
 d:direction;
 g:genre;
 di:integer;
 lbt:plistebloc;
 llt:plistelien;
procedure ajoutebloc;
begin
 case v2 div 10 of
  2: ta:=deux;
  3: ta:=trois;
 end;
 case v2 mod 10 of
  1: d:=hori;
  2: d:=verti;
 end;
 case v3 of
  0: g:=normal;
  1: g:=principal;
 end;
 lbt:=ajouterbloc(lbt,creerbloc(v1 div 10,v1 mod 10,d,ta,g));
end;
procedure ajoutecoup;
var lla:plistelien;
    lba,lbc:plistebloc;
    vx,vy:byte;
    trouve:boolean;
    pba:pbloc;
    pc:pcoup;
begin
 if llt = nil then
 begin
  llt:=ajouterlien(llt,lbt,nil,nil);
 end;
 // aller a la fin de la liste
 lla:=llt;
 while lla^.suivant <> nil do
 begin
  lla:=lla^.suivant;
 end;
 // rechercher coup de depart
 vx:=v1 div 10;
 vy:=v1 mod 10;
 lba:=lla^.plb;
 trouve:=false;
 while (lba^.suivant <> nil) and (not trouve) do
 begin
  if (lba^.pb^.pos.x = vx) and (lba^.pb^.pos.y = vy) then
   trouve:=true;
  if not trouve then
   lba:=lba^.suivant;
 end;
 if not trouve then
  if (lba^.pb^.pos.x = vx) and (lba^.pb^.pos.y = vy) then
   trouve:=true;
 if trouve then
 begin
  // creer le coup
  with lba^.pb^ do
  begin
   pba:=creerbloc(v2 div 10,v2 mod 10,dir,t,g);
  end;
  new(pc);
  pc^.pde:=lba^.pb;
  pc^.pa:=pba;
  // jouer le coup
  lbc:=copierlistebloc(lla^.plb);
  jouercoup(lbc,pc);
  // ajouter le coup
  llt:=ajouterlien(llt,lbc,nil,pc);  
 end
 else
  writeln('Erreur coup introuvable !');
end;
procedure duree;
begin
 di:=((v1 * 60) + v2) * 60 + v3;
end;
procedure nbgrilles;
begin
 nbg:=((v1 * 128) + v2) * 128 + v3;
end;
begin
 dur:=0;
 psol:=nil;
 nom:='TrafCPDB'+zero(n);
 if CPDB_DatabaseExist(nom) <> CPDB_ERR_NOEXIST then
 begin
  lbt:=nil;
  llt:=nil;
  Error:=CPDB_Open(0,nom,dmModeReadOnly,iHandle);
  Error:=CPDB_ReadLast(iHandle);
  while Error = NoError do
  begin
   Error:=CPDB_ReadShortInt(iHandle,'TYPE',t);
   Error:=CPDB_ReadShortInt(iHandle,'V1',v1);
   Error:=CPDB_ReadShortInt(iHandle,'V2',v2);
   Error:=CPDB_ReadShortInt(iHandle,'V3',v3);
   case t of
    1: ajoutebloc;
    2: ajoutecoup;
    3: duree;
    4: nbgrilles;
   end;
   Error:=CPDB_ReadPrevious(iHandle);
  end;
  Error:=CPDB_Close(iHandle);
  dur:=di;
  psol:=llt;
 end;
end;
procedure sauvegarde(n:integer;l:plistelien;duree,nbgrilles:integer);
const DBCreator = $54455354; //TEST
var Error: Err;
 iHandle: UInt8;
 nom:string;
 lbt:plistebloc;
 llt:plistelien;
procedure ajouteblocbd;
var dirb,tb,gb:byte;
begin
 with lbt^.pb^ do
 begin
  case dir of
   hori: dirb:=1;
   verti: dirb:=2;
  end;
  case t of
   deux: tb:=2;
   trois: tb:=3;
  end;
  case g of
   normal: gb:=0;
   principal: gb:=1;
  end;
  Error:=CPDB_AddRecord(iHandle);
  Error:=CPDB_WriteShortInt(iHandle,'TYPE',1);
  Error:=CPDB_WriteShortInt(iHandle,'V1',pos.x * 10 +pos.y);
  Error:=CPDB_WriteShortInt(iHandle,'V2',tb * 10 + dirb);
  Error:=CPDB_WriteShortInt(iHandle,'V3',gb);
  Error:=CPDB_UpdateRecord(iHandle);
 end;
end;
procedure ajoutecoupbd;
begin
 with llt^.suivant^.pc^ do
 begin
  Error:=CPDB_AddRecord(iHandle);
  Error:=CPDB_WriteShortInt(iHandle,'TYPE',2);
  Error:=CPDB_WriteShortInt(iHandle,'V1',pde^.pos.x * 10 + pde^.pos.y);
  Error:=CPDB_WriteShortInt(iHandle,'V2',pa^.pos.x * 10 + pa^.pos.y);
  Error:=CPDB_WriteShortInt(iHandle,'V3',0);
  Error:=CPDB_UpdateRecord(iHandle);
 end;
end;
procedure ajoutedureebd;
begin
 Error:=CPDB_AddRecord(iHandle);
 Error:=CPDB_WriteShortInt(iHandle,'TYPE',3);
 Error:=CPDB_WriteShortInt(iHandle,'V1',(duree div 3600) mod 100);
 Error:=CPDB_WriteShortInt(iHandle,'V2',(duree div 60) mod 60);
 Error:=CPDB_WriteShortInt(iHandle,'V3',duree mod 60);
 Error:=CPDB_UpdateRecord(iHandle);
end;
procedure ajoutenbgrillesbd;
begin
 Error:=CPDB_AddRecord(iHandle);
 Error:=CPDB_WriteShortInt(iHandle,'TYPE',4);
 Error:=CPDB_WriteShortInt(iHandle,'V1',(nbgrilles div 128*128) mod 128);
 Error:=CPDB_WriteShortInt(iHandle,'V2',(nbgrilles div 128) mod 128);
 Error:=CPDB_WriteShortInt(iHandle,'V3',nbgrilles mod 128);
 Error:=CPDB_UpdateRecord(iHandle);
end;
begin
 if l <> nil then
 begin
  nom:='TrafCPDB'+zero(n);
  if CPDB_DatabaseExist(nom)= CPDB_ERR_NOEXIST then
  begin
  Error:=CPDB_CreateDatabase(0,nom,DBCreator,'TYPE=SHORTINT;V1=SHORTINT;V2=SHORTINT;V3=SHORTINT;');
  Error:=CPDB_Open(0,nom,dmModeReadWrite,iHandle);
  //ajoute la grille initiale
  lbt:=l^.plb;
  if lbt <> nil then
  begin
   //premierement les blocs normaux
   while lbt^.suivant <> nil do
   begin
    if lbt^.pb^.g = normal then
     ajouteblocbd;
    lbt:=lbt^.suivant;
   end;
   if lbt^.pb^.g = normal then
    ajouteblocbd;
   //dernierement le bloc principal
   lbt:=l^.plb;
   while lbt^.suivant <> nil do
   begin
    if lbt^.pb^.g = principal then
     ajouteblocbd;
    lbt:=lbt^.suivant;
   end;
   if lbt^.pb^.g = principal then
    ajouteblocbd;
  end;
  // ajouter les coups
  llt:=l;
  while llt^.suivant <> nil do
  begin
   ajoutecoupbd;
   llt:=llt^.suivant;
  end;
  //ajouter la duree des calculs;
  ajoutedureebd;
  ajoutenbgrillesbd;
  Error:=CPDB_Close(iHandle);
  end;
 end;
end;
procedure afficherstatistiques(duree,nbliens,nbblocs,nbgrilles:integer);
begin
 writeln('Nombre de blocs      : ',nbblocs:8);
 writeln('Nombre grilles diff. : ',nbgrilles:8);
 writeln('Duree des calculs    : ',temps(duree));
 writeln('Nombre de mouvements : ',nbliens:8);
end;
function cherchesolution(plb:plistebloc;var d,nbg:integer):plistelien;
var pla,plt,plc,plact:plistelien;
 lbt:plistebloc;
 lc,lca:plistecoup;
 pbtermine:pbloc;
 n:integer;
 termine:boolean;
 sol:plistelien;
 duree:UInt32;
procedure traiterlien;
begin
 lc:=coups(plact^.plb);
 lca:=lc;
 while (lca^.suivant <> nil) and (not termine) do
 begin
  if memebloc(lca^.pc^.pa,pbtermine) then
   termine:=true
  else
  begin
   lbt:=copierlistebloc(plact^.plb);
   jouercoup(lbt,lca^.pc);
   if not existelistebloc(plc,lbt) then
   begin
    plc:=ajouterlien(plc,lbt,plact,lca^.pc);
    plt:=ajouterlien(plt,lbt,plact,lca^.pc);
   end;
   lca:=lca^.suivant;
  end;
 end;
 if memebloc(lca^.pc^.pa,pbtermine) then
  termine:=true
 else
 begin
  lbt:=copierlistebloc(plact^.plb);
  jouercoup(lbt,lca^.pc);
  if not existelistebloc(plc,lbt) then
  begin
   plc:=ajouterlien(plc,lbt,plact,lca^.pc);
   plt:=ajouterlien(plt,lbt,plact,lca^.pc);
  end;
  lca:=lca^.suivant;
 end;
end;
procedure extraitsolution;
var dl:plistelien;
 lbct:plistebloc;
begin
 sol:=nil;
 dl:=plact;
 lbct:=copierlistebloc(dl^.plb);
 jouercoup(lbct,lca^.pc);
 sol:=ajouterlien(sol,lbct,nil,lca^.pc);  
 if plact <> nil then
 begin
  while dl^.via <> nil do
  begin
   with dl^ do
    sol:=ajouterliendebut(sol,plb,via,pc);
   dl:=dl^.via;
  end;
  sol:=ajouterliendebut(sol,dl^.plb,nil,lca^.pc);  
 end;
end;
begin
 nbg:=0;
 writeln('Recherche de la solution minimale');
 writeln('---------------------------------');
 writeln;
 writeln('               Grilles');      
 writeln('Niveau   Connues   A traiter');
 duree:=TimGetSeconds;
 if plb <> nil then
 begin
  pla:=ajouterlien(nil,plb,nil,nil);
  plc:=ajouterlien(nil,plb,nil,nil);
  pbtermine:=creerbloc(5,4,hori,deux,principal);
  termine:=false;
  n:=0;
  while not termine do
  begin
   plt:=nil;
   write(n:4);
   write(nbliens(plc):10);
   writeln(nbliens(pla):10);
   plact:=pla;
   while (plact^.suivant <> nil) and (not termine) do
   begin
    traiterlien;
    if not termine then
     plact:=plact^.suivant;
   end;
   if not termine then
   begin
    traiterlien;
    pla:=plt;
   end;
   n:=n+1;
  end;
  if termine then
  begin
   extraitsolution;
   cherchesolution:=sol;
  end
  else
   cherchesolution:=sol;
  duree:=TimGetSeconds - duree;
  d:=duree;
  nbg:=nbliens(plc);  
  write(n:4);
  write(nbliens(plc):10);
  writeln(nbliens(pla):10);
  writeln;
  writeln('Solution minimale trouvee !');
  writeln;
  afficherstatistiques(duree,nbliens(sol)-1,nbblocs(sol^.plb),nbg);
 end
 else
  writeln('Aucune liste de blocs donnee');  
 bip;
 read(c);
end;
procedure affichersolution(ll:plistelien);
var llt:plistelien;
begin
 if ll <> nil then
 begin
  llt:=ll;
  while llt^.suivant <> nil do
  begin
   affichelistebloc(llt^.plb);
   read(c);
   affichecoup(llt^.suivant^.pc);
   llt:=llt^.suivant;
  end;  
  affichelistebloc(llt^.plb);
  writeln('Termine');
 end
 else
  writeln('Aucun mouvement.');
end;
procedure menugrille(n:byte;s:string);
var select:integer;
 m:menu;
 sol:plistelien;
 plateau:plistebloc;
 menusolexiste:boolean;
 duree,nbg:integer;
begin
 plateau := nil;
 plateau:=initplateau(n);
 sol:=nil;
 menusolexiste:=false;
 duree:=0;
 nbg:=0;
 restaure(n,sol,duree,nbg);
 initmenu(m);
 titlemenu(m,'Grille ' + s);
 addmenuitem(m,'Voir grille');
 addmenuitem(m,'Calculer solution');
 repeat
  if (sol <> nil) and (not menusolexiste) then
  begin
   menusolexiste:=true;
   initmenu(m);
   titlemenu(m,'Grille ' + s);
   addmenuitem(m,'Voir grille');
   addmenuitem(m,'Calculer solution ('+temps(duree)+')');
   addmenuitem(m,'Afficher solution (coups : '+IntToString(nbliens(sol)-1)+')');
   addmenuitem(m,'Statistiques');
  end;
  select:=selectmenu(m);
  case select of
   1:
    begin
     clrscr;
     writeln;
     writeln('Grille initiale');
     writeln('---------------');
     affichelistebloc(plateau);
     read(c);
    end;
   2:
    begin
     clrscr;
     sol:=cherchesolution(plateau,duree,nbg);
     sauvegarde(n,sol,duree,nbg);
    end;
   3:
    begin
    if menusolexiste then
    begin
     clrscr;
     if sol = nil then
      sol:=cherchesolution(plateau,duree,nbg);
     if sol <> nil then
     begin
      clrscr;
      writeln;
      writeln('Solution minimale');
      writeln('-----------------');
      affichersolution(sol);
     end
     else
     begin
      writeln;
      writeln('Pas de solution trouvee.');
     end; 
     read(c);
    end;     
    end;
   4:begin
    if menusolexiste then
    begin
     clrscr;
     writeln('Statistiques');
     writeln('------------');
     writeln;
     afficherstatistiques(duree,nbliens(sol)-1,nbblocs(sol^.plb),nbg);
     read(c);
    end;
   end;
  end;
 until select = 0;
 clrscr;
end;
procedure menu2;
var select:integer;
 m:menu;
 n,nmax:byte;
begin
 nmax:=40;
 
 initmenu(m);
 titlemenu(m,'Grilles de Traffic!');
 addmenuitem(m,'Test'+existe(0));
 for n:=1 to nmax do
  addmenuitem(m,'Niveau '+IntToString(n)+existe(n));
 
 repeat
  select:=selectmenu(m);
  if select in [1..nmax+1] then
   menugrille(select-1,'Niveau ' + IntToString(select-1));
 until select = 0;
 clrscr;
 writeln;
 writeln;
 writeln;
 writeln(' ':5,'A bientot');
end;
begin
 CPDB_OPENLIB;
 menu2;
 CPDB_CLOSELIB;
end.
Récupérée de « http://zigloo.ch/index.php/Traffic.pas »
Catégories: Source | Logiciel | Pascal | Palm
Traffic.pas

Un article de Wikipedia.

Affichages

Outils personnels

Navigation

Rechercher

Boîte à outils
