PureBasic

Vous trouverez les fichiers nécessaires pour le dico à cette adresse
http://www.bellamyjc.net/download/dicofr.zip
ou alors , remplacez le fichier par celui de votre choix.

Le code original et les explications se trouvent ici :
http://www.chambily.com/recursivite/ Arbres VII-4

N'hésitez pas à m'indiquer les améliorations possibles .

Code : Tout sélectionner

;Comtois 23/01/05
;Codage d'un dictionnaire

Declare CreateNoeud()

Structure Noeud
  lettre.s ; lettre contenue dans ce noeud de l'arbre
  entier.b ; flag indiquant si le mot est entier
  *Fils.Noeud[26] 
EndStructure 
;initialise l'arbre
Global *Tete.Noeud
*Tete=CreateNoeud()

;-Procedures
Procedure CreateNoeud()
  *Noeud.Noeud=AllocateMemory(SizeOf(Noeud))
  If *Noeud
    For c=0 To 25 
      *Noeud\Fils[c]=#Null 
    Next c    
    *Noeud\lettre=""
    *Noeud\entier=#False 
  Else
    MessageRequester("Erreur","Impossible d'allouer de la mémoire !",0)
    End
  EndIf
  ProcedureReturn *Noeud
EndProcedure
Procedure rajouter_mot(*courant.Noeud,LeMot.s)
  If LeMot="" 
    *courant\entier=#True
    ProcedureReturn 
  EndIf
  car.s=Left(LeMot,1)
  lettre=Asc(car)-'A'
  If *courant\Fils[lettre]<>#Null  ; si la lettre existe déjà
    *courant=*courant\Fils[lettre] ; alors On se positionne sur la lettre suivante
  Else ; sinon il faut créer cette lettre dans l'arbre
    *courant\Fils[lettre]=CreateNoeud()
    *courant=*courant\Fils[lettre]
    *courant\lettre=car
    *courant\entier=#False 
  EndIf
  LeMot=Mid(LeMot, 2, Len(LeMot)-1); on efface la lettre du mot puisqu'elle est déjà dans l'arbre
  rajouter_mot(*courant,LeMot); et on rajoute le reste
EndProcedure
Procedure Affiche(*courant.Noeud,s.s);
  If *courant\entier : Debug s : EndIf
  For i= 0 To 25 
    If *courant\Fils[i]<>#Null 
      *aux.Noeud=*courant
      *courant=*courant\Fils[i]
      Affiche(*courant,s+Chr(i+'A'))
      *courant=*aux
    EndIf
  Next i  
EndProcedure
Procedure trouve(*courant.Noeud,LeMot.s,OK.l)
  If LeMot=""  And OK
    trouve=#True
  Else
    car.s=Left(LeMot,1)
    lettre=Asc(car)-'A'
    LeMot=Mid(LeMot,2,Len(LeMot)-1)
    If lettre<0 Or lettre>25 Or *courant\Fils[lettre]=#Null 
      trouve=#False
    Else
      *courant=*courant\Fils[lettre]
      trouve=trouve(*courant,LeMot,*courant\entier)
    EndIf
  EndIf
  ProcedureReturn trouve
EndProcedure
Procedure.s EpureMot(Mot.s)
  Mot=UCase(Trim(Mot))
  MotAux.s=""
  car.s=""
  For i=1 To Len(Mot)
    car=Mid(Mot,i,1)
    If car="Â" Or car="Ä" Or car="À" Or car="Á"
      car ="A"
    ElseIf car="Ç"
      car="C"
    ElseIf car="È" Or car="É" Or car="Ê" Or car="Ë" Or car="Œ"
      car="E"
    ElseIf car="Î" Or car="Ï" Or car="Ì"
      car="I"
    ElseIf car="Ô" Or car="Ö"
      car="O"
    ElseIf car="Ù" Or car="Û" Or car="Ü" Or car="Ú"
      car="U"
    EndIf
    MotAux=MotAux+car
  Next i
  ; suppression des blancs et des tirets et autres trucs qui n'existent pas dans le jeu
  Mot=MotAux : MotAux=""
  For i=1 To Len(Mot)
    car=Mid(Mot,i,1)
    If (car <> " ") And (car <> "-") And (car <> "'")
      MotAux=MotAux+car
    EndIf
  Next i
  ProcedureReturn MotAux  
