connaitre les occurences dans un texte

[blendman]

salut

voici un petit code pour connaitre les occurrences de chaque mots dans un texte (c'est utile pour ce ux qui écrivent, pour voir les répétitions par exemple) :

Code : Tout sélectionner

; trouver les occurrences  d'un même mot dans un texte
; fidn the occurences of a word in a text

texte$ = "salut, comment puis-je vous aider ? Je me demande si je peux vous aider, vous, et moi je vais bien, je suis heureux. "+
         "Et les calamars et les ours dans tout ça ? Je ne sais pas "

Dim word.s(0)
texte$=LCase(texte$) 

For i = 1 To Len(texte$)
  character$ = Mid(texte$,i,1) 
  If character$ <> " "
    word$ + character$
  Else 
    For j  = 0 To countwords
      If word$ = word(j)
        Find =1
        Break
      EndIf      
    Next j
    If Find = 0 
      If word$ <> "!" And  word$ <> "?" 
        countwords+1
        ReDim word(countwords)
        word(countwords) = word$
        Debug word$ +"("+CountString(texte$, word$) +")"
      EndIf
    EndIf
    word$ = ""
    Find = 0
  EndIf
Next i

N'hésitez pas si vous avez un code plus rapide ou mieux

[PAPIPP]

Bonjour Blendman
Je n'ai pas vérifié si ce code et plus ou moins rapide ou que le tien
Il est basé sur les expressions régulières et sur le tri de tableau

Code : Tout sélectionner

texte$="salut, comment puis-je vous aider ? Je me demande si je peux vous aider, vous, et moi je vais bien, je suis heureux. Et les calamars dans tout ça ? Je ne sais pas "
Dim Resultat$(0)
; Resultat = CreateRegularExpression(0, "[-\w\d$!?+%@=]+")
If CreateRegularExpression(0, "[-\w\d$!+%@=]+")
  
  Nb = ExtractRegularExpression(0, texte$, Resultat$())
  SortArray(resultat$(), #PB_Sort_Ascending)
  NBx=1
  For k = 0 To Nb-1
    If k<Nb-1 
      If  resultat$(k+1)=resultat$(k)
        nbx+1
      Else
        Debug Resultat$(k)+" "+Str(nbx)
        NBx=1
      EndIf
    Else
      Debug Resultat$(k)+" "+Str(nbx)
      
    EndIf 
  Next
EndIf

A+

[blendman]

salut

Merci Papip pour ton code, mais j'ai l'impression qu'il beugue sur cette phrase, car j'ai les mots suivants qui sont comptés :
d 2, l 2, m 2, p1, r2, tre 1


la phrase :

Code : Tout sélectionner

texte$="Il lui était difficile, pénible même, de se prononcer sans avoir fait le tour de la question. "+
       "La réalité dans laquelle il venait d'être projeté ne lui était pas familière. "+
       "De même que le monde qui l'entourait sortait de l'ordinaire les personnes qu'il croisait et les réactions qu'ils affichaient "+
       "dénotaient de ce qui composait son quotidien habituellement."



Dim Occurrence$(0)
; Resultat = CreateRegularExpression(0, "[-\w\d$!?+%@=]+")

texte$=LCase(texte$)

If CreateRegularExpression(0, "[-\w\d$!+%@=]+")
 
  Nb = ExtractRegularExpression(0, texte$, Occurrence$())
  SortArray(Occurrence$(), #PB_Sort_Ascending)
  NBx=1
  For k = 0 To Nb-1
    If k<Nb-1
      If  Occurrence$(k+1)=Occurrence$(k)
        nbx+1
      Else
        Debug Occurrence$(k)+" "+Str(nbx)
        NBx=1
      EndIf
    Else
      Debug Occurrence$(k)+" "+Str(nbx)
     
    EndIf
  Next
EndIf

une idée du problème ?

[PAPIPP]

Bonjour Blendman
Oui il faut ajouté toutes les lettres accentuées éèêàùë etc.. pour le français
pour l'allemand il faudrait ajouter les lettres propres à l'allemand etc..
exemple :

; texte$="salut, comment puis-je vous aider ? Je me demande si je peux vous aider, vous, et moi je vais bien, je suis heureux. Et les calamars dans tout ça ? Je ne sais pas "
texte$="Il lui était difficile, pénible même, de se prononcer sans avoir fait le tour de la question. "+
"La réalité dans laquelle il venait d'être projeté ne lui était pas familière. "+
"De même que le monde qui l'entourait sortait de l'ordinaire les personnes qu'il croisait et les réactions qu'ils affichaient "+
"dénotaient de ce qui composait son quotidien habituellement."
Dim Resultat$(0)
; Resultat = CreateRegularExpression(0, "[-\w\d$!?+%@=]+")
If CreateRegularExpression(0, "[-\w\d$!+%@=éèêàùë]+")

Nb = ExtractRegularExpression(0, texte$, Resultat$())
; For k = 0 To Nb-1
; Debug Resultat$(k)
; Next

Debug "******************************************************"
SortArray(resultat$(), #PB_Sort_Ascending)
NBx=1
For k = 0 To Nb-1
If k<Nb-1
If resultat$(k+1)=resultat$(k)
nbx+1
Else
Debug Resultat$(k)+" "+Str(nbx)
NBx=1
EndIf
Else
Debug Resultat$(k)+" "+Str(nbx)

EndIf
Next
EndIf

A+

[Ar-S]

Sympa ce code. Papipp, n'oublie pas de laisser la gestion de la casse si nécessaire, sinon tel quel il compte " il = x et Il = x ". Pour un comptage de mot c'est ballot.

[blendman]

Merci Papipp pour la correction et l'information.
Je n'ai jamais utilisé les regular expressions, mais ça a l'air très sympa ^^.

Pour le tri,je vais essayer d'ajouter le tri descendant en fonction du nombre de répétitions trouvées et je posterai le résultat.
JE l'ai ajouté à mon petit éditeur de texte et c'est bien utile pour trouver les répétitions dans un texte (avec quelques options, comme les mots ignorés ou la taille minimum d'un mot recherché, etc..)

[comtois]

une autre variante, le tri se fait en même temps que le comptage

http://purebasic.developpez.com/sources ... brebinaire

Code : Tout sélectionner

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
texte="Il lui était difficile, pénible même, de se prononcer sans avoir fait le tour de la question. "+
       "La réalité dans laquelle il venait d'être projeté ne lui était pas familière. "+
       "De même que le monde qui l'entourait sortait de l'ordinaire les personnes qu'il croisait et les réactions qu'ils affichaient "+
       "dénotaient de ce qui composait son quotidien habituellement."

  ProcedureReturn texte
EndProcedure

;- affiche les mots de 2 caractères minimum, présents au minimum 1 fois dans le texte.

MessageRequester("Résultat", Affiche(Analyse(Texte(#PB_Compiler_Home+"Compilers/APIFunctionListing.txt"), 2), 1))

[PAPIPP]

Bonjour comtois
Merci comtois pour cet algo utilisant une méthode arborescente.
on peut aussi utiliser une Map en contrôlant les collisions.
Pour revenir aux remarques de Ar-s et de Blendman
Voici un prg qui tient compte des caractères de la langue française. Je ne pense pas avoir oublié un caractère spécial de la langue française.
Il tient aussi compte de la casse (Maj_Min)

Code : Tout sélectionner

; texte$="salut, comment puis-je vous aider ? Je me demande si je peux vous aider, vous, et moi je vais bien, je suis heureux. Et les calamars dans tout ça ? Je ne sais pas "
texte$="Il lui était difficile, pénible même, de se prononcer sans avoir fait le tour de la question. "+
"La réalité dans laquelle il venait d'être projeté ne lui était pas familière. "+
"De même que le monde qui l'entourait sortait de l'ordinaire les personnes qu'il croisait et les réactions qu'ils affichaient "+
"dénotaient de ce qui composait son quotidien habituellement ."
Debug texte$
Dim Resultat$(0)
; Resultat = CreateRegularExpression(0, "[-\w\d$!?+%@=]+")
ALPHA_FR$+"[-\wÀàÂâÆæÇçÉéÈèÊêËëÎîÏïÔôÙùÛûÜüÿ"+Chr(156)+Chr(230)+Chr(159)+"]+"
; If CreateRegularExpression(0, "[-\w\d$!+%@=éèêàùë]+")
 If CreateRegularExpression(0, ALPHA_FR$)
 
  Nb = ExtractRegularExpression(0, texte$, Resultat$())
  SortArray(resultat$(), #PB_Sort_Ascending|#PB_Sort_NoCase ) ;pour ne pas différencier la casse (MAj_Min)

  NBx=1
  For k = 0 To Nb-1
    If k<Nb-1 
      If  LCase(resultat$(k+1))=LCase(resultat$(k)); pour ne pas différencier la casse (MAj_Min)
        nbx+1
      Else
        Debug Resultat$(k)+" "+Str(nbx)
        NBx=1
      EndIf
    Else
      Debug Resultat$(k)+" "+Str(nbx)
      
    EndIf 
  Next
EndIf

A+

[PAPIPP]

Bonjour à tous
On peut aussi utiliser une logique complémentaire
Plutôt que de définir les composants d’un mot
on peut définir tout les éléments qui séparent lest mots (ponctuation parenthèses etc ..)
voici une exemple. J’ai placé dans le texte à analyser des () {} [] !?:

Code : Tout sélectionner

texte$="Il lui était difficile, pénible même, de se prononcer sans avoir fait le tour de la question. "+
"La réalité dans laquelle il venait d'être {projeté ne }lui était [pas familière.] "+
"De même ! que le monde qui! l'entourait (sortait) : de l'ordinaire les ? (personnes qu'il) croisait et les réactions qu'ils affichaient "+
"dénotaient de ce qui composait son quotidien habituellement ."
Debug texte$
Dim Resultat$(0)
If CreateRegularExpression(0, "[^(){};, !:'\.\?\[\]]+")
  Nb = ExtractRegularExpression(0, texte$, Resultat$())
 SortArray(resultat$(), #PB_Sort_Ascending|#PB_Sort_NoCase ) ;pour ne pas différencier la casse (MAj_Min)  
Debug NB
  NBx=1
  For k = 0 To Nb-1
    If k<Nb-1 
      If  LCase(resultat$(k+1))=LCase(resultat$(k))
        nbx+1
      Else
        Debug Resultat$(k)+" "+Str(nbx)
        NBx=1
      EndIf
    Else
      Debug Resultat$(k)+" "+Str(nbx)
      
    EndIf 
  Next
EndIf