# 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)

Version hors-ligne
Compteur de mots dans un texte avec un arbre binaire

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
Construction d'un quadtree
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
Formatage d'un nombre (StrNum)

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
Recherche simultanée du maximum et du minimum d'un tableau

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
Déterminer si un point se trouve dans un polygone avec la méthode 'Winding number'

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
Construction d'un labyrinthe en 2D

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
Exemple de pathfinding A*

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)

    End

Créé le 8 mars 2011 par Comtois
Reprise d'un tutoriel : Un morpion avec intelligence artificielle (Alpha-Beta)

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

Version hors-ligne

Les sources présentés sur cette page sont libres de droits et vous pouvez les utiliser à votre convenance. Par contre cette page de présentation de ces sources constitue une œuvre intellectuelle protégée par les droits d'auteurs. Copyright ©2008 Developpez LLC. Tous droits réservés Developpez LLC. Aucune reproduction, même partielle, ne peut être faite de ce site et 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.