EndProcedure
Procedure charger(Fichier$)
  If OpenFile(0,Fichier$)
    While Eof(0)=0
      Mot.s=EpureMot(ReadString())
      rajouter_mot(*Tete,Mot) ; et on rajoute le mot
    Wend
    CloseFile(0)
  Else
    MessageRequester("Erreur","Impossible d'ouvrir le fichier " + Fichier$,0)
  EndIf
EndProcedure
;-Charge le dico en mémoire
;Fichier$="dicofr\dicofr.txt" << C'est le dico une fois épuré , ça m'évite de l'épurer à chaque chargement
For i=0 To 25
  Fichier$="dicofr\"+Chr(i+'A')+".txt"
  charger(Fichier$)
Next i 
charger(Fichier$)

;-Valide cette ligne si tu veux afficher le résultat 
;Affiche(*Tete,"")
  
;-et maintenant quelques tests
Repeat
  Test$=EpureMot(InputRequester("Test Dictionnaire","Indiquez un mot ",""))
  If Test$<>""
    If trouve(*Tete,Test$,0)
      Rep$="Le mot " + Test$ + " se trouve dans le dictionnaire"
    Else
      Rep$="Le mot " + Test$ + " ne se trouve pas dans le dictionnaire"
    EndIf
    MessageRequester("Test Dictionnaire",Rep$,0)
  EndIf
Until Test$=""

Interressant

bon c'est brut mais j'ai ajouté mon anagramme dedans
du coup ça recherche les anagrammes !!

a commencer par lui meme , mais c'est a ameliorer !

Code : Tout sélectionner

;Comtois 22/01/05
;Codage d'un dictionnaire

;Dobro ajout de recherche d'annagrammes

Structure Noeud
  lettre.s ; lettre contenue dans ce noeud de l'arbre
  entier.b ; flag indiquant si le mot est entier
  *Fils.Noeud[26]
EndStructure

Global *Tete.Noeud
;initialise l'arbre
*Tete = AllocateMemory(SizeOf(Noeud))
If *Tete
  For c=0 To 25
    *Tete\Fils[c]=#Null
  Next c   
  *Tete\lettre=""
  *Tete\entier=#False
Else
  MessageRequester("Erreur","Impossible d'allouer de la mémoire !",0)
  End
EndIf

Procedure rajouter_mot(*courant.Noeud,LeMot.s)
  If LeMot=""
    *courant\entier=#True
    ProcedureReturn
  EndIf
  car.s=Left(LeMot,1)
  lettre=Asc(car)-'A'
  If *courant\Fils[lettre]<>#Null  ; si la lettre existe déjà
    *courant=*courant\Fils[lettre] ; alors On se positionne sur la lettre suivante
  Else ; sinon il faut créer cette lettre dans l'arbre
    *courant\Fils[lettre]=AllocateMemory(SizeOf(Noeud));
    ;initialise le noeud
    If *courant\Fils[lettre]
      *courant=*courant\Fils[lettre]
      For c=0 To 25
        *courant\Fils[c]=#Null
      Next c   
      *courant\lettre=car
      *courant\entier=#False
    Else
      MessageRequester("Erreur","Impossible d'allouer de la mémoire !",0)
      End
    EndIf
  EndIf
  LeMot=Mid(LeMot, 2, Len(LeMot)-1); on efface la lettre du mot puisqu'elle est déjà dans l'arbre
  rajouter_mot(*courant,LeMot); et on rajoute le reste
EndProcedure

Procedure Affiche(*courant.Noeud,s.s);
  If *courant\entier : Debug s : EndIf
  For i= 0 To 25
    If *courant\Fils[i]<>#Null
      *aux.Noeud=*courant
      *courant=*courant\Fils[i]
      Affiche(*courant,s+Chr(i+'A'))
      *courant=*aux
    EndIf
  Next i 
