IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)

Sources PureBasic

Sources PureBasicConsultez toutes les sources

Nombre d'auteurs : 41, nombre de sources : 88, dernière mise à jour : 13 août 2011 

 
OuvrirSommaireAlgorithmes

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
Image non disponible
 
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) 
EndProcedure
Créé 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 
EndDataSection
Créé 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_CloseWindow
Créé 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 :)

Image non disponible
 
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)

End
Créé 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'.

Créé le 29 mars 2011  par Comtois, Jean Christophe Beyler

Téléchargez le zip

Les sources présentées sur cette page sont libres de droits et vous pouvez les utiliser à votre convenance. Par contre, la page de présentation constitue une œuvre intellectuelle protégée par les droits d'auteur. Copyright © 2008 Developpez Developpez LLC. Tous droits réservés Developpez LLC. Aucune reproduction, même partielle, ne peut être faite de ce site ni de l'ensemble de son contenu : textes, documents et images sans l'autorisation expresse de Developpez LLC. Sinon vous encourez selon la loi jusqu'à trois ans de prison et jusqu'à 300 000 € de dommages et intérêts.