Source:PathFinding.pb
Ce code est largement perfectible , aussi n'hésitez pas à proposer votre propre solution , ou à améliorer celle ci, tout le monde en profitera :)
; *********************************************************** ; ** Comtois le 17/07/05 - Pathfinding pour Purebasic V0.5 ** ; *********************************************************** ; ********************************************************************** ; ************************** Mode d'emploi ***************************** ; ********************************************************************** ; ** Touche [F1] pour Afficher les cases Closed / Open ** ; ** Touche [F2] pour Afficher le chemin ** ; ** Touche [F3] Sauve la Map : Permet de faire différents tests avec la même map ** ; ** Touche [F4] Charge la Map ** ; ** Touche [F5] Affiche une Grille ** ; ** Touche [F6] Efface la Map ** ; ** Touche [F7] Sans/Avec diagonale ** ; ** Touche [F8] Sans/Avec recherche du point le plus proche si l'accès à la cible n'est pas possible ** ; ** Touche [F9] Sans/Avec Remplissage >> Visualise la zone de déplacement possible à partir de Départ** ; ** Bouton Gauche de la souris ajoute un mur ** ; ** Bouton Droit de la souris efface un mur ** ; ** Bouton Gauche de la souris + la Touche [Shift] Déplace la cible ** ; ** Bouton Droit de la souris + la touche [Shift] Déplace le départ ** ; ********************************************************************** ; --- Initialisation --- If InitSprite() = 0 Or InitKeyboard() = 0 Or InitMouse() = 0 MessageRequester("Erreur", "Impossible d'initialiser DirectX 7 Ou plus", 0) End EndIf ; --- Plein écran --- #ScreenWidth = 800 #ScreenHeight = 600 #ScreenDepth = 16 If OpenScreen(#ScreenWidth,#ScreenHeight,#ScreenDepth,"Essai Pathfinding") = 0 MessageRequester("Erreur", "Impossible d'ouvrir l'écran ", 0) End EndIf ; --- Variables globales --- Global ciblex,cibley,departx,departy, AffOpenClosed,affPath,AffGrille,Chrono,ChronoMax,diagonale Global Remplissage,Proche,LePlusProche.point,Destination.point diagonale=1 affPath=1 AffGrille=1 ; --- dimension du tableau et taille d'une case --- #max_x=58 #max_y=58 #max_x1=#max_x+1 #taille=10 ; --- positionne la cible sur la grille --- ciblex=1+Random(#max_x-2) cibley=1+Random(#max_y-2) ; --- positionne le départ sur la grille --- departx=1+Random(#max_x-2) departy=1+Random(#max_y-2) Structure Noeud Id.l x.l y.l f.l G.l H.l Open.l Closed.l EndStructure ; --- pour la recherche du chemin --- Dim map(#max_x,#max_y) Dim MapTest(#max_x,#max_y) Dim parent.point(#max_x,#max_y) Dim Tas((#max_x+1)*(#max_y+1)) Dim Noeud.Noeud((#max_x+1)*(#max_y+1)) ; ************************************************************************************ ; *** LES SPRITES *** ; ************************************************************************************ Enumeration #depart #cible #Souris EndEnumeration ;/Départ CreateSprite(#depart, #taille, #taille) StartDrawing(SpriteOutput(#depart)) Circle(#taille/2,#taille/2,(#taille/2),RGB(255,255,15)) StopDrawing() ;/Cible CreateSprite(#cible, #taille, #taille) StartDrawing(SpriteOutput(#cible)) Circle(#taille/2,#taille/2,(#taille/2),RGB(255,55,15)) StopDrawing() ;/ Souris CreateSprite(#Souris, #taille, #taille) StartDrawing(SpriteOutput(#Souris)) DrawingMode(4) Box(1,1,#taille-1,#taille-1,RGB(100,200,255)) StopDrawing() ; ************************************************************************************ ; *** LES PROCEDURES *** ; ************************************************************************************ Procedure SauveMap() If CreateFile(0,"PathFindingMap.map") WriteLong(ciblex) WriteLong(cibley) WriteLong(departx) WriteLong(departy) For y=0 To #max_y For x=0 To #max_x WriteLong(map(x,y)) Next x Next y CloseFile(0) EndIf EndProcedure Procedure ChargeMap() If OpenFile(0,"PathFindingMap.map") ciblex=ReadLong() cibley=ReadLong() departx=ReadLong() departy=ReadLong() For y=0 To #max_y For x=0 To #max_x map(x,y) = ReadLong() Next x Next y CloseFile(0) EndIf EndProcedure Procedure mur() Couleur=RGB(100,100,255) StartDrawing(ScreenOutput()) For y=0 To #max_y For x=0 To #max_x If map(x,y) Box(x*#taille + 1,y*#taille + 1,#taille - 1,#taille - 1,Couleur) EndIf Next x Next y DrawingMode(1) FrontColor(255,255,255) Col=0 Locate(#taille*(#max_x+1),lig) : lig + 20 DrawText("[F1] Sans/Avec open et closed") Locate(#taille*(#max_x+1),lig) : lig + 20 DrawText("[F2] Sans/Avec Recherche") Locate(#taille*(#max_x+1),lig) : lig + 20 DrawText("[F3] Sauve la Map") Locate(#taille*(#max_x+1),lig) : lig + 20 DrawText("[F4] Charge la Map") Locate(#taille*(#max_x+1),lig) : lig + 20 DrawText("[F5] Sans/Avec Grille") Locate(#taille*(#max_x+1),lig) : lig + 20 DrawText("[F6] Efface la Map") Locate(#taille*(#max_x+1),lig) : lig + 20 DrawText("[F7] Sans/Avec Diagonale") Locate(#taille*(#max_x+1),lig) : lig + 20 DrawText("[F8] Sans/Avec proche") Locate(#taille*(#max_x+1),lig) : lig + 20 DrawText("[F9] Sans/Avec Zone proche") Locate(#taille*(#max_x+1),lig) : lig + 20 DrawText("[Bouton Gauche] Ajoute un mur") Locate(#taille*(#max_x+1),lig) : lig + 20 DrawText("[Bouton Droit] Efface un mur") Locate(#taille*(#max_x+1),lig) : lig + 20 DrawText("[Bouton Gauche] + [Shift] Cible") Locate(#taille*(#max_x+1),lig) : lig + 20 DrawText("[Bouton Droit] + [Shift] Départ") Locate(#taille*(#max_x+1),lig) : lig + 20 DrawText("Position : " + Str(MouseX()/#taille) + " / " + Str(MouseY()/#taille)) Locate(#taille*(#max_x+1),lig) : lig + 20 DrawText("Temps : " + Str(Chrono) + " / " + Str(ChronoMax)) StopDrawing() EndProcedure Procedure EffaceMur() For y=0 To #max_y For x=0 To #max_x map(x,y)=0 Next x Next y EndProcedure Procedure AffGrille() Couleur=RGB(100,100,100) StartDrawing(ScreenOutput()) For x=0 To #max_x Line(x*#taille,0,0,(#max_y+1)*#taille,Couleur) Next x For y=0 To #max_y Line(0,y*#taille,(#max_x+1)* #taille,0,Couleur) Next y StopDrawing() EndProcedure Procedure RetasseTas(Pos) M=Pos While M <> 1 If Noeud(Tas(M))\f <= Noeud(Tas(M/2))\f temp = Tas(M/2) Tas(M/2) = Tas(M) Tas(M) = temp M = M/2 Else Break EndIf Wend EndProcedure Procedure remplissage(*P.point) Psp = 1 Dim Px(1000) Dim Py(1000) Px(0) = departx Py(0) = departy lim = 1 c = 2 CopyMemory(map(),MapTest(),(#max_x+1)*(#max_y+1)*4) distanceMini=-1 While Psp <> 0 xi = Px(Psp - 1) xf = Px(Psp - 1) x = Px(Psp - 1) y = Py(Psp - 1) x + 1 cp = MapTest(x, y) While cp <> lim And x <= #max_x xf = x x + 1 cp = MapTest(x, y) Wend x = Px(Psp - 1) - 1 cp = MapTest(x, y) While cp <> lim And x >= 0 xi = x x - 1 cp = MapTest(x, y) Wend ;Rechercher le point le plus proche ici !! If xi<xf a=xi b=xf Else a=xf b=xi EndIf For i=a To b MapTest(i,y)=c distance=(Abs(ciblex-i) + Abs(cibley-y))*10 If distance < distanceMini Or distanceMini = -1 distanceMini = distance *P\x = i *P\y = y EndIf Next i ;Si la cible est trouvée , on ne va pas plus loin If *P\x = ciblex And *P\y=cibley Break EndIf Psp - 1 ;Y+1 x = xf While x >= xi And y < #max_y cp = MapTest(x, y + 1) While (((cp = lim) Or (cp = c)) And (x >= xi)) x - 1 cp = MapTest(x, y + 1) Wend If ((x >= xi) And (cp <> lim) And (cp <> c)) Px(Psp) = x Py(Psp) = y + 1 Psp + 1 EndIf cp = MapTest(x, y + 1) While (( cp <> lim ) And ( x >= xi )) x - 1 cp = MapTest(x,y+1) Wend Wend ;Y-1 x = xf While x >= xi And y > 0 cp = MapTest(x, y - 1) While (((cp = lim) Or (cp = c)) And (x >= xi)) x - 1 cp = MapTest(x, y - 1) Wend If ((x >= xi) And (cp <> lim) And (cp <> c)) Px(Psp) = x Py(Psp) = y - 1 Psp + 1 EndIf cp = MapTest(x, y - 1) While (( cp <> lim ) And ( x >= xi )) x - 1 cp = MapTest(x,y-1) Wend Wend Wend EndProcedure Procedure.w ChercheChemin() ;Initialise le tableau Noeud Dim Noeud.Noeud((#max_x+1)*(#max_y+1)) ;Si on est déjà arrivé pas la peine d'aller plus loin If departx=Destination\x And departy=Destination\y ProcedureReturn 0 EndIf ;Calcul Un ID unique pour le Noeud en cours NoeudID = departx NoeudID + #max_x1 * departy ; --- on met le point de départ dans le tas --- ;Un tas c'est un arbre , habituellement binaire. ;Il permet de retrouver rapidement le f le plus petit ,sans avoir à trier l'ensemble des Noeuds. Taille_Tas = 1 Tas(Taille_Tas)=NoeudID Noeud(NoeudID)\x=departx Noeud(NoeudID)\y=departy Noeud(NoeudID)\Open=1 ; --- tant que la liste open n'est pas vide et tant qu'on a pas trouvé la cible While fin = 0 ; --- il n'y a pas de chemin --- If Taille_Tas = 0 fin = 2 Break Else ; --- on récupère la Case la plus avantageuse ( avec F le plus bas) === NoeudID=Tas(1) x=Noeud(NoeudID)\x y=Noeud(NoeudID)\y Noeud(NoeudID)\Closed=1 ;Supprime un noeud du tas Tas(1) = Tas(Taille_Tas) Taille_Tas - 1 ;Retasse le tas après une suppression v = 1 Repeat u = v If 2*u+1 <= Taille_Tas If Noeud(Tas(u))\f >= Noeud(Tas(2*u))\f : v = 2*u : EndIf If Noeud(Tas(v))\f >= Noeud(Tas(2*u+1))\f : v = 2*u+1 : EndIf ElseIf 2*u <= Taille_Tas If Noeud(Tas(u))\f >= Noeud(Tas(2*u))\f : v = 2*u : EndIf EndIf If u <> v temp = Tas(u) Tas(u) = Tas(v) Tas(v) = temp Else Break ; la propriété du tas est rétablie , on peut quitter EndIf ForEver EndIf ; --- on teste les cases autour de la case sélectionnée === For a = x - 1 To x + 1 For b = y - 1 To y + 1 ;Conditions de validité d'une case If a >= 0 And a <= #max_x And b >= 0 And b <= #max_y And (diagonale=1 Or a = x Or b = y) And (a = x Or b = y Or map(a,y)=0 Or map(x,b)=0) ;Calcul un ID unique TempID = a TempID + #max_x1 * b ; ---- si la Case est libre et n'a pas encore été traitée If map(a,b) = 0 And Noeud(TempID)\Closed = 0 ; calcule G pour la Case en cours de test ( à adapter selon le jeu) ; si la distance n'a pas d'importance , on peut se contenter de calculer ; le nombre de cases , donc de faire G = G(x,y) + 1 If a <> x And b <> y G = 14 + Noeud(NoeudID)\G ; Else G = 10 + Noeud(NoeudID)\G ; EndIf ; si la Case n'est pas dans la liste open ou si est meilleur en passant par cette case If Noeud(TempID)\Open = 0 Or G < Noeud(TempID)\G parent(a,b)\x = x parent(a,b)\y = y Noeud(TempID)\G = G Noeud(TempID)\f = Noeud(TempID)\G Noeud(TempID)\f + (Abs(ciblex-a) + Abs(cibley-b))*10 If Noeud(TempID)\Open = 0 ;Ajoute le Noeud dans le tas Taille_Tas + 1 Tas(Taille_Tas) = TempID Noeud(TempID)\x = a Noeud(TempID)\y = b Noeud(TempID)\Open = 1 Position = Taille_Tas Else ;Cherche la position du Noeud dans le tas For i = 1 To Taille_Tas If Tas(i)=TempID Position = i Break EndIf Next i EndIf ;Retasse le tas à partir du Noeud en cours While Position <> 1 If Noeud(Tas(Position))\f <= Noeud(Tas(Position/2))\f temp = Tas(Position/2) Tas(Position/2) = Tas(Position) Tas(Position) = temp Position = Position/2 Else Break EndIf Wend ; --- la cible est trouvée --- If a = Destination\x And b = Destination\y fin = 1 Break 2 EndIf EndIf EndIf EndIf Next b Next a Wend ProcedureReturn fin EndProcedure Procedure souris(ToucheShift) If ExamineMouse() SX = MouseX() / #taille SY = MouseY() / #taille If SX >= 0 And SX <= #max_x And SY >= 0 And SY <= #max_y If ToucheShift = 0 If MouseButton(1) map(SX,SY)=1 ;place un mur ElseIf MouseButton(2) map(SX,SY)=0 ; supprime un Mur EndIf Else If MouseButton(1) ciblex = SX : cibley = SY ; place la cible ElseIf MouseButton(2) departx = SX : departy = SY ; place le départ EndIf EndIf EndIf EndIf EndProcedure Procedure AffRemplissage() Couleur=RGB(85,85,85) StartDrawing(ScreenOutput()) For y=0 To #max_y For x=0 To #max_x xa=x*#taille ya=y*#taille Id = x + (#max_x+1)*y If MapTest(x,y)=2 Box(xa + 1,ya + 1,#taille - 1,#taille - 1,Couleur) EndIf Next x Next y StopDrawing() EndProcedure Procedure AffOpenClosed() CoulOpen=RGB(200,255,200) CoulClosed=RGB(255,200,200) StartDrawing(ScreenOutput()) For y=0 To #max_y For x=0 To #max_x xa=x*#taille ya=y*#taille Id = x + (#max_x+1)*y If Noeud(Id)\Closed Box(xa + 1,ya + 1,#taille - 1,#taille - 1,CoulClosed) ElseIf Noeud(Id)\Open Box(xa + 1,ya + 1,#taille - 1,#taille - 1,CoulOpen) EndIf Next x Next y StopDrawing() EndProcedure Procedure affPath() Couleur=RGB(55,255,150) tps=ElapsedMilliseconds() If ChercheChemin()=1 Chrono=ElapsedMilliseconds()-tps If Chrono>ChronoMax ChronoMax=Chrono EndIf a=-1 b=-1 cx=Destination\x cy=Destination\y StartDrawing(ScreenOutput()) While a <> departx Or b <> departy a = parent(cx,cy)\x b = parent(cx,cy)\y xa=(cx*#taille)+#taille/2 ya=(cy*#taille)+#taille/2 xb=(a*#taille)+#taille/2 yb=(b*#taille)+#taille/2 LineXY(xa,ya,xb,yb,Couleur) cx = a cy = b Wend Circle(Destination\x*#taille+#taille/2,Destination\y*#taille+#taille/2,#taille/2,Couleur) StopDrawing() EndIf EndProcedure Procedure AffCadre() Couleur=RGB(255,255,255) StartDrawing(ScreenOutput()) DrawingMode(4) Box(0,0,#taille*(#max_x+1),#taille*(#max_y+1),Couleur) StopDrawing() EndProcedure ; ************************************************************************************ ; *** BOUCLE PRINCIPALE *** ; ************************************************************************************ Repeat ClearScreen(0,0,0) ;/ état du clavier If ExamineKeyboard() If KeyboardReleased(#PB_Key_F1) AffOpenClosed=1-AffOpenClosed ElseIf KeyboardReleased(#PB_Key_F2) affPath=1-affPath ElseIf KeyboardReleased(#PB_Key_F3) SauveMap() ElseIf KeyboardReleased(#PB_Key_F4) ChargeMap() ElseIf KeyboardReleased(#PB_Key_F5) AffGrille=1-AffGrille ElseIf KeyboardReleased(#PB_Key_F6) EffaceMur() ElseIf KeyboardReleased(#PB_Key_F7) diagonale=1-diagonale ElseIf KeyboardReleased(#PB_Key_F8) Proche=1-Proche ElseIf KeyboardReleased(#PB_Key_F9) Remplissage=1-Remplissage EndIf ToucheShift = KeyboardPushed(#PB_Key_LeftShift) Or KeyboardPushed(#PB_Key_RightShift) EndIf ;/ Gestion de la souris souris(ToucheShift) ;/affiche le fond If Proche Or Remplissage remplissage(@LePlusProche) If Remplissage AffRemplissage() EndIf EndIf If Proche Destination\x=LePlusProche\x Destination\y=LePlusProche\y Else Destination\x=ciblex Destination\y=cibley EndIf mur() If AffGrille AffGrille() EndIf AffCadre() If AffOpenClosed AffOpenClosed() EndIf ;/Lance la recherche If affPath affPath() Else ChronoMax=0 EndIf ;/Affiche les sprites DisplayTransparentSprite(#Souris,MouseX() - #taille / 2,MouseY() - #taille / 2) DisplayTransparentSprite(#cible,ciblex * #taille,cibley * #taille) DisplayTransparentSprite(#depart,departx * #taille,departy * #taille) FlipBuffers() Until KeyboardPushed(#PB_Key_Escape) End
