Sources PureBasic
Sources PureBasicConsultez toutes les sources
Nombre d'auteurs : 41, nombre de sources : 88, dernière mise à jour : 13 août 2011
- Compteur de mots dans un texte avec un arbre binaire
- Construction d'un quadtree
- Formatage d'un nombre (StrNum)
- Recherche simultanée du maximum et du minimum d'un tableau
- Déterminer si un point se trouve dans un polygone avec la méthode 'Winding number'
- Construction d'un labyrinthe en 2D
- Exemple de pathfinding A*
- Reprise d'un tutoriel : Un morpion avec intelligence artificielle (Alpha-Beta)
Pour cela on utilise un arbre binaire. L'arbre contient un noeud pour chaque mot, et chaque noeud contient une variable pour stocker :
- Le mot
- Le nombre d'apparitions du mot
- Un pointeur vers le noeud suivant à gauche
- Un pointeur vers le noeud suivant à droite
A partir de n'importe quel noeud , le sous arbre de gauche ne contient que des mots de valeurs inférieures au mot contenu dans le noeud, et le sous arbre de droite ne contient que des mots de valeurs supérieures.
;- purebasic 4.0
Structure
Noeud
mot.s
compteur.l
*
Gauche.Noeud
*
Droit.Noeud
EndStructure
Procedure
.s Affiche(*
Noeud.Noeud, minimum.l)
Protected
resultat.s
If
*
Noeud
resultat +
Affiche(*
Noeud\Gauche, minimum)
If
*
Noeud\compteur >=
minimum
resultat +
RSet(Str(*
Noeud\compteur), 4
, "0"
) +
" : "
+
*
Noeud\mot +
#CRLF
$
EndIf
resultat +
Affiche(*
Noeud\Droit, minimum)
EndIf
ProcedureReturn
resultat
EndProcedure
Procedure
.l Arbre(*
Noeud.Noeud, mot.s)
If
*
Noeud
If
mot =
*
Noeud\mot
*
Noeud\compteur +
1
ElseIf
mot <
*
Noeud\mot
*
Noeud\Gauche =
Arbre(*
Noeud\Gauche, mot)
Else
*
Noeud\Droit =
Arbre(*
Noeud\Droit, mot)
EndIf
Else
*
Noeud =
AllocateMemory(SizeOf(Noeud))
If
*
Noeud
*
Noeud\mot =
mot
*
Noeud\compteur =
1
EndIf
EndIf
ProcedureReturn
*
Noeud
EndProcedure
Procedure
.l Analyse(texte.s, minimum.l)
Protected
*
arbre, mot.s, nbcar.l, *
txt.Character =
@texte
While
*
txt\c
Select
*
txt\c
Case
' ', '.', ',', ';', ' ', '(', ')', #TAB, #CR, #LF
If
nbcar >=
minimum
*
arbre =
Arbre(*
arbre, mot)
EndIf
mot =
""
nbcar =
0
Default
mot +
Chr(*
txt\c)
nbcar +
1
EndSelect
*
txt +
SizeOf(Character)
Wend
ProcedureReturn
*
arbre
EndProcedure
Procedure
.s Texte(fichier.s)
Protected
texte.s
If
ReadFile(0
, fichier)
texte =
Space(Lof(0
))
ReadData(0
, @texte, Lof(0
))
CloseFile(0
)
EndIf
ProcedureReturn
texte
EndProcedure
;- affiche les mots de 4 caractères minimum, présents au minimum 20 fois dans le texte.
MessageRequester("Résultat"
, Affiche(Analyse(Texte(#PB_Compiler_Home
+
"Compilers/APIFunctionListing.txt"
), 4
), 20
))
;21/12/08 - 4.30
;Exemple de construction d'un quadtree avec répartition des objets
;Vous pouvez changer la valeur de #QuadObjet pour constater le changement de répartition
;
Structure
s_Objet
x.l
y.l
Rayon.l
EndStructure
Structure
s_Boite
Xmini.l
Ymini.l
Xmaxi.l
Ymaxi.l
EndStructure
Structure
s_QuadTree
Depth.l
Boite.s_Boite
NbObjets.l
*
Liste.s_Objet
*
Fils.s_QuadTree[4
]
EndStructure
;-Declaration des procédures
Declare
ConstructionQuadTree(*
Noeud.s_QuadTree, *
Boite.s_Boite, *
Liste.s_Objet, NbObjets)
Declare
RenderQuadtree(*
this.s_QuadTree)
;-Variables de configuration
#NbObjets
=
50
; Nombre d'objets dans la scène
#QuadSize
=
1023
; Taille initiale du quadtree
#QuadDepth
=
5
; Profondeur du quadtree (nb de fois qu'on decoupe le plan)
#QuadObjet
=
1
; Nombre d'objets maxi par Noeud
#Rayon
=
2
; Rayon d'un objet
Dim
ListeInitiale.s_Objet(#NbObjets
-
1
)
Define
.s_QuadTree NoeudInitial
Define
.s_Boite BoiteInitiale
;-Initialise une boite
Procedure
InitBoite(*
this.s_Boite, Xmini, Xmaxi, Ymini, Ymaxi)
With
*
this
\Xmini =
Xmini
\Xmaxi =
Xmaxi
\Ymini =
Ymini
\Ymaxi =
Ymaxi
EndWith
EndProcedure
;Création d'une liste d'objets (sphères dans cet exemple)
Procedure
CreationListe(Array this.s_Objet(1
))
For
i=
0
To
#NbObjets
-
1
this(i)\x =
Random(#QuadSize
-
#Rayon
)
this(i)\y =
Random(#QuadSize
-
#Rayon
)
this(i)\Rayon =
#Rayon
Next
i
EndProcedure
;Construction du quadtree avec répartition des objets
Procedure
ConstructionQuadTree(*
Noeud.s_QuadTree, *
Boite.s_Boite, *
Liste.s_Objet, NbObjets)
Define
.s_Boite BoiteFils
Define
.s_Objet *
ListeFils, *
Ptr
;Define.s_Vecteur CentreBoite, DemiDimensionBoite
Define
.s_QuadTree *
PtrF
Define
.l x, y, z, i, t, NbObjetsFils
NewList
Liste.s_Objet()
*
Noeud\Boite\Xmini =
*
Boite\Xmini
*
Noeud\Boite\Xmaxi =
*
Boite\Xmaxi
*
Noeud\Boite\Ymini =
*
Boite\Ymini
*
Noeud\Boite\Ymaxi =
*
Boite\Ymaxi
; Le noeud peut être partagé ?
If
NbObjets >
#QuadObjet
And
*
Noeud\Depth <
#QuadDepth
;On répartit les objets dans les noeuds fils
For
y =
0
To
1
For
x =
0
To
1
;No du fils
i =
(y <<
1
) |
x
;Boite englobante du fils i
BoiteFils\Xmini =
(1
.0
-
x /
2
.0
) *
*
Boite\Xmini +
x /
2
.0
*
*
Boite\Xmaxi
BoiteFils\Xmaxi =
BoiteFils\Xmini +
(*
Boite\Xmaxi -
*
Boite\Xmini) /
2
.0
BoiteFils\Ymini =
(1
.0
-
y /
2
.0
) *
*
Boite\Ymini +
y /
2
.0
*
*
Boite\Ymaxi
BoiteFils\Ymaxi =
BoiteFils\Ymini +
(*
Boite\Ymaxi -
*
Boite\Ymini) /
2
.0
*
Ptr =
*
Liste
ClearList(Liste())
For
t =
1
To
NbObjets
; Calcul les objets en collision avec la boite du fils i
If
*
Ptr\x >
BoiteFils\Xmini And
*
Ptr\x <
BoiteFils\Xmaxi And
*
Ptr\y >
BoiteFils\Ymini And
*
Ptr\y <
BoiteFils\Ymaxi
AddElement(Liste())
CopyMemory(*
Ptr, Liste(), SizeOf(s_Objet))
EndIf
*
Ptr +
SizeOf(s_Objet)
Next
t
NbObjetsFils =
ListSize(Liste())
*
ListeFils =
#Null
If
NbObjetsFils
*
ListeFils =
AllocateMemory(SizeOf(s_Objet) *
NbObjetsFils)
*
Ptr =
*
ListeFils
ForEach
Liste()
CopyMemory(Liste(), *
Ptr, SizeOf(s_Objet))
*
Ptr +
SizeOf(s_Objet)
Next
EndIf
;Ajoute un Noeud
*
Noeud\Fils[i]=
AllocateMemory(SizeOf(s_QuadTree))
*
PtrF =
*
Noeud\Fils[i]
*
PtrF\Depth =
*
Noeud\Depth +
1
ConstructionQuadTree(*
Noeud\Fils[i], @BoiteFils, *
ListeFils, NbObjetsFils)
Next
x
Next
y
Else
; Affecte la liste au noeud en cours
*
Noeud\Liste =
*
Liste
*
Noeud\NbObjets =
NbObjets
EndIf
EndProcedure
; Rendu du Quadtree
Procedure
RenderQuadtree(*
this.s_QuadTree)
DrawingMode(#PB_2DDrawing_Outlined
)
Box(*
this\Boite\xmini,*
this\Boite\ymini,*
this\Boite\xmaxi-*
this\boite\xmini,*
this\Boite\ymaxi-*
this\Boite\ymini,#White
)
If
*
this\Liste
*
Ptr.s_Objet =
*
this\Liste
For
i =
0
To
*
this\NbObjets-
1
Circle(*
Ptr\x,*
Ptr\y, *
Ptr\Rayon,#Red
)
*
Ptr +
SizeOf(s_Objet)
Next
i
EndIf
For
y =
0
To
1
For
x =
0
To
1
i =
(y <<
1
) |
x
If
*
this\Fils[i]
RenderQuadtree(*
this\Fils[i])
EndIf
Next
x
Next
y
EndProcedure
;*******************
;- Exemple *
;*******************
If
InitSprite()=
0
Or
InitMouse()=
0
Or
InitKeyboard()=
0
End
EndIf
OpenScreen(1280
,1024
,32
,"Quadtree Demo"
)
InitBoite(@BoiteInitiale, 0
, #QuadSize
, 0
, #QuadSize
)
CreationListe(ListeInitiale())
ConstructionQuadTree(@NoeudInitial, @BoiteInitiale, ListeInitiale(), #NbObjets
)
Repeat
ClearScreen(#Black
)
ExamineKeyboard()
; Rendu du quadtree
StartDrawing(ScreenOutput())
RenderQuadtree(@NoeudInitial)
StopDrawing()
FlipBuffers()
Until
KeyboardPushed(#PB_Key_Escape
)
Il s'agit de 2 fonctions (une pour les Quads, une pour les Doubles) pour formater un nombre comme ceci :
StrNumQ(-1234567) donne "-1,234,567"
StrNumD(-1234.5678) donne "-1,234.567"
Voici une solution qui ne fait pas appel à l'API windows (donc utile aussi sous Linux ou Mac).
Récursivité, quand tu nous tiens...
; StrNumQ(Number.q [, Grouping.l [, ThousandSep.s]])
; StrNumD(Number.d [, Grouping.l [, ThousandSep.s [, DecimalSep.s [, NumDigits.l]]]])
EnableExplicit
Procedure
.s StrNumQ(Number.q, Grouping.l =
3
, ThousandSep.s =
","
, Reserved1.s =
""
, Reserved2.s =
""
, Reserved3.l =
0
)
If
Not
Reserved3
ProcedureReturn
StrNumQ(0
, Grouping, ThousandSep, StrQ(Number), ""
, 1
)
EndIf
If
Not
Reserved1 Or
Reserved1 =
"-"
ProcedureReturn
Reserved1 +
Reserved2
EndIf
If
Reserved3 =
2
Reserved2 =
ThousandSep +
Reserved2
EndIf
ProcedureReturn
StrNumQ(0
, Grouping, ThousandSep, Left(Reserved1, Len(Reserved1)-
Grouping), Right(Reserved1, Grouping) +
Reserved2, 2
)
EndProcedure
Procedure
.s StrNumD(Number.d, Grouping.l =
3
, ThousandSep.s =
","
, DecimalSep.s =
"."
, NumDigits.l =
4
, Reserved1.s =
""
, Reserved2.s =
""
, Reserved3.l =
0
)
If
Not
Reserved3
ProcedureReturn
StrNumD(0
, Grouping, ThousandSep, ""
, 0
, StringField(StrD(Number), 1
, "."
), DecimalSep +
StringField(StrD(Number, NumDigits), 2
, "."
), 1
)
EndIf
If
Not
Reserved1 Or
Reserved1 =
"-"
ProcedureReturn
Reserved1 +
Reserved2
EndIf
If
Reserved3 =
2
Reserved2 =
ThousandSep +
Reserved2
EndIf
ProcedureReturn
StrNumD(0
, Grouping, ThousandSep, ""
, 0
, Left(Reserved1, Len(Reserved1)-
Grouping), Right(Reserved1, Grouping) +
Reserved2, 2
)
EndProcedure
Debug
"StrNumQ()"
;{
Debug
StrNumQ(1234567890
)
Debug
StrNumQ(123456789
)
Debug
StrNumQ(12345678
)
Debug
StrNumQ(1234567
)
Debug
StrNumQ(123456
)
Debug
StrNumQ(12345
)
Debug
StrNumQ(1234
)
Debug
StrNumQ(123
)
Debug
StrNumQ(12
)
Debug
StrNumQ(1
)
Debug
StrNumQ(0
)
Debug
StrNumQ(-
1
)
Debug
StrNumQ(-
12
)
Debug
StrNumQ(-
123
)
Debug
StrNumQ(-
1234
)
Debug
StrNumQ(-
12345
)
Debug
StrNumQ(-
123456
)
Debug
StrNumQ(-
1234567
)
Debug
StrNumQ(-
12345678
)
Debug
StrNumQ(-
123456789
)
Debug
StrNumQ(-
1234567890
)
Debug
""
;}
Debug
"StrNumD()"
;{
Debug
StrNumD(1234567890
.12345
)
Debug
StrNumD(123456789
.12345
)
Debug
StrNumD(12345678
.12345
)
Debug
StrNumD(1234567
.12345
)
Debug
StrNumD(123456
.12345
)
Debug
StrNumD(12345
.12345
)
Debug
StrNumD(1234
.12345
)
Debug
StrNumD(123
.12345
)
Debug
StrNumD(12
.12345
)
Debug
StrNumD(1
.12345
)
Debug
StrNumD(0
.12345
)
Debug
StrNumD(-
1
.12345
)
Debug
StrNumD(-
12
.12345
)
Debug
StrNumD(-
123
.12345
)
Debug
StrNumD(-
1234
.12345
)
Debug
StrNumD(-
12345
.12345
)
Debug
StrNumD(-
123456
.12345
)
Debug
StrNumD(-
1234567
.12345
)
Debug
StrNumD(-
12345678
.12345
)
Debug
StrNumD(-
123456789
.12345
)
Debug
StrNumD(-
1234567890
.12345
)
Debug
""
;}
End
ce qui revient au même que la fonction Win32 dédiée :
Procedure
.s StrNum(Number.s, decimal.l =
2
) ; Formats a number string as a number string customized for a specified locale.
Protected
result.s, fmt.NUMBERFMT
fmt\NumDigits =
decimal ; Specifies the number of fractional digits.
fmt\LeadingZero =
0
; Specifies whether to use leading zeroes in decimal fields.
fmt\Grouping =
3
; Specifies the size of each group of digits to the left of the decimal.
fmt\lpDecimalSep =
@"."
; Pointer to a null-terminated decimal separator string.
fmt\lpThousandSep =
@" "
; Pointer to a null-terminated thousand separator string.
fmt\NegativeOrder =
1
; Specifies the negative number mode (LOCALE_INEGNUMBER).
result =
Space(GetNumberFormat_(0
, 0
, Number, fmt, 0
, 0
))
GetNumberFormat_(0
, 0
, Number, fmt, @result, Len(result))
ProcedureReturn
result
EndProcedure
Macro
StrNumL(Number) : StrNum(Str (Number), 0
) : EndMacro
Macro
StrNumF(Number) : StrNum(StrF(Number), 4
) : EndMacro
Macro
StrNumD(Number) : StrNum(StrD(Number), 8
) : EndMacro
Macro
StrNumQ(Number) : StrNum(StrQ(Number), 0
) : EndMacro
Debug
StrNumD(-
112233445566
.778899
)
Ce code est l'adaptation avec PureBasic d'un algorithme présenté à l'adresse suivante :
https://algo.developpez.com/sources/?page=tableaux#Recherche_min_max
; Recherche simultanée du maximum et du minimum
;
; Auteur : Romuald Perrot
; Lien : http://algo.developpez.com/sources/?page=tableaux#Recherche_min_max
;
; Adaptation PureBasic par Comtois le 06/02/2010 - PB v4.40
;
; Entrée :
; T : Tableau de n nombres indexé à partir de 1. (n >= 2)
;
; Sortie :
; Max : un nombre égal au plus grand élément de T.
; Min : un nombre égal au plus petit élement de T.
;
; Complexité :
; 3 * ( n / 2 ) comparaisons
#IntegerMax
=
$7FFFFFFF
Structure
MinMax
Min.i
Max.i
EndStructure
Define
i, n
Define
Resultat.MinMax
Declare
IsImPair(n)
Declare
MinMax(Array T(1
), n, *
Resultat.MinMax)
n =
999999
Dim
Tableau(n)
;Remplissage du tableau
For
i =
1
To
n
Tableau(i) =
Random(#IntegerMax
)
Next
i
;Recherche du Min et du Max
MinMax(Tableau(), n, @Resultat)
MessageRequester("Recherche simultanée du maximum et du minimum"
, "Mini = "
+
Str(Resultat\Min) +
#LFCR
$ +
"Maxi = "
+
Str(Resultat\Max),0
)
Procedure
MinMax(Array T(1
), n, *
Resultat.MinMax)
If
IsImPair(n) =
0
If
T(1
) >
T(2
)
*
Resultat\Max =
T(1
)
*
Resultat\Min =
T(2
)
Else
*
Resultat\Max =
T(2
)
*
Resultat\Min =
T(1
)
EndIf
i =
3
Else
*
Resultat\Max =
T(1
)
*
Resultat\Min =
T(1
)
i =
2
EndIf
While
i <
n
If
T(i) <
T(i+
1
)
If
T(i) <
*
Resultat\Min
*
Resultat\Min =
T(i)
EndIf
If
T(i+
1
) >
*
Resultat\Max
*
Resultat\Max =
T(i+
1
)
EndIf
Else
If
T(i+
1
) <
*
Resultat\Min
*
Resultat\Min =
T(i+
1
)
EndIf
If
T(i) >
*
Resultat\Max
*
Resultat\Max =
T(i)
EndIf
EndIf
i =
i +
2
Wend
EndProcedure
Procedure
IsImPair(n)
ProcedureReturn
(n &
1
)
EndProcedure
Adaption pour PureBasic de l'algorithme du Winding number que vous trouverez ici avec les explications en anglais.
; Copyright 2001, softSurfer (www.softsurfer.com)
; This code may be freely used And modified For any purpose
; providing that this copyright notice is included With it.
; SoftSurfer makes no warranty For this code, And cannot be held
; liable For any real Or imagined damage resulting from its use.
; Users of this code must verify correctness For their application.
EnableExplicit
; isLeft(): tests If a point is Left|On|Right of an infinite line.
; Input: three points P0, P1, And P2
; Return: >0 For P2 left of the line through P0 And P1
; =0 For P2 on the line
; <0 For P2 right of the line
; See: the January 2001 Algorithm "Area of 2D and 3D Triangles and Polygons"
Procedure
isLeft(*
P0.point, *
P1.point, *
P2.point)
ProcedureReturn
((*
P1\x -
*
P0\x) *
(*
P2\y -
*
P0\y) -
(*
P2\x -
*
P0\x) *
(*
P1\y -
*
P0\y))
EndProcedure
; wn_PnPoly(): winding number test For a point in a polygon
; Input: P = a point,
; V[] = vertex points of a polygon V[n+1] With V[n]=V[0]
; Return: wn = the winding number (=0 only If P is outside V[])
Procedure
wn_PnPoly(*
P.point,Array V.Point(1
), n)
Define
i.i
Define
wn.i =
0
; // the winding number counter
; loop through all edges of the polygon
For
i=
0
To
n-
1
; edge from V[i] To V[i+1]
If
V(i)\y <=
*
P\y ; start y <= P.y
If
V(i+
1
)\y >
*
P\y ; an upward crossing
If
isLeft(@V(i), @V(i+
1
), *
P) >
0
; P left of edge
wn +
1
; have a valid up intersect
EndIf
EndIf
Else
; start y > P.y (no test needed)
If
V(i+
1
)\y <=
*
P\y ; a downward crossing
If
isLeft(@V(i), @V(i+
1
), *
P) <
0
; P right of edge
wn -
1
; have a valid down intersect
EndIf
EndIf
EndIf
Next
i
ProcedureReturn
wn
EndProcedure
OpenWindow(0
,0
,0
,800
,600
,"Point Inside Quadrangle"
,#PB_Window_ScreenCentered
|
#PB_Window_SystemMenu
)
#Nb
=
4
Dim
Polygon.Point(#Nb
)
Define
i.i, p.point
Define
ev
For
i=
0
To
#Nb
Read.i Polygon(i)\x
Read.i Polygon(i)\y
Next
i
Repeat
ev =
WindowEvent()
Delay(20
)
If
StartDrawing(WindowOutput(0
))
p\x =
WindowMouseX(0
)
p\y =
WindowMouseY(0
)
If
wn_PnPoly(@p, Polygon(), #Nb
)
FrontColor(RGB(200
,20
,20
))
Else
FrontColor(RGB(20
,200
,20
))
EndIf
For
i=
0
To
#Nb
-
1
LineXY(Polygon(i)\x,Polygon(i)\y,Polygon(i+
1
)\x,Polygon(i+
1
)\y)
Next
i
StopDrawing()
EndIf
Until
ev =
#PB_Event_CloseWindow
DataSection
Data
.i 550
,130
Data
.i 700
,400
Data
.i 220
,300
Data
.i 250
,250
Data
.i 550
,130
EndDataSection
L'auteur de ce code a utilisé l'algorithme "Hunt-and-Kill algorithm", vous en trouverez d'autres sur le site indiqué dans le code ci-dessous.
;Maze example by Joakim L. Christiansen
;Feel free to use and abuse!
;
;Extra credits to:
;http://weblog.jamisbuck.org/2011/2/7/maze-generation-algorithm-recap
EnableExplicit
#main
=
0
#main_image
=
0
Global
wantedWidth=
800
, wantedHeight=
600
Global
blockSize=
18
Global
mazeWidth =
Round(wantedWidth/
blockSize,#PB_Round_Up
)
Global
mazeHeight =
Round(wantedHeight/
blockSize,#PB_Round_Up
)
Global
Dim
maze(mazeWidth,mazeHeight)
Global
image, drawDelay =
10
Procedure
.l passageAllowed(fromX,fromY,toX,toY)
Protected
i,u,result
If
toX>
0
And
toX<
mazeWidth And
toY>
0
And
toY<
mazeHeight
result=
#True
If
maze(toX,toY)=
0
result =
#False
EndIf
If
maze(toX,toY-
1
)=
0
And
toY-
1
<>
fromY
result =
#False
EndIf
If
maze(toX,toY+
1
)=
0
And
toY+
1
<>
fromY
result =
#False
EndIf
If
maze(toX-
1
,toY)=
0
And
toX-
1
<>
fromX
result =
#False
EndIf
If
maze(toX+
1
,toY)=
0
And
toX+
1
<>
fromX
result =
#False
EndIf
EndIf
ProcedureReturn
result
EndProcedure
Procedure
.l moveRandomDirection(*
x.long,*
y.long)
Protected
result, NewList
possibleDirection()
ClearList(possibleDirection())
If
passageAllowed(*
x\l,*
y\l, *
x\l,*
y\l-
1
) ;up
AddElement(possibleDirection()): possibleDirection() =
0
EndIf
If
passageAllowed(*
x\l,*
y\l, *
x\l,*
y\l+
1
) ;down
AddElement(possibleDirection()): possibleDirection() =
1
EndIf
If
passageAllowed(*
x\l,*
y\l, *
x\l-
1
,*
y\l) ;left
AddElement(possibleDirection()): possibleDirection() =
2
EndIf
If
passageAllowed(*
x\l,*
y\l, *
x\l+
1
,*
y\l) ;right
AddElement(possibleDirection()): possibleDirection() =
3
EndIf
If
ListSize(possibleDirection()) >
0
SelectElement(possibleDirection(),Random(ListSize(possibleDirection())-
1
))
Select
possibleDirection()
Case
0
: *
y\l-
1
Case
1
: *
y\l+
1
Case
2
: *
x\l-
1
Case
3
: *
x\l+
1
EndSelect
maze(*
x\l,*
y\l) =
0
result =
#True
Else
result =
#False
EndIf
ProcedureReturn
result
EndProcedure
Procedure
drawPassage(x,y)
Protected
round1,round2,round3,round4
If
maze(x,y-
1
)=
1
If
maze(x+
1
,y)=
1
;top right
round1=
#True
EndIf
If
maze(x-
1
,y)=
1
;top left
round2=
#True
EndIf
EndIf
If
maze(x,y+
1
)=
1
If
maze(x+
1
,y)=
1
;bottom right
round3=
#True
EndIf
If
maze(x-
1
,y)=
1
;bottom left
round4=
#True
EndIf
EndIf
RoundBox(x*
blockSize,y*
blockSize,blockSize,blockSize,7
,7
,RGB(180
,180
,180
))
If
Not
round1
Box(x*
blockSize+
blockSize/
2
,y*
blockSize,blockSize/
2
,blockSize/
2
,RGB(180
,180
,180
))
EndIf
If
Not
round2
Box(x*
blockSize,y*
blockSize,blockSize/
2
,blockSize/
2
,RGB(180
,180
,180
))
EndIf
If
Not
round3
Box(x*
blockSize+
blockSize/
2
,y*
blockSize+
blockSize/
2
,blockSize/
2
,blockSize/
2
,RGB(180
,180
,180
))
EndIf
If
Not
round4
Box(x*
blockSize,y*
blockSize+
blockSize/
2
,blockSize/
2
,blockSize/
2
,RGB(180
,180
,180
))
EndIf
EndProcedure
Procedure
drawMaze()
Protected
x,y
If
StartDrawing(ImageOutput(image))
Box(0
,0
,mazeWidth*
blockSize,mazeHeight*
blockSize,#Black
)
For
y=
0
To
mazeHeight
For
x=
0
To
mazeWidth
If
maze(x,y) =
1
Box(x*
blockSize,y*
blockSize,blockSize,blockSize,RGB(0
,0
,0
))
Else
drawPassage(x,y)
EndIf
Next
Next
StopDrawing()
SetGadgetState(#main_image
,ImageID(image))
EndIf
EndProcedure
Procedure
createMaze(d)
Protected
x,y, scanY, scanX, mazeComplete
For
x=
0
To
mazeWidth ;fill with walls
For
y=
0
To
mazeHeight
maze(x,y) =
1
Next
Next
x =
Random(mazeWidth-
2
)+
1
y =
Random(mazeHeight-
2
)+
1
maze(x,y) =
0
;place first brick
Repeat
If
moveRandomDirection(@x,@y) =
#False
;Debug "end reached, finding new position..."
For
scanY=
2
To
mazeHeight-
1
For
scanX=
1
To
mazeWidth-
1
If
maze(scanX,scanY) =
0
If
moveRandomDirection(@scanX,@scanY)
;Debug "moved"
x =
scanX
y =
scanY
Break
2
EndIf
EndIf
Next
If
scanY=
mazeHeight-
1
mazeComplete =
#True
EndIf
Next
EndIf
If
drawDelay
drawMaze()
Delay(drawDelay)
EndIf
Until
mazeComplete
;Debug "Maze building completed!"
drawMaze()
Delay(2000
)
CreateThread(@createMaze(),0
)
EndProcedure
image =
CreateImage(#PB_Any
,(mazeWidth+
1
)*
blockSize,(mazeHeight+
1
)*
blockSize,24
)
OpenWindow(#main
,0
,0
,(mazeWidth+
1
)*
blockSize,(mazeHeight+
1
)*
blockSize,"JLC's Maze Example v1.2"
,#PB_Window_ScreenCentered
|
#PB_Window_SystemMenu
)
ImageGadget(#main_image
,0
,0
,(mazeWidth+
1
)*
blockSize,(mazeHeight+
1
)*
blockSize,ImageID(image))
CreateThread(@createMaze(),0
)
Repeat
Until
WaitWindowEvent()=
#PB_Event_CloseWindow
Ce code date presque de mes débuts avec PureBasic. Si je devais le refaire aujourd'hui il aurait sûrement une autre forme, déjà il n'y aurait plus de variables et de tableaux globaux. Mais il fait ce qu'on lui demande, trouver un chemin :)
; ***********************************************************
; ** Comtois le 16/07/05 - Pathfinding pour Purebasic V0.4 **
; ***********************************************************
; v4.51
; **********************************************************************
; ************************** 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 **
; ** 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
LoadFont(0
, "Arial"
,8
)
; --- 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,diagonale
affPath=
1
AffGrille=
1
; --- dimension du tableau et taille d'une case ---
#max_x
=
48
#max_y
=
48
#max_x1
=
#max_x
+
1
#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 ---
Global
Dim
Map(#max_x
,#max_y
)
Global
Dim
parent.point(#max_x
,#max_y
)
Global
Dim
Tas((#max_x
+
1
)*
(#max_y
+
1
))
Global
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(0
, 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(0
)
Next
x
Next
y
CloseFile(0
)
EndIf
EndProcedure
Procedure
mur()
Couleur=
RGB(100
,100
,255
)
StartDrawing(ScreenOutput())
DrawingFont(FontID(0
))
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(RGB(255
,255
,255
))
Col=
0
lig +
20
DrawText(#taille
*
(#max_x
+
1
),lig,"[F1] Sans/Avec open et closed"
)
lig +
20
DrawText(#taille
*
(#max_x
+
1
),lig,"[F2] Sans/Avec Recherche"
)
lig +
20
DrawText(#taille
*
(#max_x
+
1
),lig,"[F3] Sauve la Map"
)
lig +
20
DrawText(#taille
*
(#max_x
+
1
),lig,"[F4] Charge la Map"
)
lig +
20
DrawText(#taille
*
(#max_x
+
1
),lig,"[F5] Sans/Avec Grille"
)
lig +
20
DrawText(#taille
*
(#max_x
+
1
),lig,"[F6] Efface la Map"
)
lig +
20
DrawText(#taille
*
(#max_x
+
1
),lig,"[F7] Sans/Avec Diagonale"
)
lig +
20
DrawText(#taille
*
(#max_x
+
1
),lig,"[Bouton Gauche] Ajoute un mur"
)
lig +
20
DrawText(#taille
*
(#max_x
+
1
),lig,"[Bouton Droit] Efface un mur"
)
lig +
20
DrawText(#taille
*
(#max_x
+
1
),lig,"[Bouton Gauche] + [Shift] Cible"
)
lig +
20
DrawText(#taille
*
(#max_x
+
1
),lig,"[Bouton Droit] + [Shift] Départ"
)
lig +
20
DrawText(#taille
*
(#max_x
+
1
),lig,"Position : "
+
Str(MouseX()/
#taille
) +
" / "
+
Str(MouseY()/
#taille
))
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
.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_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
; ---- 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
And
(diagonale=
1
Or
a =
x Or
b =
y)
;Calcul un ID unique
TempID =
a +
#max_x1
*
b
If
Map(a,b) =
0
And
Noeud(TempID)\Closed =
0
If
a =
x Or
b =
y Or
Map(a,y)=
0
Or
Map(x,b)=
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 =
17
+
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)\f =
Noeud(TempID)\G +
distance
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_x1
*
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
)
;/ é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
If
KeyboardReleased(#PB_Key_F6
)
EffaceMur()
EndIf
If
KeyboardReleased(#PB_Key_F7
)
diagonale=
1
-
diagonale
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
Pour apprendre le fonctionnement du Min-Max et Alpha-Beta, j'ai suivi ce tutoriel :
Programmation de Jeux 2D: Un morpion en SDL de Jean Christophe Beyler.
Un grand merci à lui, le tutoriel était très clair, et du coup j'ai eu envie de le recoder avec mon langage préféré, c'est à dire avec PureBasic.
Et en guise d'exercice, j'ai conservé le style objet du programme original.
Vous pouvez comparer le résultat avec la fonction 'clic'. Tout d'abord le code original :
void
Moteur::
clic(int
x, int
y)
{
//Si on est dans le menu
if
(dansMenu)
{
menu->
clic(x,y);
}
else
{
if
(jeu->
getFini())
{
jeu->
videJeu();
}
else
jeu->
clic(x,y);
}
}
Et la version PureBasic dans le style objet :
Procedure
MoteurClass_clic(*
This.s_Moteur, x, y)
;Si on est dans le menu
If
*
This\dansMenu
*
This\menu\clic(x,y)
Else
If
*
This\jeu\getFini()
*
This\jeu\videJeu()
Else
*
This\jeu\clic(x,y)
EndIf
EndIf
EndProcedure
Bien que PureBasic soit un langage procédural, il permet tout de même d'utiliser des objets existants (COM) grâce aux interfaces.
Vous trouverez un très bon tutoriel à cette adresse pour coder dans le style objet, il se nomme 'Using OOP in PureBasic'.