Traffic.pas
Un article de Wikipedia.
Solution minimale du jeu Traffic!
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.
Catégories: Source | Logiciel | Pascal | Palm