EndProcedure

Procedure trouve(*courant.Noeud,LeMot.s,OK.l)
  If LeMot=""  And OK
    trouve=#True
  Else
    car.s=Left(LeMot,1)
    lettre=Asc(car)-'A'
    LeMot=Mid(LeMot,2,Len(LeMot)-1)
    If lettre<0 Or lettre>25 Or *courant\Fils[lettre]=#Null
      trouve=#False
    Else
      *courant=*courant\Fils[lettre]
      If *courant\entier
        OK=#True
      Else
        OK=#False
      EndIf 
      trouve=trouve(*courant,LeMot,OK)
    EndIf
  EndIf
  ProcedureReturn trouve
EndProcedure
Procedure charger(Fichier$)
  If OpenFile(0,Fichier$)
    While Eof(0)=0
      Mot.s=UCase(Trim(ReadString()))
      MotAux.s=""
      car.s=""
      For i=1 To Len(Mot)
        car=Mid(Mot,i,1)
        If car="Â" Or car="Ä" Or car="À" Or car="Á"
          car ="A"
        ElseIf car="Ç"
          car="C"
        ElseIf car="È" Or car="É" Or car="Ê" Or car="Ë" Or car="Œ"
          car="E"
        ElseIf car="Î" Or car="Ï" Or car="Ì"
          car="I"
        ElseIf car="Ô" Or car="Ö"
          car="O"
        ElseIf car="Ù" Or car="Û" Or car="Ü" Or car="Ú"
          car="U"
        EndIf
        MotAux=MotAux+car
      Next i
      ; suppression des blancs et des tirets et autres trucs qui n'existent pas dans le jeu
      Mot=MotAux : MotAux=""
      For i=1 To Len(Mot)
        car=Mid(Mot,i,1)
        If (car <> " ") And (car <> "-") And (car <> "'")
          MotAux=MotAux+car
        EndIf
      Next i
      rajouter_mot(*Tete,MotAux) ; et on rajoute le mot
    Wend
    CloseFile(0)
  Else
    MessageRequester("Erreur","Impossible d'ouvrir le fichier " + Fichier$,0)
  EndIf
EndProcedure

;/Charge le dico en mémoire
For i=0 To 25
  Fichier$="dicofr\"+Chr(i+'A')+".txt"
  charger(Fichier$)
Next i
 
 ;/Valide cette ligne si tu veux afficher le résultat
Affiche(*Tete,"")
 
 ;/et maintenant quelques tests
Repeat
  Test$=UCase(Trim(InputRequester("cherche anagram","Indiquez un mot ","")))
  If Test$<>""
    m$=Test$
    Gosub Dobro_anagram
    Rep$="Le mot " + Test$ + " n'a pas d'anagramme" 
    MessageRequester("Test Dictionnaire",Rep$,0)
    
  EndIf
    
  Until Test$="" 
  
 
  ; parer
  ; raper
  
  ; *****************************************************************
  
  Dobro_anagram:
  
  n= Len(m$)
  Dim mo$(n)
  Dim p(n)
  mo$(n)=m$
  Z=n
  rt:
  p(Z)=1
  dt:
  mo$(Z-1)=Right(mo$(Z),Z-1)
  Z=Z-1
  If Z>1
    Goto rt
  EndIf
  m$=""
  For w=1 To n
    m$=Left(mo$(w),1)+m$
  Next w
  CallDebugger
  Debug m$
  If trouve(*Tete,m$,0)
    Rep$="Le mot " + Test$ + " a comme anagramme: "+ m$ 
     MessageRequester("Test Dictionnaire",Rep$,0)
  EndIf
  

gt:
mo$(Z+1)=mo$(Z)+Left(mo$(Z+1),1)
Z=Z+1
p(Z)=p(Z)+1
If p(Z)<=Z
  Goto dt
EndIf
If Z<n
  Goto gt
EndIf
Return

Merci comtois

Très productif aujourd'hui