; ***********************************************************
; ** Comtois le 15/07/05 - Pathfinding pour Purebasic V0.3 **
; ***********************************************************
; **********************************************************************
; ************************** 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 **
; ** 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
affPath = 1
AffGrille = 1
; --- dimension du tableau et taille d'une case ---
#max_x = 48
#max_y = 48
#taille = 12
; --- 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 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, 255))
StopDrawing()
;/Cible
CreateSprite(#cible, #taille, #taille)
StartDrawing(SpriteOutput(#cible))
Circle(#taille/2, #taille/2,(#taille/2), RGB(255, 55, 18))
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")
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")
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)
Locate(#taille*(#max_x + 1), 0)
DrawText("[F1] Sans/Avec open et closed")
Locate(#taille*(#max_x + 1), 20)
DrawText("[F2] Sans/Avec Recherche")
Locate(#taille*(#max_x + 1), 40)
DrawText("[F3] Sauve la Map")
Locate(#taille*(#max_x + 1), 60)
DrawText("[F4] Charge la Map")
Locate(#taille*(#max_x + 1), 80)
DrawText("[F5] Sans/Avec Grille")
Locate(#taille*(#max_x + 1), 100)
DrawText("[Bouton Gauche] Ajoute un mur")
Locate(#taille*(#max_x + 1), 120)
DrawText("[Bouton Droit] Efface un mur")
Locate(#taille*(#max_x + 1), 140)
DrawText("[Bouton Gauche] + [Shift] Cible")
Locate(#taille*(#max_x + 1), 160)
DrawText("[Bouton Droit] + [Shift] Départ")
Locate(#taille*(#max_x + 1), 180)
DrawText("Position : " + Str(MouseX()/#taille) + " / " + Str(MouseY()/#taille))
StopDrawing()
EndProcedure
Procedure AffGrille()
Couleur = RGB(100, 100, 100)
StartDrawing(ScreenOutput())
DrawingMode(4)
For y = 0 To #max_y
For x = 0 To #max_x
Box(x*#taille , y*#taille , #taille , #taille, Couleur)
Next x
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.w ChercheChemin()
; C'est mon interprétation du fameux A*
; 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 = ciblex And departy = cibley
ProcedureReturn 0
EndIf
; Calcul Un ID unique pour le Noeud en cours
NoeudID = departx +(#max_x + 1) * 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 ===
; dans cette version le déplacement se fait dans les huits directions
; il est possible d'ajouter un paramètre pour limiter les déplacements à 4 directions
For a = x - 1 To x + 1
For b = y - 1 To y + 1
; ---- si la Case est libre et n'a pas encore été traitée
If a >= 0 And a <= #max_x And b >= 0 And b <= #max_y
; Calcul un ID unique
TempID = a +(#max_x + 1) * b
If map(a, b) = 0 And Noeud(TempID)\Closed = 0
interdit = 0
If a = x - 1 And b = y - 1 And map(x, y - 1)= 1 And map(x - 1, y)= 1 : interdit = 1 : EndIf
If a = x - 1 And b = y + 1 And map(x, y + 1)= 1 And map(x - 1, y)= 1 : interdit = 1 : EndIf
If a = x + 1 And b = y - 1 And map(x, y - 1)= 1 And map(x + 1, y)= 1 : interdit = 1 : EndIf
If a = x + 1 And b = y + 1 And map(x, y + 1)= 1 And map(x + 1, y)= 1 : interdit = 1 : EndIf
If interdit = 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 Abs(a - x) > 0 And Abs(b - y) > 0
G = 18 + Noeud(NoeudID)\G ;
Else
G = 10 + Noeud(NoeudID)\G ;
EndIf
; si la Case n'est pas dans la liste open
If Noeud(TempID)\Open = 0 Or G < Noeud(TempID)\G
parent(a, b)\x = x
parent(a, b)\y = y
Noeud(TempID)\G = G
distance =(Abs(ciblex - a) + Abs(cibley - b))*10
Noeud(TempID)\H = distance
Noeud(TempID)\f = Noeud(TempID)\G + Noeud(TempID)\H
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
RetasseTas(Taille_Tas)
Else
; Retasse le tas à partir du Noeud en cours
For i = 1 To Taille_Tas
If Tas(i)= TempID
RetasseTas(i)
Break
EndIf
Next i
EndIf
; --- la cible est trouvée ---
If a = ciblex And b = cibley
fin = 1
Break 2
EndIf
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 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()
If ChercheChemin()= 1
a =- 1
b =- 1
cx = ciblex
cy = cibley
Couleur = RGB(255, 255, 100)
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
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
EndIf
If KeyboardReleased(#PB_Key_F2)
affPath = 1 - affPath
EndIf
If KeyboardReleased(#PB_Key_F3)
SauveMap()
EndIf
If KeyboardReleased(#PB_Key_F4)
ChargeMap()
EndIf
If KeyboardReleased(#PB_Key_F5)
AffGrille = 1 - AffGrille
EndIf
ToucheShift = KeyboardPushed(#PB_Key_LeftShift) Or KeyboardPushed(#PB_Key_RightShift)
EndIf
;/ Gestion de la souris
souris(ToucheShift)
;/affiche le fond
mur()
If AffGrille
AffGrille()
EndIf
AffCadre()
If AffOpenClosed
AffOpenClosed()
EndIf
;/Lance la recherche
If affPath
affPath()
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