Sources PureBasic
Sources PureBasicConsultez toutes les sources
Nombre d'auteurs : 41, nombre de sources : 88, dernière mise à jour : 13 août 2011
Sommaire→Algorithmes- 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.
Sélectionnez
;- 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))Créé le 20 février 2008 par Flype, Comtois
Sélectionnez
;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)Mis à jour le 21 décembre 2008 par Comtois
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...
Sélectionnez
; 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 :
Sélectionnez
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)Créé le 9 mars 2008 par Flype
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
Sélectionnez
; 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)
EndProcedureCréé le 6 février 2010 par Comtois
Adaption pour PureBasic de l'algorithme du Winding number que vous trouverez ici avec les explications en anglais.
Sélectionnez
; 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
EndDataSectionCréé le 3 décembre 2010 par Comtois
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.
Sélectionnez
;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_CloseWindowCréé le 10 février 2011 par Joakim Christiansen
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 :)
Sélectionnez
; ***********************************************************
; ** 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)
EndCréé le 8 mars 2011 par Comtois
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 :
Sélectionnez
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 :
Sélectionnez
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'.