Le Mot le plus long

Programmation d'applications complexes
PAPIPP
Messages : 534
Inscription : sam. 23/févr./2008 17:58

Le Mot le plus long

Message par PAPIPP »

Bonjour à tous

Je pense que tout un chacun connait ce jeu de l’émission des chiffres et des lettres.
Je vais ici rappeler les règles de ce jeu.

On tire au hasard 10 lettres des 26 possibilités de l’alphabet composées de voyelles et de consonnes. Toutes ces lettres seront en majuscule.
Il n’y a aucune lettre accentuée tirée, par contre les mots acceptés peuvent en contenir.

On demande aux candidats de trouver le mot le plus long possible avec ces 10 lettres.


Fonctionnement du prg.

Le principal problème est de trouver un dictionnaire le plus complet possible.

J’ai trouvé 2 dictionnaires qui peuvent être chargés automatiquement par le prg.

Par défaut l’un de ces deux dictionnaires sera chargé automatiquement au départ.
Ceci demande quelques secondes pour l’initialisation.

Pour générer les 10 lettres vous avez 3 Options.

1) vous pouvez taper vous-même ces lettres dans le cadre chargé de les recevoir.
Si vous tapez ces lettres en minuscule le mot sera inversé.
par exemple vous tapez le mot oiseau en minuscule il sera inversé dans le cadre et apparaitra UAESIO.
Par contre si vous tapez ce même mot en majuscule les lettres seront placées dans le bon ordre
Vous pouvez placer le curseur entre les lettres et soit les supprimer avec le touche <---
soit en ajouter jusqu’au maximum autorisé.

2) Vous pouvez choisir au hasard les voyelles ou les consonnes en tapant sur la touche ‘voyelle’ ou ‘consonne’ .
(une seule lettre par touche cliquée)

3) Vous pouvez générer les 10 lettres en cliquant sur la touche ‘change tout’.

Vous pouvez effacer toute cette zone en cliquant sur la touche ‘Efface’.

Vous pouvez limiter le nombre de lettres générées en limitant ce nombre entre 4 et 10 en choisissant le nombre de caractères à tirer sous Nb Car Max.
La valeur 10 est prise par défaut.

Si vous êtes maintenant satisfait du tirage vous pouvez afficher tous les mots trouvés par ordre inverse le leur longueur en cliquant sur ‘solution’.

Vous pouvez à nouveau tirer les lettres comme il est précisé ci-dessus, Modifier le Nb de caractères max et rechercher une autre solution.

Utilisation des menu ‘Choix_dico’ et ‘Fichier’.

1) Avec Choix_dico vous pouvez choisir un dictionnaire de votre choix.
Soit dans le répertoire ou est situé le prg.
Dans ce cadre si vous désirez modifier un fichier existant, faites-en une copie avant modification.
Vous pouvez créer votre propre dictionnaire en *.TXT et le placer dans ce même répertoire.

Soit en chargeant un dictionnaire à partir du Web.
Il y a 2 options possibles :
Web ASCII est chargé au départ du PRG mais vous pouvez le recharger.
Web UTF8 si vous choisissez cette option le Dico en UTF8 sera chargé et converti en ASCII.
Dans cette option le prg réinitialise tous les éléments qu’il aura besoin ce qui demande quelques secondes d’attente.

2) Menu ‘Fichier’.
Tous les fichiers Choisis dans Choix_Dico seront sauvegardés sous le suffixe *.TXTSav.
Donc si un fichier *.txt disparait par inadvertance il peut être restauré dans cette option.
dans la mesure où la sauvegarde existe.

Vous pouvez aussi supprimer des fichiers *.TXT.

Code : Tout sélectionner

Enumeration FormWindow
  #Window_1
EndEnumeration

Enumeration FormGadget
  #TITRE
  #NB_CAR
  #VOYELLE
  #EDITION_CAR
  #Text_1
  #CONSONNE
  #CHANGE_TOUT
  #SOLUTION
  #SOLUT1
  #NomFic
  #Efface
  #NBFic
EndEnumeration

Enumeration FormMenu
  #FchierRep
  #WEB_1
  #Web_2
  #Quiter
  #EFFACER
  #RESTAURER
EndEnumeration

Enumeration FormFont
  #Font_Window_1_0
  #Font_Window_1_1
  #Font_Window_1_2
EndEnumeration

LoadFont(#Font_Window_1_0,"Arial", 28, #PB_Font_Bold)
LoadFont(#Font_Window_1_1,"Courier New", 40, #PB_Font_Bold)
LoadFont(#Font_Window_1_2,"Courier New", 9)


Procedure OpenWindow_1(x = 0, y = 0, width = 730, height = 800)
  OpenWindow(#Window_1, x, y, width, height, "", #PB_Window_SystemMenu | #PB_Window_MinimizeGadget)
  CreateMenu(0, WindowID(#Window_1))
  MenuTitle("Choix_Dico")
  MenuItem(#FchierRep, "Fichier TXT en répertoire")
  MenuItem(#WEB_1, "Web ASCII=>LEXIQUE*.TXT")
  MenuItem(#Web_2, "Web UTF8=>LISTE*.TXT")
  MenuItem(#Quiter, "Quiter")
  MenuTitle("Fichier")
  MenuItem(#EFFACER, "Effacer *.TXT")
  MenuItem(#RESTAURER, "RESTAURer *.TXT")
  TextGadget(#TITRE, 40, 10, 650, 50, "L E   M O T    L E    P L U S    L O N G", #PB_Text_Center)
  SetGadgetFont(#TITRE, FontID(#Font_Window_1_0))
  ComboBoxGadget(#NB_CAR, 40, 100, 50, 20, #PB_ComboBox_Editable)
  ButtonGadget(#VOYELLE, 190, 190, 80, 30, "Voyelle")
  EditorGadget(#EDITION_CAR, 185, 60, 345, 70, #PB_Editor_WordWrap)
  SetGadgetFont(#EDITION_CAR, FontID(#Font_Window_1_1))
  TextGadget(#Text_1, 30, 80, 70, 20, "  Nb Car Max")
  ButtonGadget(#CONSONNE, 450, 190, 80, 30, "Consonne")
  ButtonGadget(#CHANGE_TOUT, 300, 190, 130, 30, "Change tout")
  ButtonGadget(#SOLUTION, 300, 230, 130, 30, "SOLUTION")
  EditorGadget(#SOLUT1, 10, 270, 700, 490)
  SetGadgetFont(#SOLUT1, FontID(#Font_Window_1_2))
  TextGadget(#NomFic, 50, 150, 620, 20, "Nom du fichier utilisé :", #PB_Text_Center)
  ButtonGadget(#Efface, 570, 90, 80, 30, "Efface")
  TextGadget(#NBFic, 20, 240, 210, 20, "")
EndProcedure




structure mot
  StructureUnion
    NOMC.s{26}
    Lettre.s{1}[26]
  EndStructureUnion
endstructure 
Structure colonne 
  numelem.a[11]
  car.mot
EndStructure
Structure tabres 
  ligne.colonne[255]
EndStructure  

Global FICHIER$
global Path_Map$
global NewMap moti.string()
global NewMap mot4.string()
global NewMap mot5.string()
global NewMap mot6.string()
global NewMap mot7.string()
global NewMap mot8.string()
global NewMap mot9.string()
global NewMap motx.string()
global NewMap mots.string()
global newmap motrouve.string()
global Aphabet.mot
ProcedureDLL.q _nbcycl()
  !RDTSC
  ProcedureReturn
EndProcedure
macro stock(_n)
  if len(mot$)<12
    If FindMapElement(mot#_n(),nomt\NOMC)
    if FindString(mot#_n(nomt\NOMC)\s,mot$)
     else  
      mot#_n(nomt\NOMC)\s=mot#_n()\s+"/"+mot$
    endif  
  Else
    mot#_n(nomt\NOMC)\s=nomt\NOMC+"/"+mot$
  endif
endif
endmacro 

Macro _q_t
  "
EndMacro
macro TestMap(__n)
  a$=_q_t#__n#_q_t
  ficMap$=Path_Map$+"Mot_"+a$+".txt"
  if filesize(FicMap$)<0
    resulta *0
  Else
    resulta *1
  endif 
endmacro

Macro Ecrire(__n)
  a$=_q_t#__n#_q_t
  
  if filesize(Path_Map$)=-1
    if CreateDirectory(Path_Map$) 
    Else
      MessageRequester("Information","Impossible de créer le répertoire  Mapx.txt!"+#LF$+ Path_Map$)
    endif  
  endif
  
  ficMap$=Path_Map$+"Mot_"+a$+".txt"
  if filesize(FicMap$)=>0
    RenameFile(ficMap$,ficMap$+"sav")
  endif  
  If CreateFile(__n, ficMap$)         ; crée un nouveau fichier texte ou recrée une fichier texte vide s'il existe déjà ...
    ResetMap(mot#__n())      
    While NextMapElement(mot#__n()) 
      WriteStringN(__n, mot#__n()\s)
    Wend
    CloseFile(__n)                       ; ferme le fichier précédemment ouvert et enregistre les données
  Else
    MessageRequester("Information","Impossible de créer le fichier Mapx.txt!"+#LF$+ ficMap$)
  EndIf
endmacro 

procedure creation_Fichier(fichierm$)
nom_fichier$=GetCurrentDirectory()+"_Nom_Fichier_"
if  createfile(5,nom_fichier$)
  WriteString(5,Fichierm$+chr(10),#PB_Ascii )
CloseFile(5)
else 
 MessageRequester("Information","Impossible de creer le fichier ASCII"+#LF$+ FichierM$)
endif
endprocedure
procedure Lecture_Nom_Fichier_()
  nom_fichier$=GetCurrentDirectory()+"_Nom_Fichier_"
  if filesize(nom_fichier$)>0
  if  readfile(5,nom_fichier$)  ;;; fichier avec un seul enregistrement donc pas de boucle
    FICHIER$=ReadString(5)     
    CloseFile(5)               ; Ferme le fichier précédemment créé ou ouvert
  Else
    MessageRequester("Information","Impossible d'ouvrir le fichier!=_Nom_Fichier_")
  EndIf
Else
  fichier$=""
  endif
endprocedure


;;;;****************** initialisation générale pour les cas ou les fichiers ne seraient pas créés ********
procedure INIT_GEN(val);; val pour une éventuelle  utilisation avec thread 
  EnableExplicit 
  protected result, resulta,resultb,resultc, mot$,i,lmot,ii,a$,x,s,init_dic$,FichierParDefaut$,Filtre$
  protected filtre,prgpb$,Compilateur,Sortie$,code_ret,prgexec$,exec_dico
  protected Path_Fic$,file$,files$,ficMap$,jjj
  
  define Nomt.mot
  define Nom.mot
  dim tabnom.s(25)
  lecture_Nom_fichier_()
  ClearMap(motrouve())
  Clearmap( moti.string())
  Clearmap( mot4.string())
  Clearmap( mot5.string())
  Clearmap( mot6.string())
  Clearmap( mot7.string())
  Clearmap( mot8.string())
  Clearmap( mot9.string())
  Clearmap( motx.string())
  Clearmap( mots.string())
  if FileSize(Fichier$) <0
    if fichier$=""
      Fichier$ = getCurrentDirectory()+"LEXIQUE_MOTS_FR2.TXT" 
      creation_fichier(fichier$)
    endif
    InitNetwork()
    result=ReceiveHTTPFile("http://www.lexique.org/listes/liste_mots.txt",fichier$)
  Else
    if CopyFile(fichier$, fichier$+"sav") 
      result=1
    Else
      result=0
      MessageRequester("Information","Impossible de créer le fichier!"+#LF$+ fichier$+"sav")
    endif
  endif 
  Path_Fic$=GetPathPart(FICHIER$)
  if path_fic$=""
    files$=GetFilePart(FICHIER$,#PB_FileSystem_NoExtension)
  else
    files$=GetFilePart(FICHIER$,#PB_FileSystem_NoExtension)+"\"
  endif 
  file$=GetFilePart(FICHIER$)
  path_map$=Path_Fic$+files$
  SetGadgetText(#NomFic,"FICHIER UTILISE : "+fichier$)
  ;;; Test de la présence des fichiers MAP*.txt
  resulta=1
  for jjj=1 to 10
    select jjj
      case 1 to 3
        TestMap(i)
      case 4 
        testMap(4)
      case 5
        testMap(5)
      case 6 
        testMap(6)
      case 7
        testMap(7)
      case 8
        testMap(8)
      case 9
        testMap(9)
      case 10
        TestMAp(x)
      Default
        TestMap(s)
    endselect      
  next  
  if result and not resulta
    If ReadFile(0, fichier$, #PB_Ascii  )   ; Si le fichier peut être lu , on continue...
      While Eof(0) = 0                      ; Boucle tant que la fin du fichier n'est pas atteinte. (Eof = 'End Of File') 
        MOT$=StringField(ReadString(0),1,chr(09))
        if FindString(Mot$," ") =0 ;;;or FindString(Mot$,chr(9))=0
          nom\NOMC=Ucase(MOT$)
          for i=0 to len(nom\NOMC)-1
            select peeka(ascii(nom\lettre[i]))
              case 32 to 63
                nom\lettre[i]=""
              case 192 to 197
                nom\lettre[i]="A"
              case 199
                nom\lettre[i]="C"
              case 200 to 203
                nom\lettre[i]="E"
              case 204 to 207
                nom\lettre[i]="I"
              case 210 to 214
                nom\lettre[i]="O"
              case 217 to 220
                nom\lettre[i]="U"
              case 255,221,253
                nom\lettre[i]="Y"
            endselect    
            tabnom(i)=nom\Lettre[i]
          next
          SortArray(tabnom(),#PB_Sort_Ascending,0,len(nom\NOMC)-1 )
          nomt\NOMC=""
          for i=0 to len(nom\NOMC)-1
            nomt\Lettre[i]=tabnom(i)
          next
          lmot=len(mot$)
          select lmot
            case 1 to 3
              stock(i)
            case 4
              stock(4)
            case 5
              stock(5)  
            case 6
              stock(6)          
            case 7
              stock(7)
            case 8
              stock(8)
            case 9
              stock(9)
            case 10 
              stock(x)
            case 11 to 22
              stock(s)
          endselect
        Else
        endif
        
      Wend
      CloseFile(0); Ferme le fichier précédemment ouvert
      ;;;; ********************  remettre l'initialisation dictionnaire à 0 
      ;    SetGadgetState(#Init_Dic,#PB_CheckBox_Unchecked)
      ;    flag_dic=0
      ;;;;********************* sauve les map sur des fichiers **************************
      for ii=3 to 11
        select ii
          case 3
            i=3
            ecrire (i)
          case 4
            ecrire(4)
          case 5
            ecrire(5)
          case 6
            ecrire(6)
          case 7
            ecrire(7)
          case 8
            ecrire(8)
          case 9
            ecrire(9)
          case 10
            x=ii
            ecrire(x)
          case 11 to 22
            s=ii
            ecrire(s)
        endselect    
      Next
    Else
      MessageRequester("Information","Impossible d'ouvrir le fichier!")
    EndIf
  endif
  DisableExplicit
  creation_Fichier(Fichier$)
endprocedure
 ;******************  Moteur du mot le plus long ************************* 
 
  Macro Lire(__n)
  a$=_q_t#__n#_q_t
  ficMap$=Path_Map$+"Mot_"+a$+".txt"
  If ReadFile(__n, ficMap$,#PB_File_SharedRead )   ; Si le fichier peut être lu , on continue...
      While Eof(__n) = 0                 
        MOT$=ReadString(__n)
        pos=__n
        if __n<4 or __n>9
          pos = FindString(mot$, "/")-1
        endif
          clef$=left(mot$,pos)
        mot#__n(clef$)\s=mot$
    Wend
    CloseFile(__n)                       ; ferme le fichier précédemment ouvert et enregistre les données
  Else
    MessageRequester("Information","Impossible de Lire le fichier!"+#LF$+ FicMap$)
  EndIf
endmacro  
procedure AlphabetVoyelleConsonne(val);; val pour une éventuelle  utilisation avec thread
  EnableExplicit
protected VOYELLE.mot,CONSONNE.mot,i,c$
for i=0 to 25
  c$= chr(65+i)
  select c$
    case "A","E","I","O","U","Y"
      voyelle\NOMC+c$
    Default
      consonne\NOMC+c$
  endselect
next  
Aphabet.mot\NOMC=voyelle\NOMC+consonne\NOMC
DisableExplicit
endprocedure
;;;***************************************************
procedure chargementMap(val);; val pour une éventuelle  utilisation avec thread
  EnableExplicit
  protected ii,i,x,s,a$,fichier$,mot$,pos,clef$,FicMap$
  AlphabetVoyelleConsonne(0)
  for ii=3 to 11
        select ii
          case 3
            i=3
            Lire (i)
          case 4
            Lire(4)
          case 5
            Lire(5)
          case 6
            Lire(6)
          case 7
            Lire(7)
          case 8
            Lire(8)
          case 9
            Lire(9)
          case 10
            x=ii
            Lire(x)
          case 11 to 22
            s=ii
            Lire(s)
        endselect    
      Next
   DisableExplicit
endprocedure  


;************************ les deux Procédure de degroupement **********************************
EnableExplicit
Declare comb_exp0(N,gr,ind)
Procedure Comb_exp(N,GR,chaine$)
  EnableExplicit
  Global clef.mot\NOMC=chaine$
  Global  RES.tabres
  define res0.tabres
  copymemory(res0,res,SizeOf(tabres))
  res\ligne[0]\numelem[0]=1
  Global Dim tab(N)
  comb_exp0(N,Gr,1);
  DisableExplicit
EndProcedure
Procedure comb_exp0(N,gr,ind);;;,Array tab(1))
  EnableExplicit
  protected i,j,lig
  global GP0
  If ind=1
    gp0=gr
  EndIf 
  If gr<>0
    For i=tab(ind-1)+1 To N
      tab(ind)=i
      comb_exp0(N,gr-1,ind+1)
    Next 
  Else
    lig=res\ligne[0]\numelem[0]
    For j=1 To GP0
      res\ligne[lig]\car\Lettre[j-1] = clef\Lettre[tab(j)-1]
   Next
    res\ligne[0]\numelem[0]+1
  EndIf
  DisableExplicit
EndProcedure
DisableExplicit
;;;******************** Procédure de tri par lettre ***********************************
procedure.s trilettre(entree$)
  EnableExplicit
  protected entree.mot,i,sortiet.mot
  Entree.mot\NOMC=entree$
  dim tabnom.s(25)

for i=0 to len(Entree\NOMC)-1
  tabnom(i)=Entree\Lettre[i]
next

SortArray(tabnom(),#PB_Sort_Ascending,0,len(Entree\NOMC)-1 )

define Sortiet.mot\NOMC=""
for i=0 to len(Entree\NOMC)-1
  Sortiet\Lettre[i]=tabnom(i)
next
ProcedureReturn Sortiet\NOMC 
DisableExplicit
endprocedure
macro edite(__n)
  sort$=""
  a$=_q_t#__n#_q_t
  ;    fichier$="Mot_"+a$+".txt"
  b$=a$
  select a$
    case "x"
      nbcar=10
      b$=">10"    
    case "i"
      nbcar=3
      b$="<4"
    case "s"
      nbcar= 11
      b$=">10"
    Default
      nbcar=val(a$)
  endselect    
  if nbli=1
    titre$="Mot(s) de " +b$+ " lettres="+chr(10)
    mot_de_x_lettre$=""
    lmin=len(mot_de_x_lettre$)
  endif  
  ;         res$=mot4(res\ligne[nbli]\car\NOMC)\s
  res$=mot#__n (res\ligne[nbli]\car\NOMC)\s
  if res$<>"" and motrouve(res$)\s=""
    mot_de_x_lettre$ + right(res$,len(res$)-nbcar);+"/"
                                                  ;     if len(mot_de_x_lettre$)%100>90
                                                  ;       mot_de_x_lettre$+chr(10)
                                                  ;     endif  
    lmot=len(mot_de_x_lettre$)
    motrouve(res$)\s=res$
  endif 
  if nbli=nblign and lmot>lmin
    sort$=mot_de_x_lettre$
    lsort=len(sort$)
    nbslash = CountString(sort$, "/")
    ;     nbcount=96/(nbcar+1)
    nbcount=96/(nbcar+1)
    nbocc=nbslash/nbcount
    for o=1 to nbocc
      pos=1+((nbcar+1)*nbcount*o)
      ;     ReplaceString(bbb$,"/",chr(10), #PB_String_InPlace,pos,1)
      ReplaceString(sort$,"/",chr(10), #PB_String_InPlace,pos,1)
    next
    d$=ReplaceString(sort$,chr(10),chr(10)+"/")
    nbmot=countstring(d$,"/")
    nbmottotal+ nbmot
    ltitre=len(str(nbmot)+" "+titre$)
    sort$=str(nbmot)+" "+titre$+d$
    
    if len(sort$)>ltitre+3
      setgadgettext(#SOLUT1,getgadgettext(#SOLUT1)+sort$+chr(10)+chr(10))
    endif  
  endif  
endmacro 
;;;;************ simulation du tirage des letrres ****************
procedure TIRAGEALEA()
  EnableExplicit
  global cartret.mot\NOMC=""
  global cartire.mot\NOMC=""
  
protected nbvoyt=0, nb_atirer, t,rnd
nb_atirer=val(GetGadgetText(#NB_CAR))
for t=1 to nb_atirer
  rnd=random(len(Aphabet\NOMC)-1,0)
  if rnd<6
    nbvoyt+1
  endif  
  if t=nb_atirer and nbvoyt=0
    cartire.mot\NOMC+Aphabet\Lettre[random(5,0)]
    nbvoyt+1
 else
   cartire.mot\NOMC+Aphabet\Lettre[rnd]
  endif 
Next
SetGadgetText(#EDITION_CAR,cartire\NOMC)
DisableExplicit
endprocedure

procedure edition_car()
  EnableExplicit
  static fin.q,deb.q,fin2.q
  protected carm.mot\NOMC= getGadgetText(#EDITION_CAR), car.mot,i,ascii,lcar
  car.mot\NOMC=ucase(carm\NOMC)
  lcar=len(car.mot\NOMC)
  if lcar > val(getgadgettext(#NB_CAR))
    setgadgettext(#EDITION_CAR,left(getgadgettext(#EDITION_CAR),val(getgadgettext(#NB_CAR))))
  endif  
  for i=0 to lcar-1
    ascii=peeka(ascii(car\lettre[i]))
    select ascii
      case 192 to 197
        car\lettre[i]="A"
      case 199
        car\lettre[i]="C"
      case 200 to 203
        car\lettre[i]="E"
      case 204 to 207
        car\lettre[i]="I"
      case 210 to 214
        car\lettre[i]="O"
      case 217 to 220
        car\lettre[i]="U"
      case 255,221,253
        car\lettre[i]="Y"
      case 65 to 90
      Default
      car\NOMC = ReplaceString(car\NOMC, car\Lettre[i], "" ) 
    endselect    
  next
  if car\NOMC<>carm\NOMC
    car\NOMC=ucase(car\NOMC)
    setgadgettext(#EDITION_CAR,car\NOMC)
  endif
  cartire.mot\NOMC=car\NOMC
  DisableExplicit
endprocedure
procedure voyelle()
  EnableExplicit
  protected rnd,tirevoy$,nb_car
  rnd=random(5,0)
  tirevoy$=Aphabet\Lettre[rnd]
  nb_car=val(getgadgettext(#NB_CAR))
  setgadgettext(#EDITION_CAR,left(getgadgettext(#EDITION_CAR)+tirevoy$,nb_car))  
  DisableExplicit
endprocedure  
procedure consonne()
    EnableExplicit
  protected rnd,tirecon$,nb_car
  rnd=random(25,6)
  tirecon$=Aphabet\Lettre[rnd]
   nb_car=val(getgadgettext(#NB_CAR))
  setgadgettext(#EDITION_CAR,left(getgadgettext(#EDITION_CAR)+tirecon$,nb_car))  
  DisableExplicit
endprocedure  

procedure Efface_Car()
  setgadgettext(#EDITION_CAR,"")
endprocedure

procedure solution()
  EnableExplicit
  protected gredt,jj,group,nblign,lnomc,nbli,sort$,a$,b$,nbcar,titre$,mot_de_x_lettre$,lmin,res$,lmot,lsort
  protected nbslash,  nbcount,nbocc,o,pos,d$,nbmot,ltitre,nbmottotal
  ;;;; exploitation des différents regroupement ************************
;;; ******* Il faut trier les lettres avant de faire la recherche 
  edition_car()
cartret.mot\NOMC=trilettre(cartire.mot\NOMC)
lnomc=len(cartret.mot\NOMC)
if lnomc>10
;   MessageRequester("Mot <10lettres ", "limité à 10 lettres"+chr(10)+cartret.mot\NOMC)
  lnomc=10
  cartret.mot\NOMC=left(cartret.mot\NOMC,10)
 endif 
ClearMap(motrouve()) 
setgadgettext(#SOLUT1,"")
nbmottotal=0
for group=lnomc to 4 step -1
  Comb_exp(lnomc,group,cartret.mot\NOMC)
  nblign=res\ligne[0]\numelem[0]-1
  for nbli=1 to nblign
    ;;;;******************* Cherche *******************
    select group;;;;EEQRSTUU
      case 10
        edite(x)
      case 9
        edite(9)
      case 8
        edite(8)
      case 7
        edite(7)
      case 6
        edite(6)
      case 5
        edite(5)
      case 4
        edite(4)
    endselect    
  next 
next
SetGadgetText(#NBFic,"Nb de Mots trouvés : "+str(nbmottotal))
DisableExplicit
endprocedure

procedure Choix_Rep()
  EnableExplicit 
    protected FichierParDefaut$,filtre$,filtre,FichierM$
  FichierParDefaut$ = getCurrentDirectory()+"LEXIQUE_MOTS_FR2.TXT"   ; Répertoire et fichier par défaut qui seront affichés
  Filtre$ = "Fichiers Textes|*.txt"
  Filtre  = 0    ; utiliser  par défaut le premier des trois filtres possibles
  FichierM$ = OpenFileRequester("Choisissez un fichier à charger", FichierParDefaut$, Filtre$, Filtre)
  creation_fichier(FichierM$)
  INIT_GEN(0)
  chargementMap(0)
  DisableExplicit
endprocedure

procedure choix_ASCII()
  EnableExplicit
  protected FichierM$
  FichierM$=getCurrentDirectory()+"LEXIQUE_MOTS_FR2.TXT" 
  InitNetwork()
  ;   result=ReceiveHTTPFile("http://www.pallier.org/extra/liste.de.mots.francais.frgut.txt",FichierM$)
  if ReceiveHTTPFile("http://www.lexique.org/listes/liste_mots.txt",FichierM$)
    if CopyFile(FichierM$, FichierM$+"sav") 
    Else
      MessageRequester("Information","Impossible de copier le fichier!"+#LF$+ FichierM$+"sav")
    endif
  else 
    MessageRequester("Information","Impossible de recevoir le fichier!"+#LF$+ FichierM$)
  endif
    creation_fichier(FichierM$)
    INIT_GEN(0)
    chargementMap(0)
    DisableExplicit
endprocedure

procedure choix_UTF8()
   EnableExplicit
  protected fichierUTF8$,mot$,FichierM$
  fichierUTF8$=getCurrentDirectory()+"LISTE_MOTS_FRANCAIS_UTF8.TXT"
  FichierM$=getCurrentDirectory()+"LISTE_MOTS_FRANCAIS_ASCII.TXT"
  InitNetwork()
  if ReceiveHTTPFile("http://www.pallier.org/extra/liste.de.mots.francais.frgut.txt",fichierUTF8$)
    ;     result=ReceiveHTTPFile("http://www.lexique.org/listes/liste_mots.txt",FichierM$)
    if CopyFile(fichierUTF8$, fichierUTF8$+"sav")  
      If ReadFile(10, fichierUTF8$, #PB_UTF8   )   ; Si le fichier peut être lu , on continue...
        if CreateFile(100, FichierM$, #PB_Ascii  )
          While Eof(10) = 0                      ; Boucle tant que la fin du fichier n'est pas atteinte. (Eof = 'End Of File') 
            MOT$=ReadString(10)
            WriteStringN(100, mot$) 
          Wend
        Else
          MessageRequester("Information","Impossible de creer le fichier ASCII"+#LF$+ FichierM$)
        endif
        CloseFile(100)
        if CopyFile(FichierM$, FichierM$+"sav") 
        Else
          MessageRequester("Information","Impossible de copier le fichier!"+#LF$+ FichierM$+"sav")
        endif
      Else
        MessageRequester("Information","Impossible de lire le fichier UTF8"+#LF$+ fichierUTF8$)
      endif
    Else
      MessageRequester("Information","Impossible de copier le fichier!"+#LF$+ fichierUTF8$+"sav")
      
    endif
  Else
    MessageRequester("Information","Impossible de recevoir le fichier "+#LF$+ fichierUTF8$)
  endif
    creation_fichier(FichierM$)
    INIT_GEN(0)
    chargementMap(0)
    DisableExplicit
endprocedure

procedure RESTAURER()
   EnableExplicit
  protected FichierParDefaut$,filtre$,filtre,FichierR$,pos,FICH$
  FichierParDefaut$ = getCurrentDirectory()+"LEXIQUE_MOTS_FR2.TXTsav"   ; Répertoire et fichier par défaut qui seront affichés
  Filtre$ = "Fichiers Textes|*.txtsav"
  Filtre  = 0    ; utiliser  par défaut le premier des trois filtres possibles
  FichierR$ = OpenFileRequester("Choisissez un fichier à RESTAURer", FichierParDefaut$, Filtre$, Filtre, #PB_Requester_MultiSelection)
  While FichierR$
    pos=FindString(FichierR$,".txt",1,#PB_String_NoCase)
    FICH$=left(Fichierr$,pos)+"TXT"
    if CopyFile(FichierR$,FICH$)
    Else
      MessageRequester("Information","Impossible de RESTAURer le fichier!"+#LF$+ fichier$+"sav")
    endif  
    FichierR$ = NextSelectedFileName()
  Wend
  DisableExplicit
endprocedure

procedure EFFACER()
   EnableExplicit
    protected FichierParDefaut$,filtre$,filtre, FichierM$
  FichierParDefaut$ = getCurrentDirectory()+"LEXIQUE_MOTS_FR2.TXT"   ; Répertoire et fichier par défaut qui seront affichés
  Filtre$ = "Fichiers Textes|*.txt"
  Filtre  = 0    ; utiliser  par défaut le premier des trois filtres possibles
  FichierM$ = OpenFileRequester("Choisissez un fichier à EFFACER", FichierParDefaut$, Filtre$, Filtre)
  DeleteFile(FichierM$ , #PB_FileSystem_Force)
   DisableExplicit
endprocedure
 
  Procedure QuitHandler()
    End
  EndProcedure
  OpenWindow_1()
for i=4 to 10 
  AddGadgetItem(#NB_CAR,0,str(i) )
next
SetGadgetText(#NB_CAR,"10")
Lecture_Nom_Fichier_()
INIT_GEN(0) 
chargementmap(0)


  BindMenuEvent(0,#RESTAURER, @RESTAURER())
  BindMenuEvent(0,#EFFACER, @EFFACER())


  BindMenuEvent(0,#FchierRep,  @Choix_Rep())
  BindMenuEvent(0,#WEB_1,  @Choix_ASCII())
  BindMenuEvent(0,#WEB_2, @Choix_UTF8())
  BindMenuEvent(0,#QUITER, @QuitHandler())
  
BindgadgetEvent(#Efface,@Efface_Car())
BindgadgetEvent(#CONSONNE,@consonne())
BindgadgetEvent(#VOYELLE,@voyelle())
BindgadgetEvent(#EDITION_CAR,@edition_car())
BindgadgetEvent(#SOLUTION,@Solution())
BindgadgetEvent(#CHANGE_TOUT,@TIRAGEALEA())
Repeat
Until WaitWindowEvent(#Window_1) = #PB_Event_CloseWindow


A+
Dernière modification par PAPIPP le mar. 29/janv./2019 7:37, modifié 1 fois.
Il est fort peu probable que les mêmes causes ne produisent pas les mêmes effets.(Einstein)
Et en logique positive cela donne.
Il est très fortement probable que les mêmes causes produisent les mêmes effets.
Avatar de l’utilisateur
Micoute
Messages : 2522
Inscription : dim. 02/oct./2011 16:17
Localisation : 35520 La Mézière

Re: Le Mot le plus long

Message par Micoute »

Merci beaucoup PAPIPP pour le partage grâcieux, j'adore.
Microsoft Windows 10 Famille 64 bits : Carte mère : ASRock 970 Extreme3 R2.0 : Carte Graphique NVIDIA GeForce RTX 3080 : Processeur AMD FX 6300 6 cœurs 12 threads 3,50 GHz PB 5.73 PB 6.00 LTS (x64)
Un homme doit être poli, mais il doit aussi être libre !
Avatar de l’utilisateur
Huitbit
Messages : 939
Inscription : jeu. 08/déc./2005 5:19
Localisation : Guadeloupe

Re: Le Mot le plus long

Message par Huitbit »

Hello,
Tout cela a l'air très intéressant !

J'ai un soucis ligne 253

Code : Tout sélectionner

Select PeekA(ascii(nom\lettre[i]))
Il ne reconnaît pas ascii()

Ai-je mal lu les consignes ?

Je suis en PureBasic 5.46 LTS (Windows - x64)
Dois-je passer à la nouvelle version ?

Hasta la vista !
Elevé au MSX !
Avatar de l’utilisateur
Micoute
Messages : 2522
Inscription : dim. 02/oct./2011 16:17
Localisation : 35520 La Mézière

Re: Le Mot le plus long

Message par Micoute »

Huitbit a écrit :Dois-je passer à la nouvelle version ?
De toute façon, ça ne mangera pas de pain, mais surtout parce la dernière version est aussi une version LTS
Microsoft Windows 10 Famille 64 bits : Carte mère : ASRock 970 Extreme3 R2.0 : Carte Graphique NVIDIA GeForce RTX 3080 : Processeur AMD FX 6300 6 cœurs 12 threads 3,50 GHz PB 5.73 PB 6.00 LTS (x64)
Un homme doit être poli, mais il doit aussi être libre !
PAPIPP
Messages : 534
Inscription : sam. 23/févr./2008 17:58

Re: Le Mot le plus long

Message par PAPIPP »

@Micoute
Merci

@HuitBit

J'ai réalisé des tests sur PB570 32 bits et sur PB570 64 bits
Tout est OK



PS : je suis en test pour charger un dictionnaire plus complet que les deux fournis plus de 230 000 mots (Enfin je pense)

A+
Il est fort peu probable que les mêmes causes ne produisent pas les mêmes effets.(Einstein)
Et en logique positive cela donne.
Il est très fortement probable que les mêmes causes produisent les mêmes effets.
Marc56
Messages : 2147
Inscription : sam. 08/févr./2014 15:19

Re: Le Mot le plus long

Message par Marc56 »

Il ne reconnaît pas ascii()
...
Je suis en PureBasic 5.46 LTS (Windows - x64)
Apparu avec la 5.50

2 Juillet 2016 : Version 5.50
...
- Ajouté: UTF8() et Ascii() pour créer facilement une chaine UTF8 et :wink:

Historique

:wink:
PAPIPP
Messages : 534
Inscription : sam. 23/févr./2008 17:58

Re: Le Mot le plus long

Message par PAPIPP »

Bonjour à tous

Comme je l’ai signalé dans le post précédent j’essaie de réaliser un dictionnaire plus complet que les deux fournis ;

Actuellement le logiciel ne prend pas en compte les mots composés comme arc-en-ciel ou les traite mal. Faut-il modifier le prg pour prendre en compte ces mots ?
Voici une liste des quelques mots composés ayant moins de 11 lettres puisque le jeu ne permet pas de rechercher des mots de plus de 10 lettres j’ai limité la liste à 10 lettres après suppression des tirets.
arcs-en-ciel arcsenciel 10
arc-en-ciel arcenciel 9
a-t-il atil 4
becs-de-cane becsdecane 10
bec-de-cane becdecane 9
béni-oui-oui béniouioui 10
cha-cha-cha chachacha 9
col-de-cygne coldecygne 10
cou-de-pied coudepied 9
eaux-de-vie eauxdevie 9
eau-de-vie eaudevie 8
hors-la-loi horslaloi 9
in-dix-huit indixhuit 9
in-dix-huit indixhuit 9
lie-de-vin liedevin 8
mal-en-point malenpoint 10
oeil-de-chat oeildechat 10
oeil-de-pie oeildepie 9
one-man-show onemanshow 10
pas-de-géant pasdegéant 10
pas-de-porte pasdeporte 10
pet-de-nonne petdenonne 10
pied-de-loup pieddeloup 10
pied-de-veau pieddeveau 10
pots-de-vin potsdevin 9
pot-au-feu potaufeu 8
pot-de-vin potdevin 8
pout-de-soie poutdesoie 10
poux-de-soie pouxdesoie 10
pou-de-soie poudesoie 9
queue-de-pie queuedepie 10
queue-de-rat queuederat 10
rai-de-coeur raidecoeur 10
rats-de-cave ratsdecave 10
rat-de-cave ratdecave 9
riz-pain-sel rizpainsel 10
rond-de-cuir ronddecuir 10
sans-le-sou sanslesou 9
saut-de-lit sautdelit 9
saut-de-loup sautdeloup 10
sur-le-champ surlechamp 10
tête-de-clou têtedeclou 10
tête-de-loup têtedeloup 10
tête-de-mort têtedemort 10
tire-au-cul tireaucul 9
va-et-vient vaetvient 9
va-nu-pieds vanupieds 9
vert-de-gris vertdegris 10
vert-de-gris vertdegris 10
vol-au-vent volauvent 9
A+
Il est fort peu probable que les mêmes causes ne produisent pas les mêmes effets.(Einstein)
Et en logique positive cela donne.
Il est très fortement probable que les mêmes causes produisent les mêmes effets.
Ollivier
Messages : 4190
Inscription : ven. 29/juin/2007 17:50
Localisation : Encore ?
Contact :

Re: Le Mot le plus long

Message par Ollivier »

Houlà... Les mots composés sont inclus ? Je ne savais pas...
Je ne me souviens plus trop des règles. Ça faisait 9 lettres avant non?

En tout cas, je dois avoir une liste qui traîne quelquepart. C'est la liste du Petit Larousse 1989 que j'ai recopié à la main vers 1997 !
Je les ai plaggié pour mon plus grand bonheur puisque c'était pour un logiciel de création de grilles de mots croisés. Uniquement par passion.

La liste doit faire quelques 70 000 mots (ce sont les pluriels irréguliers qui en rajoutent). Je me souviens avoir fait un compresseur 8 bits --->> 5 bits, avec une conversion par modification de suffixe.

ex :
NYCTALOPE Code 5*Backspace
nyctHEMERE

Code 0 à 25 : 26 lettres de l'alphabet
Code 26 à 31 : x*BackSpace + Entrée (mot suivant)

Code 26 BackSpace*n avec code 5bits suivant définissant n de 5 à... 36 (sachant que le plus grand effacement ça doit faire 16 backspace, ça laissait 20 codages vacants)
Code 27 BackSpace*4
Code 28 BackSpace*3
Code 29 BackSpace*2
Code 30 BackSpace*1
Code 31 Pas de backSpace

65 000 mots non conjugués sans accent, avec féminins et pluriels ça faisait 277 kilo-octets.

Tenait sur une disquette 720 Ko (je faisais avec les moyens du bord...) avec OS, compilateur Borland, code source et liste de mots !!!

(Sachant qu'aujourd'hui la mise à jour OREO de chez SAMSUNG fait 500 méga pour voir des smileys inutiles et un clavier tactile devenu encombrant sans avoir le choix de l'installer, ça fait bizarre d'avoir un tout-en-un de 0,72 mégas. C'est sûr j'avais pas les smileys...)
Avatar de l’utilisateur
Huitbit
Messages : 939
Inscription : jeu. 08/déc./2005 5:19
Localisation : Guadeloupe

Re: Le Mot le plus long

Message par Huitbit »

Hello,

Merci beaucoup :P ,
je vais tester ça ce week end quand j'en aurai fin avec
la grippe :?
Prendre un p'tit suppo c'est agréable.... :lol: :roll:


Hasta la vista !
Elevé au MSX !
PAPIPP
Messages : 534
Inscription : sam. 23/févr./2008 17:58

Re: Le Mot le plus long

Message par PAPIPP »

Bonjour à tous ?

Voici la possibilité d’obtenir un troisième dictionnaire que vous placerez dans le même répertoire que le prg ‘Le mot le plus long’.

Comme il est demandé par les producteurs de ce dictionnaire, j’ai placé leur référence en tête et en commentaire de ce prg.

Ce dictionnaire une fois fini prend environ 3 Méga octets.

Code : Tout sélectionner

; ; --- ATTENTION : CONSERVEZ CETTE LICENCE SI VOUS REDISTRIBUEZ CE FICHIER ---
; ; License ABU
; ; -=-=-=-=-=-
; ; Version 1.1, Aout 1999
; ; 
; ; Copyright (C) 1999 Association de Bibliophiles Universels
; ;    http://abu.cnam.fr/
; ;    abu@cnam.fr
; ; 
; ; La base de textes de l'Association des Bibliophiles Universels (ABU)
; ; est une oeuvre de compilation, elle peut être copiée, diffusée et
; ; modifiée dans les conditions suivantes :
; ; 
; ; 1.  Toute copie à des fins privées, à des fins d'illustration de l'enseignement
; ;     ou de recherche scientifique est autorisée.
; ; 
; ; 2.  Toute diffusion ou inclusion dans une autre oeuvre doit
; ; 
; ;      a) soit inclure la presente licence s'appliquant a l'ensemble de la
; ;         diffusion ou de l'oeuvre dérivee.
; ; 
; ;      b) soit permettre aux bénéficiaires de cette diffusion ou de cette
; ;         oeuvre dérivée d'en extraire facilement et gratuitement une version
; ;         numérisée de chaque texte inclu, muni de la présente licence.  Cette
; ;         possibilité doit être mentionnée explicitement et de façon claire,
; ;         ainsi que le fait que la présente notice s'applique aux documents
; ;         extraits.
; ; 
; ;      c) permettre aux bénéficiaires de cette diffusion ou de cette
; ;         oeuvre dérivée d'en extraire facilement et gratuitement la version
; ;         numérisée originale, munie le cas échéant des améliorations visées au
; ;         paragraphe 6, si elles sont présentent dans la diffusion ou la nouvelle
; ;         oeuvre. Cette possibilité doit être mentionnée explicitement et de
; ;         façon claire, ainsi que le fait que la présente notice s'applique aux
; ;         documents extraits.
; ; 
; ;    Dans tous les autres cas, la présente licence sera réputée s'appliquer
; ;    à l'ensemble de la diffusion ou de l'oeuvre dérivée.
; ; 
; ; 
; ; 3. L'en-tête qui accompagne chaque fichier doit être intégralement 
; ;    conservée au sein de la copie.
; ; 
; ; 4. La mention du producteur original doit être conservée, ainsi
; ;    que celle des contributeurs ultérieurs.
; ; 
; ; 5. Toute modification ultérieure, par correction d'erreurs,
; ;    additions de variantes, mise en forme dans un autre format, ou autre,
; ;    doit être indiquée.  L'indication des diverses contributions devra être
; ;    aussi précise que possible, et datée.
; ; 
; ; 6. Ce copyright s'applique obligatoirement à toute amélioration
; ;    par simple correction d'erreurs ou d'oublis mineurs (orthographe,
; ;    phrase manquante, ...), c'est-à-dire ne correspondant pas à
; ;    l'adjonction d'une autre variante connue du texte, qui devra donc
; ;    comporter la présente notice.
; ; 
; ; ----------------------- FIN DE LA LICENCE ABU --------------------------------

fichierp$=GetCurrentDirectory()+"LETTRE_"
InitNetwork()
nbtot=0
if CreateFile(12,"DICTIONNAIRE_ABU_CNAM_FR.TXT",#PB_Ascii)
  for I=0 TO 25
    L$=CHR(97+i)
    FICHIER$=fichierp$+l$+".TXT"
    URL$="http://abu.cnam.fr/cgi-bin/donner-dico-uncompress?liste_"+l$
    ; Header$ = GetHTTPHeader(URL$);;;; [, Options [, AgentUtilisateur$]])
    ; PARAM$ = GetURLPart(URL$, #PB_URL_Parameters)
    result=ReceiveHTTPFile(URL$,fichier$)
    nbfil=0
    flag_dep=0
    If ReadFile(0, fichier$, #PB_Ascii  )   ; Si le fichier peut être lu , on continue...
      entete: 
      While Eof(0) = 0                      ; Boucle tant que la fin du fichier n'est pas atteinte. (Eof = 'End Of File') 
        MOT$=StringField(ReadString(0),1,chr(09))
        if findstring(mot$,"FIN DE LA LICENCE ABU")
          flag_dep=1
          goto entete
        endif
        if flag_dep=0
;           motsup$+mot$+" "+str(lmot)+"//"
          goto entete
        endif
        lmot=len(mot$)
        if lmot<1 or lmot>25
;           motsup$+mot$+" "+str(lmot)+"//"
          goto entete
        endif  
        nbfil+1
        ;         if nbfil%20 =0
        ;           debug mot$+" "+_n(len(mot$))
        ;         endif
        WriteString(12,mot$+chr(10),#PB_Ascii)
      Wend
      CloseFile(0); Ferme le fichier précédemment ouvert
;       if i>0
        DeleteFile(fichier$,#PB_FileSystem_Force)
;       endif  
      nbtot+nbfil
    Else
      MessageRequester("Information","Impossible d'ouvrir le fichier : "+fichier$)
    EndIf
    if nbfil % 7=0
      nbfil$+l$+"="+str(nbfil)+chr(10)
    Else
      nbfil$+ l$+"="+str(nbfil)+" / "
    endif
  Next
Else
  MessageRequester("Information","Impossible de créer le fichier : Dictionnaire_abu_cnam_fr.TXT")
endif
closefile(12)
; messagerequester("MOTS supprimés",motsup$)
MessageRequester("Nbtot="+str(nbtot),NBfil$)

End


Les 26 fichiers, 'Lettre_x.txt ', créés sont détruits immédiatement après leur utilisation.
(x correspond à la première lettre des mots enregistrés)
Si vous désirez les conserver, placez l'instruction suivante en commentaire ;; DeleteFile(fichier$,#PB_FileSystem_Force)

A+
Il est fort peu probable que les mêmes causes ne produisent pas les mêmes effets.(Einstein)
Et en logique positive cela donne.
Il est très fortement probable que les mêmes causes produisent les mêmes effets.
PAPIPP
Messages : 534
Inscription : sam. 23/févr./2008 17:58

Re: Le Mot le plus long

Message par PAPIPP »

Bonjours à tous.

Comme il me fallait choisir entre supprimer ou ajouter les mots composés.

J’ai choisi d’ajouter les mots composés
Or comme Ollivier le précisait, le jeu ne comporte pas plus de 9 lettres à trouver et ne contient pas les mots composés.
Ceci est offert en plus. C’est à vous de restreindre les règles c'est-à-dire de refuser les mots de plus de 9 lettres et les mots composés.
Vous pouvez aussi modifier le prg pour appliquer ces règles.

Avec ce nouveau prg voici ce que donne avec le nouveau dictionnaire le mot arcs-en-ciel tapé en lettre minuscule dans la zone des lettres à fournir.
LEICNESCRA
Résultats /
2 Mot(s) de >10 lettres=
/arcs-en-ciel/encerclais

6 Mot(s) de 9 lettres=
/arc-en-ciel/encerclai/calcinées/cancérise/cancérisé/encerclas

30 Mot(s) de 8 lettres=
/calcinée/encercla/cénacles/carences/créances/calciner/calcinés/cerclais/linacées/sélacien
/cèlerais/cisèlera/éclairés/éclaires/escalier/recelais/césarien/racinées/recensai/relances
/relancés/renâcles/carlines/clarines/lanciers/arlésien/enlisera/lanières/lésinera/licences

98 Mot(s) de 7 lettres=
/cénacle/carencé/carence/créance/calcine/calciné/cerclai/calices/cerclas/cancers/cancres/linacée
/cèlerai/éclairé/éclaire/lacerie/recelai/racinée/caséine/acières/cariées/carnèle/élancer/enlacer
/relance/relancé/renâcle/renâclé/élancés/enlaces/enlacés/lancées/scalène/cèleras/lacères/lacérés
/raclées/recalés/recelas/acenser/ancrées/carénés/carènes/carnées/caserne/caserné/nacrées/recensa
/sérance/sérancé/câliner/carline/clarine/lancier/câlines/sanicle/caliers/claires/éclairs/arsenic
/cernais/encrais/racines/racinés/rancies/ricanes/lancers/carlins/larcins/aliéner/lanière/alésien
/aliénés/aliènes/léserai/réalise/réalisé/relaies/salière/aériens/âneries/enraies/rénales/licence
/science/cerclés/cercles/silence/céleris/ciseler/censier/incréés/rincées/sincère/enliser/ensiler
/lésiner/liernes

194 Mot(s) de 6 lettres=
/calice/accise/cancel/carcel/cercla/cancer/cancre/calcin/aciéré/acière/cariée/alcène/élancé
/élance/enlace/enlacé/lancée/cèlera/écaler/lacère/lacéré/raclée/recalé/recela/calées/écales
/escale/lacées/ancrée/caréné/carène/carnée/nacrée/acense/séance/acérés/acères/écrasé/écrase
/racées/sacrée/câline/câliné/lanice/calier/claire/éclair/celais/cisela/claies/cernai/encrai
/racine/raciné/rancie/ricane/ricané/aciers/cariés/caries/casier/craies/créais/écrias/sciera
/lancer/lancés/lances/racles/raclés/sarcle/sarclé/ancres/ancrés/carnés/carnes/cernas/crânes
/écrans/encras/nacrés/nacres/rances/carlin/larcin/câlins/lancis/clairs/crains/rancis/rinças
/aliéné/aliène/relaie/ailées/elaeis/aérien/ânerie/ânière/enraie/aînées/arisée/rénale/alênes
/aléser/lésera/réales/resale/arènes/lainer/lanier/enlias/enlisa/ensila/laines/lésina/lianes
/salien/saline/éliras/lieras/lisera/relais/sérail/aniser/arsine/inséra/iseran/nieras/raines
/renais/résina/serina/rilsan/cerclé/cercle/cerces/cincle/clercs/céleri/cisèle/ciselé/siècle
/incréé/rincée/nièces/sciène/cerise/cirées/criées/écries/écriés/recels/cernés/cernes/crènes
/encres/encrés/écrins/rinces/rincés/enlier/lierne/enlies/enlise/enlisé/ensile/ensilé/lésine
/lésiné/sénile/silène/liseré/liséré/lisère/réélis/relies/reliés/relise/sériel/insère/inséré
/néréis/reines/renies/reniés/résiné/résine/serein/serine/sérine/seriné/sirène/liners

195 Mot(s) de 5 lettres=
/accès/calée/écale/écalé/lacée/acéré/acère/racée/casée/celai/claie/acier/carié/carie/craie/créai
/écria/lancé/lance/caler/lacer/racle/raclé/calés/cales/celas/lacés/laces/ancre/ancré/caner/carné
/carne/cerna/crâne/écran/encra/nacré/nacre/rance/canes/céans/encas/âcres/acres/caser/césar/crase
/créas/racés/races/réacs/sacré/sacre/scare/sérac/câlin/clair/lacis/laïcs/cairn/ranci/rinça/incas
/ciras/crias/clans/crans/ailée/aînée/aisée/alêne/réale/alésé/alèse/salée/arène/ansée/aérés/aères
/rasée/enlia/laine/liane/élira/liera/relia/ailés/ailes/alise/asile/laies/lésai/salie/ânier/arien
/niera/raine/rainé/renia/aînés/aines/anisé/anise/saine/sanie/aires/arise/arisé/serai/raies/réais
/séria/siéra/rénal/élans/lares/laser/râles/saler/salin/liras/rails/rials/salir/arsin/cerce/clerc
/crics/nièce/cirée/criée/écrie/écrié/sciée/celer/recel/cèles/celés/cerné/cerne/crène/encre/encré
/censé/scène/créés/crées/recès/ciels/lices/sicle/écrin/rince/rincé/ceins/cinés/cirés/cires/cries
/criés/crise/écris/scier/clins/crins/enlie/enlié/élier/élire/relie/relié/éléis/élise/liées/érine
/reine/renie/renié/niées/seine/risée/série/sérié/léser/réels/rênes/liner/liens/lines/lires/relis
/reins/riens/serin

137 Mot(s) de 4 lettres=
/crac/calé/cale/cela/lacé/lace/acné/cane/cané/âcre/acre/arec/créa/racé/race/réac/aces/case/casé
/laïc/inca/cari/cira/cria/scia/clan/cals/lacs/cran/arcs/cars/aéré/aère/ailé/aile/laie/aîné/aine
/aire/raie/réai/aies/aise/aisé/saie/élan/lare/râle/râlé/réal/ales/lésa/sale/salé/ânes/ansé/anse
/nase/ares/sera/rase/rasé/réas/lira/rail/rial/lais/lias/sali/sial/rani/anis/nais/nias/sain/airs
/iras/rais/rias/sari/ceci/clic/cric/cèle/celé/cène/créé/crée/ciel/lice/ciné/ciré/cire/crie/crié
/scie/scié/clés/cens/clin/cils/crin/cris/liée/niée/réel/lèse/lésé/rené/rêne/nées/séné/ères/erse
/rées/lien/line/lier/lire/riel/élis/îles/iles/liés/lies/lise/nier/rein/rien/nies/niés/sein/sien
/ires/reis/ries/sire
Voici le prg

Code : Tout sélectionner


Enumeration FormWindow
  #Window_1
EndEnumeration
; openconsole("Mots",#PB_Ascii  )
Enumeration FormGadget
  #TITRE
  #NB_CAR
  #VOYELLE
  #EDITION_CAR
  #Text_1
  #CONSONNE
  #CHANGE_TOUT
  #SOLUTION
  #SOLUT1
  #NomFic
  #Efface
  #NBFic
EndEnumeration

Enumeration FormMenu
  #FchierRep
  #WEB_1
  #Web_2
  #Quiter
  #EFFACER
  #RESTAURER
EndEnumeration

Enumeration FormFont
  #Font_Window_1_0
  #Font_Window_1_1
  #Font_Window_1_2
EndEnumeration

LoadFont(#Font_Window_1_0,"Arial", 28, #PB_Font_Bold)
LoadFont(#Font_Window_1_1,"Courier New", 40, #PB_Font_Bold)
LoadFont(#Font_Window_1_2,"Courier New", 9)


Procedure OpenWindow_1(x = 0, y = 0, width = 730, height = 800)
  OpenWindow(#Window_1, x, y, width, height, "", #PB_Window_SystemMenu | #PB_Window_MinimizeGadget)
  ;   SetWindowColor(#Window_1, RGB(208,208,208))
  CreateMenu(0, WindowID(#Window_1))
  MenuTitle("Choix_Dico")
  MenuItem(#FchierRep, "Fichier TXT en répertoire")
  MenuItem(#WEB_1, "Web ASCII=>LEXIQUE*.TXT")
  MenuItem(#Web_2, "Web UTF8=>LISTE*.TXT")
  MenuItem(#Quiter, "Quiter")
  MenuTitle("Fichier")
  MenuItem(#EFFACER, "Effacer *.TXT")
  MenuItem(#RESTAURER, "RESTAURer *.TXT")
  TextGadget(#TITRE, 40, 10, 650, 50, "L E   M O T    L E    P L U S    L O N G", #PB_Text_Center)
  SetGadgetFont(#TITRE, FontID(#Font_Window_1_0))
  ComboBoxGadget(#NB_CAR, 40, 100, 50, 20, #PB_ComboBox_Editable)
  ButtonGadget(#VOYELLE, 190, 190, 80, 30, "Voyelle")
  EditorGadget(#EDITION_CAR, 185, 60, 345, 70, #PB_Editor_WordWrap)
  SetGadgetFont(#EDITION_CAR, FontID(#Font_Window_1_1))
  TextGadget(#Text_1, 30, 80, 70, 20, "  Nb Car Max")
  ButtonGadget(#CONSONNE, 450, 190, 80, 30, "Consonne")
  ButtonGadget(#CHANGE_TOUT, 300, 190, 130, 30, "Change tout")
  ButtonGadget(#SOLUTION, 300, 230, 130, 30, "SOLUTION")
  EditorGadget(#SOLUT1, 10, 270, 700, 490)
  SetGadgetFont(#SOLUT1, FontID(#Font_Window_1_2))
  TextGadget(#NomFic, 50, 150, 620, 20, "Nom du fichier utilisé :", #PB_Text_Center)
  ButtonGadget(#Efface, 570, 90, 80, 30, "Efface")
  TextGadget(#NBFic, 20, 240, 210, 20, "")
EndProcedure




structure mot
  StructureUnion
    NOMC.s{26}
    Lettre.s{1}[26]
  EndStructureUnion
endstructure 
Structure colonne 
  numelem.a[11]
  car.mot
EndStructure
Structure tabres 
  ligne.colonne[255]
EndStructure  

Global FICHIER$
global Path_Map$
global NewMap moti.string()
global NewMap mot4.string()
global NewMap mot5.string()
global NewMap mot6.string()
global NewMap mot7.string()
global NewMap mot8.string()
global NewMap mot9.string()
global NewMap motx.string()
global NewMap mots.string()
global newmap motrouve.string()
global Aphabet.mot
global flag_dico=1
ProcedureDLL.q _nbcycl()
  !RDTSC
  ProcedureReturn
EndProcedure
macro stock(_n)
  ;   if len(mot$)<26   ;;;; ici pas de limite pour mémoriser le mots de plus de 10 lettres alors qu'il ne sont pas utilisés
  ;;;;;    pour accélérer on peut réduire <13
  if len(mot$)<12
    If FindMapElement(mot#_n(),nomt\NOMC)
      if FindString(mot#_n(nomt\NOMC)\s,mot$)
      else  
        mot#_n(nomt\NOMC)\s=mot#_n()\s+"/"+motm$
      endif  
    Else
      mot#_n(nomt\NOMC)\s=nomt\NOMC+"/"+motm$
    endif
  endif
endmacro 

Macro _q_t
  "
EndMacro
macro TestMap(__n)
  a$=_q_t#__n#_q_t
  ficMap$=Path_Map$+"Mot_"+a$+".txt"
  if filesize(FicMap$)<0
    resulta *0
  Else
    resulta *1
  endif 
endmacro

Macro Ecrire(__n)
  a$=_q_t#__n#_q_t
  
  if filesize(Path_Map$)=-1
    if CreateDirectory(Path_Map$) 
    Else
      MessageRequester("Information","Impossible de créer le répertoire  Mapx.txt!"+#LF$+ Path_Map$)
    endif  
  endif
  
  ficMap$=Path_Map$+"Mot_"+a$+".txt"
  if filesize(FicMap$)=>0
    RenameFile(ficMap$,ficMap$+"sav")
  endif  
  If CreateFile(__n, ficMap$)         ; crée un nouveau fichier texte ou recrée une fichier texte vide s'il existe déjà ...
    ResetMap(mot#__n())      
    While NextMapElement(mot#__n()) 
      WriteStringN(__n, mot#__n()\s)
    Wend
    CloseFile(__n)                       ; ferme le fichier précédemment ouvert et enregistre les données
  Else
    MessageRequester("Information","Impossible de créer le fichier Mapx.txt!"+#LF$+ ficMap$)
  EndIf
endmacro 

procedure creation_Fichier(fichierm$)
  nom_fichier$=GetCurrentDirectory()+"_Nom_Fichier_"
  if  createfile(5,nom_fichier$)
    WriteString(5,Fichierm$+chr(10),#PB_Ascii )
    CloseFile(5)
  else 
    MessageRequester("Information","Impossible de creer le fichier ASCII"+#LF$+ FichierM$)
  endif
endprocedure
procedure Lecture_Nom_Fichier_()
  nom_fichier$=GetCurrentDirectory()+"_Nom_Fichier_"
  if filesize(nom_fichier$)>0
    if  readfile(5,nom_fichier$)  ;;; fichier avec un seul enregistrement donc pas de boucle
      FICHIER$=ReadString(5)     
      CloseFile(5)               ; Ferme le fichier précédemment créé ou ouvert
    Else
      MessageRequester("Information","Impossible d'ouvrir le fichier!=_Nom_Fichier_")
    EndIf
  Else
    fichier$=""
  endif
endprocedure


;;;;****************** initialisation générale pour les cas ou les fichiers ne seraient pas créés ********
procedure INIT_GEN(val);; val pour une éventuelle  utilisation avec thread 
  EnableExplicit 
  protected result, resulta,resultb,resultc, mot$,i,lmot,ii,a$,x,s,init_dic$,FichierParDefaut$,Filtre$
  protected filtre,prgpb$,Compilateur,Sortie$,code_ret,prgexec$,exec_dico
  protected Path_Fic$,file$,files$,ficMap$,jjj,MOTM$,nbtir
  
  define Nomt.mot
  define Nom.mot
  dim tabnom.s(25)
  lecture_Nom_fichier_()
  ClearMap(motrouve())
  Clearmap( moti.string())
  Clearmap( mot4.string())
  Clearmap( mot5.string())
  Clearmap( mot6.string())
  Clearmap( mot7.string())
  Clearmap( mot8.string())
  Clearmap( mot9.string())
  Clearmap( motx.string())
  Clearmap( mots.string())
  if FileSize(Fichier$) <0
    if fichier$=""
      Fichier$ = getCurrentDirectory()+"LEXIQUE_MOTS_FR2.TXT" 
      creation_fichier(fichier$)
    endif
    InitNetwork()
    result=ReceiveHTTPFile("http://www.lexique.org/listes/liste_mots.txt",fichier$)
  Else
    if CopyFile(fichier$, fichier$+"sav") 
      result=1
    Else
      result=0
      MessageRequester("Information","Impossible de créer le fichier!"+#LF$+ fichier$+"sav")
    endif
  endif 
  Path_Fic$=GetPathPart(FICHIER$)
  if path_fic$=""
    files$=GetFilePart(FICHIER$,#PB_FileSystem_NoExtension)
  else
    files$=GetFilePart(FICHIER$,#PB_FileSystem_NoExtension)+"\"
  endif 
  file$=GetFilePart(FICHIER$)
  path_map$=Path_Fic$+files$
  SetGadgetText(#NomFic,"FICHIER UTILISE : "+fichier$)
  ;;; Test de la présence des fichiers MAP*.txt
  resulta=1
;   if flag_dico=1   
    for jjj=1 to 11
      select jjj
        case 1 to 3
          TestMap(i)
        case 4 
          testMap(4)
        case 5
          testMap(5)
        case 6 
          testMap(6)
        case 7
          testMap(7)
        case 8
          testMap(8)
        case 9
          testMap(9)
        case 10
          TestMAp(x)
        Default
          TestMap(s)
      endselect      
    next
;   else 
;     resulta=0
;   endif
  if result and not resulta
;     flag_dico=1
    If ReadFile(0, fichier$, #PB_Ascii  )   ; Si le fichier peut être lu , on continue...
      While Eof(0) = 0                      ; Boucle tant que la fin du fichier n'est pas atteinte. (Eof = 'End Of File') 
        MOT$=StringField(ReadString(0),1,chr(09))
        motm$=mot$
        nbtir=CountString(mot$,"-")
        if nbtir>0
          MOT$=RemoveString(MOTm$,"-")
          ;           if len(mot$)<11
          ;             printn(mot$+"   "+motm$+"  "+str(len(motm$)))
          ;            endif 
        endif  
        
        if FindString(Mot$," ") =0 ;;;or FindString(Mot$,chr(9))=0
          nom\NOMC=Ucase(MOT$)
          for i=0 to len(nom\NOMC)-1
            select peeka(ascii(nom\lettre[i]))
              case 32 to 63
                nom\lettre[i]=""
              case 192 to 197
                nom\lettre[i]="A"
              case 199
                nom\lettre[i]="C"
              case 200 to 203
                nom\lettre[i]="E"
              case 204 to 207
                nom\lettre[i]="I"
              case 210 to 214
                nom\lettre[i]="O"
              case 217 to 220
                nom\lettre[i]="U"
              case 255,221,253
                nom\lettre[i]="Y"
            endselect    
            tabnom(i)=nom\Lettre[i]
          next
          SortArray(tabnom(),#PB_Sort_Ascending,0,len(nom\NOMC)-1 )
          nomt\NOMC=""
          for i=0 to len(nom\NOMC)-1
            nomt\Lettre[i]=tabnom(i)
          next
          lmot=len(mot$)
          select lmot
            case 1 to 3
              stock(i)
            case 4
              stock(4)
            case 5
              stock(5)  
            case 6
              stock(6)          
            case 7
              stock(7)
            case 8
              stock(8)
            case 9
              stock(9)
            case 10 
              stock(x)
            case 11 to 25
              stock(s)
          endselect
        Else
        endif
        
      Wend
      CloseFile(0); Ferme le fichier précédemment ouvert
                  ;;;; ********************  remettre l'initialisation dictionnaire à 0 
                  ;    SetGadgetState(#Init_Dic,#PB_CheckBox_Unchecked)
                  ;    flag_dic=0
                  ;;;;********************* sauve les map sur des fichiers **************************
      for ii=3 to 25
        select ii
          case 3
            i=3
            ecrire (i)
          case 4
            ecrire(4)
          case 5
            ecrire(5)
          case 6
            ecrire(6)
          case 7
            ecrire(7)
          case 8
            ecrire(8)
          case 9
            ecrire(9)
          case 10
            x=ii
            ecrire(x)
          case 11 to 25
            s=ii
            ecrire(s)
        endselect    
      Next
    Else
      MessageRequester("Information","Impossible d'ouvrir le fichier!")
    EndIf
  endif
  DisableExplicit
  creation_Fichier(Fichier$)
endprocedure
;******************  Moteur du mot le plus long ************************* 

Macro Lire(__n)
  a$=_q_t#__n#_q_t
  ficMap$=Path_Map$+"Mot_"+a$+".txt"
  If ReadFile(__n, ficMap$,#PB_File_SharedRead )   ; Si le fichier peut être lu , on continue...
    While Eof(__n) = 0                 
      MOT$=ReadString(__n)
      pos=__n
      if __n<4 or __n>9
        pos = FindString(mot$, "/")-1
      endif
      clef$=left(mot$,pos)
      mot#__n(clef$)\s=mot$
    Wend
    CloseFile(__n)                       ; ferme le fichier précédemment ouvert et enregistre les données
  Else
    MessageRequester("Information","Impossible de Lire le fichier!"+#LF$+ FicMap$)
  EndIf
endmacro  
procedure AlphabetVoyelleConsonne(val);; val pour une éventuelle  utilisation avec thread
  EnableExplicit
  protected VOYELLE.mot,CONSONNE.mot,i,c$
  for i=0 to 25
    c$= chr(65+i)
    select c$
      case "A","E","I","O","U","Y"
        voyelle\NOMC+c$
      Default
        consonne\NOMC+c$
    endselect
  next  
  Aphabet.mot\NOMC=voyelle\NOMC+consonne\NOMC
  DisableExplicit
endprocedure
;;;***************************************************
procedure chargementMap(val);; val pour une éventuelle  utilisation avec thread
  EnableExplicit
  protected ii,i,x,s,a$,fichier$,mot$,pos,clef$,FicMap$
  AlphabetVoyelleConsonne(0)
  for ii=3 to 25
    select ii   ;;;; Les mots <4 lettres et >10 lettres ne sont pas utilisés dans le prg il sont mis en commentaire
                ;           case 3
                ;             i=3
                ;             Lire (i)
      case 4
        Lire(4)
      case 5
        Lire(5)
      case 6
        Lire(6)
      case 7
        Lire(7)
      case 8
        Lire(8)
      case 9
        Lire(9)
      case 10
        x=ii
        Lire(x)
        ;           case 11 to 25
        ;             s=ii
        ;             Lire(s)
    endselect    
  Next
  DisableExplicit
endprocedure  


;************************ les deux Procédure de degroupement **********************************
EnableExplicit
Declare comb_exp0(N,gr,ind)
Procedure Comb_exp(N,GR,chaine$)
  EnableExplicit
  Global clef.mot\NOMC=chaine$
  Global  RES.tabres
  define res0.tabres
  copymemory(res0,res,SizeOf(tabres))
  res\ligne[0]\numelem[0]=1
  Global Dim tab(N)
  comb_exp0(N,Gr,1);
  DisableExplicit
EndProcedure
Procedure comb_exp0(N,gr,ind);;;,Array tab(1))
  EnableExplicit
  protected i,j,lig
  global GP0
  If ind=1
    gp0=gr
  EndIf 
  If gr<>0
    For i=tab(ind-1)+1 To N
      tab(ind)=i
      comb_exp0(N,gr-1,ind+1)
    Next 
  Else
    lig=res\ligne[0]\numelem[0]
    For j=1 To GP0
      res\ligne[lig]\car\Lettre[j-1] = clef\Lettre[tab(j)-1]
    Next
    res\ligne[0]\numelem[0]+1
  EndIf
  DisableExplicit
EndProcedure
DisableExplicit
;;;******************** Procédure de tri par lettre ***********************************
procedure.s trilettre(entree$)
  EnableExplicit
  protected entree.mot,i,sortiet.mot
  Entree.mot\NOMC=entree$
  dim tabnom.s(25)
  
  for i=0 to len(Entree\NOMC)-1
    tabnom(i)=Entree\Lettre[i]
  next
  
  SortArray(tabnom(),#PB_Sort_Ascending,0,len(Entree\NOMC)-1 )
  
  define Sortiet.mot\NOMC=""
  for i=0 to len(Entree\NOMC)-1
    Sortiet\Lettre[i]=tabnom(i)
  next
  ProcedureReturn Sortiet\NOMC 
  DisableExplicit
endprocedure
macro edite(__n)
  sort$=""
  a$=_q_t#__n#_q_t
  ;    fichier$="Mot_"+a$+".txt"
  b$=a$
  select a$
    case "x"
      nbcar=10
      b$=">10"    
    case "i"
      nbcar=3
      b$="<4"
    case "s"
      nbcar= 11
      b$=">10"
    Default
      nbcar=val(a$)
  endselect    
  if nbli=1
    titre$="Mot(s) de " +b$+ " lettres="+chr(10)
    mot_de_x_lettre$=""
    lmin=len(mot_de_x_lettre$)
  endif  
  ;         res$=mot4(res\ligne[nbli]\car\NOMC)\s
  res$=mot#__n (res\ligne[nbli]\car\NOMC)\s
  if res$<>"" and motrouve(res$)\s=""
    mot_de_x_lettre$ + right(res$,len(res$)-nbcar);+"/"
                                                  ;     if len(mot_de_x_lettre$)%100>90
                                                  ;       mot_de_x_lettre$+chr(10)
                                                  ;     endif  
    lmot=len(mot_de_x_lettre$)
    motrouve(res$)\s=res$
  endif 
  if nbli=nblign and lmot>lmin
    sort$=mot_de_x_lettre$
    lsort=len(sort$)
    nbslash = CountString(sort$, "/")
    ;     nbcount=96/(nbcar+1)
    nbcount=96/(nbcar+1)
    nbocc=nbslash/nbcount
    for o=1 to nbocc
      pos=1+((nbcar+1)*nbcount*o)
      ;     ReplaceString(bbb$,"/",chr(10), #PB_String_InPlace,pos,1)
      ReplaceString(sort$,"/",chr(10), #PB_String_InPlace,pos,1)
    next
    d$=ReplaceString(sort$,chr(10),chr(10)+"/")
    nbmot=countstring(d$,"/")
    nbmottotal+ nbmot
    ltitre=len(str(nbmot)+" "+titre$)
    sort$=str(nbmot)+" "+titre$+d$
    
    if len(sort$)>ltitre+3
      setgadgettext(#SOLUT1,getgadgettext(#SOLUT1)+sort$+chr(10)+chr(10))
    endif  
  endif  
endmacro 
;;;;************ simulation du tirage des letrres ****************
procedure TIRAGEALEA()
  EnableExplicit
  global cartret.mot\NOMC=""
  global cartire.mot\NOMC=""
  
  protected nbvoyt=0, nb_atirer, t,rnd
  nb_atirer=val(GetGadgetText(#NB_CAR))
  for t=1 to nb_atirer
    rnd=random(len(Aphabet\NOMC)-1,0)
    if rnd<6
      nbvoyt+1
    endif  
    if t=nb_atirer and nbvoyt=0
      cartire.mot\NOMC+Aphabet\Lettre[random(5,0)]
      nbvoyt+1
    else
      cartire.mot\NOMC+Aphabet\Lettre[rnd]
    endif 
  Next
  SetGadgetText(#EDITION_CAR,cartire\NOMC)
  DisableExplicit
endprocedure

procedure edition_car()
  EnableExplicit
  static fin.q,deb.q,fin2.q
  protected carm.mot\NOMC= getGadgetText(#EDITION_CAR), car.mot,i,ascii,lcar
  car.mot\NOMC=ucase(carm\NOMC)
  lcar=len(car.mot\NOMC)
  if lcar > val(getgadgettext(#NB_CAR))
    setgadgettext(#EDITION_CAR,left(getgadgettext(#EDITION_CAR),val(getgadgettext(#NB_CAR))))
  endif  
  for i=0 to lcar-1
    ascii=peeka(ascii(car\lettre[i]))
    select ascii
      case 192 to 197
        car\lettre[i]="A"
      case 199
        car\lettre[i]="C"
      case 200 to 203
        car\lettre[i]="E"
      case 204 to 207
        car\lettre[i]="I"
      case 210 to 214
        car\lettre[i]="O"
      case 217 to 220
        car\lettre[i]="U"
      case 255,221,253
        car\lettre[i]="Y"
      case 65 to 90
      Default
        car\NOMC = ReplaceString(car\NOMC, car\Lettre[i], "" ) 
    endselect    
  next
  if car\NOMC<>carm\NOMC
    car\NOMC=ucase(car\NOMC)
    setgadgettext(#EDITION_CAR,car\NOMC)
  endif
  cartire.mot\NOMC=car\NOMC
  DisableExplicit
endprocedure
procedure voyelle()
  EnableExplicit
  protected rnd,tirevoy$,nb_car
  rnd=random(5,0)
  tirevoy$=Aphabet\Lettre[rnd]
  nb_car=val(getgadgettext(#NB_CAR))
  setgadgettext(#EDITION_CAR,left(getgadgettext(#EDITION_CAR)+tirevoy$,nb_car))  
  DisableExplicit
endprocedure  
procedure consonne()
  EnableExplicit
  protected rnd,tirecon$,nb_car
  rnd=random(25,6)
  tirecon$=Aphabet\Lettre[rnd]
  nb_car=val(getgadgettext(#NB_CAR))
  setgadgettext(#EDITION_CAR,left(getgadgettext(#EDITION_CAR)+tirecon$,nb_car))  
  DisableExplicit
endprocedure  

procedure Efface_Car()
  setgadgettext(#EDITION_CAR,"")
endprocedure

procedure solution()
  EnableExplicit
  protected gredt,jj,group,nblign,lnomc,nbli,sort$,a$,b$,nbcar,titre$,mot_de_x_lettre$,lmin,res$,lmot,lsort
  protected nbslash,  nbcount,nbocc,o,pos,d$,nbmot,ltitre,nbmottotal
  ;;;; exploitation des différents regroupement ************************
  ;;; ******* Il faut trier les lettres avant de faire la recherche 
  edition_car()
  cartret.mot\NOMC=trilettre(cartire.mot\NOMC)
  lnomc=len(cartret.mot\NOMC)
  if lnomc>10
    ;   MessageRequester("Mot <10lettres ", "limité à 10 lettres"+chr(10)+cartret.mot\NOMC)
    lnomc=10
    cartret.mot\NOMC=left(cartret.mot\NOMC,10)
  endif 
  ClearMap(motrouve()) 
  setgadgettext(#SOLUT1,"")
  nbmottotal=0
  for group=lnomc to 4 step -1
    Comb_exp(lnomc,group,cartret.mot\NOMC)
    nblign=res\ligne[0]\numelem[0]-1
    for nbli=1 to nblign
      ;;;;******************* Cherche *******************
      select group;;;;EEQRSTUU
        case 10
          edite(x)
        case 9
          edite(9)
        case 8
          edite(8)
        case 7
          edite(7)
        case 6
          edite(6)
        case 5
          edite(5)
        case 4
          edite(4)
      endselect    
    next 
  next
  SetGadgetText(#NBFic,"Nb de Mots trouvés : "+str(nbmottotal))
  DisableExplicit
endprocedure

procedure Choix_Rep()
  EnableExplicit 
  protected FichierParDefaut$,filtre$,filtre,FichierM$
  FichierParDefaut$ = getCurrentDirectory()+"LEXIQUE_MOTS_FR2.TXT"   ; Répertoire et fichier par défaut qui seront affichés
  Filtre$ = "Fichiers Textes|*.txt"
  Filtre  = 0    ; utiliser  par défaut le premier des trois filtres possibles
  FichierM$ = OpenFileRequester("Choisissez un fichier à charger", FichierParDefaut$, Filtre$, Filtre)
  creation_fichier(FichierM$)
;   flag_dico=0
  INIT_GEN(0)
  chargementMap(0)
  DisableExplicit
endprocedure

procedure choix_ASCII()
  EnableExplicit
  protected FichierM$
  FichierM$=getCurrentDirectory()+"LEXIQUE_MOTS_FR2.TXT" 
  InitNetwork()
  ;   result=ReceiveHTTPFile("http://www.pallier.org/extra/liste.de.mots.francais.frgut.txt",FichierM$)
  if ReceiveHTTPFile("http://www.lexique.org/listes/liste_mots.txt",FichierM$)
    if CopyFile(FichierM$, FichierM$+"sav") 
    Else
      MessageRequester("Information","Impossible de copier le fichier!"+#LF$+ FichierM$+"sav")
    endif
  else 
    MessageRequester("Information","Impossible de recevoir le fichier!"+#LF$+ FichierM$)
  endif
  creation_fichier(FichierM$)
  INIT_GEN(0)
  chargementMap(0)
  DisableExplicit
endprocedure

procedure choix_UTF8()
  EnableExplicit
  protected fichierUTF8$,mot$,FichierM$
  fichierUTF8$=getCurrentDirectory()+"LISTE_MOTS_FRANCAIS_UTF8.TXT"
  FichierM$=getCurrentDirectory()+"LISTE_MOTS_FRANCAIS_ASCII.TXT"
  InitNetwork()
  if ReceiveHTTPFile("http://www.pallier.org/extra/liste.de.mots.francais.frgut.txt",fichierUTF8$)
    ;     result=ReceiveHTTPFile("http://www.lexique.org/listes/liste_mots.txt",FichierM$)
    if CopyFile(fichierUTF8$, fichierUTF8$+"sav")  
      If ReadFile(10, fichierUTF8$, #PB_UTF8   )   ; Si le fichier peut être lu , on continue...
        if CreateFile(100, FichierM$, #PB_Ascii  )
          While Eof(10) = 0                      ; Boucle tant que la fin du fichier n'est pas atteinte. (Eof = 'End Of File') 
            MOT$=ReadString(10)
            WriteStringN(100, mot$) 
          Wend
        Else
          MessageRequester("Information","Impossible de creer le fichier ASCII"+#LF$+ FichierM$)
        endif
        CloseFile(100)
        if CopyFile(FichierM$, FichierM$+"sav") 
        Else
          MessageRequester("Information","Impossible de copier le fichier!"+#LF$+ FichierM$+"sav")
        endif
      Else
        MessageRequester("Information","Impossible de lire le fichier UTF8"+#LF$+ fichierUTF8$)
      endif
    Else
      MessageRequester("Information","Impossible de copier le fichier!"+#LF$+ fichierUTF8$+"sav")
      
    endif
  Else
    MessageRequester("Information","Impossible de recevoir le fichier "+#LF$+ fichierUTF8$)
  endif
  creation_fichier(FichierM$)
  INIT_GEN(0)
  chargementMap(0)
  DisableExplicit
endprocedure

procedure RESTAURER()
  EnableExplicit
  protected FichierParDefaut$,filtre$,filtre,FichierR$,pos,FICH$
  FichierParDefaut$ = getCurrentDirectory()+"LEXIQUE_MOTS_FR2.TXTsav"   ; Répertoire et fichier par défaut qui seront affichés
  Filtre$ = "Fichiers Textes|*.txtsav"
  Filtre  = 0    ; utiliser  par défaut le premier des trois filtres possibles
  FichierR$ = OpenFileRequester("Choisissez un fichier à RESTAURer", FichierParDefaut$, Filtre$, Filtre, #PB_Requester_MultiSelection)
  While FichierR$
    pos=FindString(FichierR$,".txt",1,#PB_String_NoCase)
    FICH$=left(Fichierr$,pos)+"TXT"
    if CopyFile(FichierR$,FICH$)
    Else
      MessageRequester("Information","Impossible de RESTAURer le fichier!"+#LF$+ fichier$+"sav")
    endif  
    FichierR$ = NextSelectedFileName()
  Wend
  DisableExplicit
endprocedure

procedure EFFACER()
  EnableExplicit
  protected FichierParDefaut$,filtre$,filtre, FichierM$
  FichierParDefaut$ = getCurrentDirectory()+"LEXIQUE_MOTS_FR2.TXT"   ; Répertoire et fichier par défaut qui seront affichés
  Filtre$ = "Fichiers Textes|*.txt"
  Filtre  = 0    ; utiliser  par défaut le premier des trois filtres possibles
  FichierM$ = OpenFileRequester("Choisissez un fichier à EFFACER", FichierParDefaut$, Filtre$, Filtre)
  DeleteFile(FichierM$ , #PB_FileSystem_Force)
  DisableExplicit
endprocedure

Procedure QuitHandler()
  End
EndProcedure
OpenWindow_1()
for i=4 to 10 
  AddGadgetItem(#NB_CAR,0,str(i) )
next
SetGadgetText(#NB_CAR,"10")
Lecture_Nom_Fichier_()
INIT_GEN(0) 
chargementmap(0)


BindMenuEvent(0,#RESTAURER, @RESTAURER())
BindMenuEvent(0,#EFFACER, @EFFACER())


BindMenuEvent(0,#FchierRep,  @Choix_Rep())
BindMenuEvent(0,#WEB_1,  @Choix_ASCII())
BindMenuEvent(0,#WEB_2, @Choix_UTF8())
BindMenuEvent(0,#QUITER, @QuitHandler())

BindgadgetEvent(#Efface,@Efface_Car())
BindgadgetEvent(#CONSONNE,@consonne())
BindgadgetEvent(#VOYELLE,@voyelle())
BindgadgetEvent(#EDITION_CAR,@edition_car())
BindgadgetEvent(#SOLUTION,@Solution())
BindgadgetEvent(#CHANGE_TOUT,@TIRAGEALEA())
Repeat
Until WaitWindowEvent(#Window_1) = #PB_Event_CloseWindow
; CloseConsole()
A+
Dernière modification par PAPIPP le dim. 17/févr./2019 11:28, modifié 1 fois.
Il est fort peu probable que les mêmes causes ne produisent pas les mêmes effets.(Einstein)
Et en logique positive cela donne.
Il est très fortement probable que les mêmes causes produisent les mêmes effets.
Avatar de l’utilisateur
Naheulf
Messages : 191
Inscription : dim. 10/mars/2013 22:22
Localisation : France

Re: Le Mot le plus long

Message par Naheulf »

Bonjour,
juste pour information, si vous voulez avoir un dictionnaire le plus complet possible allez faire un tour sur le site de Grammalecte. Avec le lien « Lexique 6.3 » tu pourras télécharger la liste de toutes les formes fléchies (les variantes des mots) du dictionnaire Hunspell (le dico qui sert dans Firefox, libre office, Linux…).

Après suppression des entrées qui ne sont pas des mots à proprement parler (Chiffres romains, abréviation familières, sigles, onomatopées), des colonnes inutiles et des doublons, il me reste une liste de 462 960 mots (5.64Mo en .txt). Il reste encore à supprimer tous les caractères non ASCII (ex : « œ » --> « oe », « à » --> « a » …), les tirets « - » puis éliminer les mots trop longs.

Si ça peut t’aider : Voici un petit lien Gist vers la liste que j’obtiens.
PAPIPP
Messages : 534
Inscription : sam. 23/févr./2008 17:58

Re: Le Mot le plus long

Message par PAPIPP »

Bonjour à tous
Merci Naheulf

Cela m’a permis de détecter une bogue et d’ajouter.
1) les mots dont le son est é, œ (o e dans l’o) (œdipe, œsophage).
2) les mots dont le son est eû ou œu nœud, œufs.

Voici le prg de mise en forme et de conversion UTF8 => ASCII .
(il prend moins de place qu’un fichier en Unicode).
Charger le fichier https://grammalecte.net/download.php?prj=fr
sous la rubrique Lexique 6.3 le fichier lexique-dicollecte-fr-v6.3.zip et décompressez.

Code : Tout sélectionner

FichierEnt1$="lexique-dicollecte-fr-v6.3.txt"
C9$=Chr(09)
If ReadFile(1, FichierEnt1$, #PB_UTF8 )   ; Si le fichier peut être lu , on continue...
Else
  MessageRequester("Information","Impossible d'ouvrir le fichier : "+FichierEnt1$)
  End
EndIf 
If CreateFile(12,"lexique-dicollecte-fr-ASCII.txt",#PB_Ascii)
Else
  MessageRequester("Information","Impossible de créer le fichier : "+ FichierSORT$)
  End
EndIf
While Eof(1) = 0          
  enr1$=ReadString(1) 
  nb09=CountString(enr1$,C9$)
  If nb09>10
    prem$=StringField(enr1$,2, C9$)
    WriteString(12,prem$+Chr(10),#PB_Ascii  )
  EndIf
Wend 
CloseFile(1)
CloseFile(12)
 End

Et le fichier corrigé suivant

Code : Tout sélectionner

Enumeration FormWindow
  #Window_1
EndEnumeration
; openconsole("Mots",#PB_Ascii  )
Enumeration FormGadget
  #TITRE
  #NB_CAR
  #VOYELLE
  #EDITION_CAR
  #Text_1
  #CONSONNE
  #CHANGE_TOUT
  #SOLUTION
  #SOLUT1
  #NomFic
  #Efface
  #NBFic
EndEnumeration

Enumeration FormMenu
  #FchierRep
  #WEB_1
  #Web_2
  #Quiter
  #EFFACER
  #RESTAURER
EndEnumeration

Enumeration FormFont
  #Font_Window_1_0
  #Font_Window_1_1
  #Font_Window_1_2
EndEnumeration

LoadFont(#Font_Window_1_0,"Arial", 28, #PB_Font_Bold)
LoadFont(#Font_Window_1_1,"Courier New", 40, #PB_Font_Bold)
LoadFont(#Font_Window_1_2,"Courier New", 9)


Procedure OpenWindow_1(x = 0, y = 0, width = 730, height = 800)
  OpenWindow(#Window_1, x, y, width, height, "", #PB_Window_SystemMenu | #PB_Window_MinimizeGadget)
  ;   SetWindowColor(#Window_1, RGB(208,208,208))
  CreateMenu(0, WindowID(#Window_1))
  MenuTitle("Choix_Dico")
  MenuItem(#FchierRep, "Fichier TXT en répertoire")
  MenuItem(#WEB_1, "Web ASCII=>LEXIQUE*.TXT")
  MenuItem(#Web_2, "Web UTF8=>LISTE*.TXT")
  MenuItem(#Quiter, "Quiter")
  MenuTitle("Fichier")
  MenuItem(#EFFACER, "Effacer *.TXT")
  MenuItem(#RESTAURER, "RESTAURer *.TXT")
  TextGadget(#TITRE, 40, 10, 650, 50, "L E   M O T    L E    P L U S    L O N G", #PB_Text_Center)
  SetGadgetFont(#TITRE, FontID(#Font_Window_1_0))
  ComboBoxGadget(#NB_CAR, 40, 100, 50, 20, #PB_ComboBox_Editable)
  ButtonGadget(#VOYELLE, 190, 190, 80, 30, "Voyelle")
  EditorGadget(#EDITION_CAR, 185, 60, 345, 70, #PB_Editor_WordWrap)
  SetGadgetFont(#EDITION_CAR, FontID(#Font_Window_1_1))
  TextGadget(#Text_1, 30, 80, 70, 20, "  Nb Car Max")
  ButtonGadget(#CONSONNE, 450, 190, 80, 30, "Consonne")
  ButtonGadget(#CHANGE_TOUT, 300, 190, 130, 30, "Change tout")
  ButtonGadget(#SOLUTION, 300, 230, 130, 30, "SOLUTION")
  EditorGadget(#SOLUT1, 10, 270, 700, 490)
  SetGadgetFont(#SOLUT1, FontID(#Font_Window_1_2))
  TextGadget(#NomFic, 50, 150, 620, 20, "Nom du fichier utilisé :", #PB_Text_Center)
  ButtonGadget(#Efface, 570, 90, 80, 30, "Efface")
  TextGadget(#NBFic, 20, 240, 210, 20, "")
EndProcedure




Structure mot
  StructureUnion
    NOMC.s{26}
    Lettre.s{1}[26]
  EndStructureUnion
EndStructure 
Structure colonne 
  car.mot
EndStructure
Structure tabres 
  numelem.l
  ligne.colonne[255] ;;;  le max est car Combin(10,5) =252  si l(on devait passer à 12 lettres il faudrait passer à Combin(12,6)=924 
EndStructure  

Global FICHIER$
Global Path_Map$
Global NewMap moti.string()
Global NewMap mot4.string()
Global NewMap mot5.string()
Global NewMap mot6.string()
Global NewMap mot7.string()
Global NewMap mot8.string()
Global NewMap mot9.string()
Global NewMap motx.string()
Global NewMap mots.string()
Global NewMap motrouve.string()
Global Aphabet.mot
Global flag_dico=1
ProcedureDLL.q _nbcycl()
  !RDTSC
  ProcedureReturn
EndProcedure
Macro stock(_n)
  ;   if len(mot$)<26   ;;;; ici pas de limite pour mémoriser le mots de plus de 10 lettres alors qu'il ne sont pas utilisés
  ;;;;;    pour accélérer on peut réduire <13
  If Len(mot$)<12
    If FindMapElement(mot#_n(),nomt\NOMC)
      If FindString(mot#_n(nomt\NOMC)\s,mot$)
      Else  
        mot#_n(nomt\NOMC)\s=mot#_n()\s+"/"+motm$
      EndIf  
    Else
      mot#_n(nomt\NOMC)\s=nomt\NOMC+"/"+motm$
    EndIf
  EndIf
EndMacro 

Macro _q_t
  "
EndMacro
Macro TestMap(__n)
  a$=_q_t#__n#_q_t
  ficMap$=Path_Map$+"Mot_"+a$+".txt"
  If FileSize(FicMap$)<0
    resulta *0
  Else
    resulta *1
  EndIf 
EndMacro

Macro Ecrire(__n)
  a$=_q_t#__n#_q_t
  
  If FileSize(Path_Map$)=-1
    If CreateDirectory(Path_Map$) 
    Else
      MessageRequester("Information","Impossible de créer le répertoire  Mapx.txt!"+#LF$+ Path_Map$)
    EndIf  
  EndIf
  
  ficMap$=Path_Map$+"Mot_"+a$+".txt"
  If FileSize(FicMap$)=>0
    RenameFile(ficMap$,ficMap$+"sav")
  EndIf  
  If CreateFile(__n, ficMap$)         ; crée un nouveau fichier texte ou recrée une fichier texte vide s'il existe déjà ...
    ResetMap(mot#__n())      
    While NextMapElement(mot#__n()) 
      WriteStringN(__n, mot#__n()\s)
    Wend
    CloseFile(__n)                       ; ferme le fichier précédemment ouvert et enregistre les données
  Else
    MessageRequester("Information","Impossible de créer le fichier Mapx.txt!"+#LF$+ ficMap$)
  EndIf
EndMacro 

Procedure creation_Fichier(fichierm$)
  nom_fichier$=GetCurrentDirectory()+"_Nom_Fichier_"
  If  CreateFile(5,nom_fichier$)
    WriteString(5,Fichierm$+Chr(10),#PB_Ascii )
    CloseFile(5)
  Else 
    MessageRequester("Information","Impossible de creer le fichier ASCII"+#LF$+ FichierM$)
  EndIf
EndProcedure
Procedure Lecture_Nom_Fichier_()
  nom_fichier$=GetCurrentDirectory()+"_Nom_Fichier_"
  If FileSize(nom_fichier$)>0
    If  ReadFile(5,nom_fichier$)  ;;; fichier avec un seul enregistrement donc pas de boucle
      FICHIER$=ReadString(5)     
      CloseFile(5)               ; Ferme le fichier précédemment créé ou ouvert
    Else
      MessageRequester("Information","Impossible d'ouvrir le fichier!=_Nom_Fichier_")
    EndIf
  Else
    fichier$=""
  EndIf
EndProcedure


;;;;****************** initialisation générale pour les cas ou les fichiers ne seraient pas créés ********
Procedure INIT_GEN(val);; val pour une éventuelle  utilisation avec thread 
  EnableExplicit 
  Protected result, resulta,resultb,resultc, mot$,i,lmot,ii,a$,x,s,init_dic$,FichierParDefaut$,Filtre$
  Protected filtre,prgpb$,Compilateur,Sortie$,code_ret,prgexec$,exec_dico
  Protected Path_Fic$,file$,files$,ficMap$,jjj,MOTM$,nbtir
  
  Define Nomt.mot
  Define Nom.mot
  Dim tabnom.s(25)
  lecture_Nom_fichier_()
  ClearMap(motrouve())
  ClearMap( moti.string())
  ClearMap( mot4.string())
  ClearMap( mot5.string())
  ClearMap( mot6.string())
  ClearMap( mot7.string())
  ClearMap( mot8.string())
  ClearMap( mot9.string())
  ClearMap( motx.string())
  ClearMap( mots.string())
  If FileSize(Fichier$) <0
    If fichier$=""
      Fichier$ = GetCurrentDirectory()+"LEXIQUE_MOTS_FR2.TXT" 
      creation_fichier(fichier$)
    EndIf
    InitNetwork()
    result=ReceiveHTTPFile("http://www.lexique.org/listes/liste_mots.txt",fichier$)
  Else
    If CopyFile(fichier$, fichier$+"sav") 
      result=1
    Else
      result=0
      MessageRequester("Information","Impossible de créer le fichier!"+#LF$+ fichier$+"sav")
    EndIf
  EndIf 
  Path_Fic$=GetPathPart(FICHIER$)
  If path_fic$=""
    files$=GetFilePart(FICHIER$,#PB_FileSystem_NoExtension)
  Else
    files$=GetFilePart(FICHIER$,#PB_FileSystem_NoExtension)+"\"
  EndIf 
  file$=GetFilePart(FICHIER$)
  path_map$=Path_Fic$+files$
  SetGadgetText(#NomFic,"FICHIER UTILISE : "+fichier$)
  ;;; Test de la présence des fichiers MAP*.txt
  resulta=1
;   if flag_dico=1   
    For jjj=1 To 11
      Select jjj
        Case 1 To 3
          TestMap(i)
        Case 4 
          testMap(4)
        Case 5
          testMap(5)
        Case 6 
          testMap(6)
        Case 7
          testMap(7)
        Case 8
          testMap(8)
        Case 9
          testMap(9)
        Case 10
          TestMAp(x)
        Default
          TestMap(s)
      EndSelect      
    Next
;   else 
;     resulta=0
;   endif
  If result And Not resulta
;     flag_dico=1
    If ReadFile(0, fichier$, #PB_Ascii  )   ; Si le fichier peut être lu , on continue...
      While Eof(0) = 0                      ; Boucle tant que la fin du fichier n'est pas atteinte. (Eof = 'End Of File') 
        
        MOT$=StringField(ReadString(0),1,Chr(09))
        motm$=mot$
        If CountString(mot$,Chr($0153))>0
          mot$=ReplaceString(motm$,Chr($0153),"OE")
        EndIf  
        nbtir=CountString(mot$,"-")
        If nbtir>0
          MOT$=RemoveString(MOTm$,"-")
          ;           if len(mot$)<11
          ;             printn(mot$+"   "+motm$+"  "+str(len(motm$)))
          ;            endif 
        EndIf  
        
        If FindString(Mot$," ") =0 ;;;or FindString(Mot$,chr(9))=0
          nom\NOMC=UCase(MOT$)
          For i=0 To Len(nom\NOMC)-1
            Select PeekA(Ascii(nom\lettre[i]))
              Case 32 To 63
                nom\lettre[i]=""
              Case 192 To 197
                nom\lettre[i]="A"
              Case 199
                nom\lettre[i]="C"
              Case 200 To 203
                nom\lettre[i]="E"
              Case 204 To 207
                nom\lettre[i]="I"
              Case 210 To 214
                nom\lettre[i]="O"
              Case 217 To 220
                nom\lettre[i]="U"
              Case 255,221,253
                nom\lettre[i]="Y"
            EndSelect    
            tabnom(i)=nom\Lettre[i]
          Next
          SortArray(tabnom(),#PB_Sort_Ascending,0,Len(nom\NOMC)-1 )
          nomt\NOMC=""
          For i=0 To Len(nom\NOMC)-1
            nomt\Lettre[i]=tabnom(i)
          Next
          lmot=Len(mot$)
          Select lmot
            Case 1 To 3
              stock(i)
            Case 4
              stock(4)
            Case 5
              stock(5)  
            Case 6
              stock(6)          
            Case 7
              stock(7)
            Case 8
              stock(8)
            Case 9
              stock(9)
            Case 10 
              stock(x)
            Case 11 To 25
              stock(s)
          EndSelect
        Else
        EndIf
        
      Wend
      CloseFile(0); Ferme le fichier précédemment ouvert
                  ;;;; ********************  remettre l'initialisation dictionnaire à 0 
                  ;    SetGadgetState(#Init_Dic,#PB_CheckBox_Unchecked)
                  ;    flag_dic=0
                  ;;;;********************* sauve les map sur des fichiers **************************
      For ii=3 To 25
        Select ii
          Case 3
            i=3
            ecrire (i)
          Case 4
            ecrire(4)
          Case 5
            ecrire(5)
          Case 6
            ecrire(6)
          Case 7
            ecrire(7)
          Case 8
            ecrire(8)
          Case 9
            ecrire(9)
          Case 10
            x=ii
            ecrire(x)
          Case 11 To 25
            s=ii
            ecrire(s)
        EndSelect    
      Next
    Else
      MessageRequester("Information","Impossible d'ouvrir le fichier!")
    EndIf
  EndIf
  DisableExplicit
  creation_Fichier(Fichier$)
EndProcedure
;******************  Moteur du mot le plus long ************************* 

Macro Lire(__n)
  a$=_q_t#__n#_q_t
  ficMap$=Path_Map$+"Mot_"+a$+".txt"
  If ReadFile(__n, ficMap$,#PB_File_SharedRead )   ; Si le fichier peut être lu , on continue...
    While Eof(__n) = 0                 
      MOT$=ReadString(__n)
      pos=__n
      If __n<4 Or __n>9
        pos = FindString(mot$, "/")-1
      EndIf
      clef$=Left(mot$,pos)
      mot#__n(clef$)\s=mot$
    Wend
    CloseFile(__n)                       ; ferme le fichier précédemment ouvert et enregistre les données
  Else
    MessageRequester("Information","Impossible de Lire le fichier!"+#LF$+ FicMap$)
  EndIf
EndMacro  
Procedure AlphabetVoyelleConsonne(val);; val pour une éventuelle  utilisation avec thread
  EnableExplicit
  Protected VOYELLE.mot,CONSONNE.mot,i,c$
  For i=0 To 25
    c$= Chr(65+i)
    Select c$
      Case "A","E","I","O","U","Y"
        voyelle\NOMC+c$
      Default
        consonne\NOMC+c$
    EndSelect
  Next  
  Aphabet.mot\NOMC=voyelle\NOMC+consonne\NOMC
  DisableExplicit
EndProcedure
;;;***************************************************
Procedure chargementMap(val);; val pour une éventuelle  utilisation avec thread
  EnableExplicit
  Protected ii,i,x,s,a$,fichier$,mot$,pos,clef$,FicMap$
  AlphabetVoyelleConsonne(0)
  For ii=3 To 25
    Select ii   ;;;; Les mots <4 lettres et >10 lettres ne sont pas utilisés dans le prg il sont mis en commentaire
                ;           case 3
                ;             i=3
                ;             Lire (i)
      Case 4
        Lire(4)
      Case 5
        Lire(5)
      Case 6
        Lire(6)
      Case 7
        Lire(7)
      Case 8
        Lire(8)
      Case 9
        Lire(9)
      Case 10
        x=ii
        Lire(x)
        ;           case 11 to 25
        ;             s=ii
        ;             Lire(s)
    EndSelect    
  Next
  DisableExplicit
EndProcedure  


;************************ les deux Procédure de degroupement **********************************
EnableExplicit
Declare comb_exp0(N,gr,ind)
Procedure Comb_exp(N,GR,chaine$)
  EnableExplicit
  Global clef.mot\NOMC=chaine$
  Global  RES.tabres
  Define res0.tabres
  CopyMemory(res0,res,SizeOf(tabres))
  res\numelem=1
 
  Global Dim tab(N)
  comb_exp0(N,Gr,1);
  DisableExplicit
EndProcedure
Procedure comb_exp0(N,gr,ind);;;,Array tab(1))
  EnableExplicit
  Protected i,j,lig
  Global GP0
  If ind=1
    gp0=gr
  EndIf 
  If gr<>0
    For i=tab(ind-1)+1 To N
      tab(ind)=i
      comb_exp0(N,gr-1,ind+1)
    Next 
  Else
    lig=res\numelem
    For j=1 To GP0
      res\ligne[lig]\car\Lettre[j-1] = clef\Lettre[tab(j)-1]
    Next
    res\numelem+1
  EndIf
  DisableExplicit
EndProcedure
DisableExplicit
;;;******************** Procédure de tri par lettre ***********************************
Procedure.s trilettre(entree$)
  EnableExplicit
  Protected entree.mot,i,sortiet.mot
  Entree.mot\NOMC=entree$
  Dim tabnom.s(25)
  
  For i=0 To Len(Entree\NOMC)-1
    tabnom(i)=Entree\Lettre[i]
  Next
  
  SortArray(tabnom(),#PB_Sort_Ascending,0,Len(Entree\NOMC)-1 )
  
  Define Sortiet.mot\NOMC=""
  For i=0 To Len(Entree\NOMC)-1
    Sortiet\Lettre[i]=tabnom(i)
  Next
  ProcedureReturn Sortiet\NOMC 
  DisableExplicit
EndProcedure
Macro edite(__n)
  sort$=""
  a$=_q_t#__n#_q_t
  ;    fichier$="Mot_"+a$+".txt"
  b$=a$
  Select a$
    Case "x"
      nbcar=10
      b$=">10"    
    Case "i"
      nbcar=3
      b$="<4"
    Case "s"
      nbcar= 11
      b$=">10"
    Default
      nbcar=Val(a$)
  EndSelect    
  If nbli=1
    titre$="Mot(s) de " +b$+ " lettres="+Chr(10)
    mot_de_x_lettre$=""
    lmin=Len(mot_de_x_lettre$)
  EndIf  
  ;         res$=mot4(res\ligne[nbli]\car\NOMC)\s
  res$=mot#__n (res\ligne[nbli]\car\NOMC)\s
  If res$<>"" And motrouve(res$)\s=""
    mot_de_x_lettre$ + Right(res$,Len(res$)-nbcar);+"/"
                                                  ;     if len(mot_de_x_lettre$)%100>90
                                                  ;       mot_de_x_lettre$+chr(10)
                                                  ;     endif  
    lmot=Len(mot_de_x_lettre$)
    motrouve(res$)\s=res$
  EndIf 
  If nbli=nblign And lmot>lmin
    sort$=mot_de_x_lettre$
    lsort=Len(sort$)
    nbslash = CountString(sort$, "/")
    ;     nbcount=96/(nbcar+1)
    nbcount=96/(nbcar+1)
    nbocc=nbslash/nbcount
    For o=1 To nbocc
      pos=1+((nbcar+1)*nbcount*o)
      ;     ReplaceString(bbb$,"/",chr(10), #PB_String_InPlace,pos,1)
      ReplaceString(sort$,"/",Chr(10), #PB_String_InPlace,pos,1)
    Next
    d$=ReplaceString(sort$,Chr(10),Chr(10)+"/")
    nbmot=CountString(d$,"/")
    nbmottotal+ nbmot
    ltitre=Len(Str(nbmot)+" "+titre$)
    sort$=Str(nbmot)+" "+titre$+d$
    
    If Len(sort$)>ltitre+3
      SetGadgetText(#SOLUT1,GetGadgetText(#SOLUT1)+sort$+Chr(10)+Chr(10))
    EndIf  
  EndIf  
EndMacro 
;;;;************ simulation du tirage des letrres ****************
Procedure TIRAGEALEA()
  EnableExplicit
  Global cartret.mot\NOMC=""
  Global cartire.mot\NOMC=""
  
  Protected nbvoyt=0, nb_atirer, t,rnd
  nb_atirer=Val(GetGadgetText(#NB_CAR))
  For t=1 To nb_atirer
    rnd=Random(Len(Aphabet\NOMC)-1,0)
    If rnd<6
      nbvoyt+1
    EndIf  
    If t=nb_atirer And nbvoyt=0
      cartire.mot\NOMC+Aphabet\Lettre[Random(5,0)]
      nbvoyt+1
    Else
      cartire.mot\NOMC+Aphabet\Lettre[rnd]
    EndIf 
  Next
  SetGadgetText(#EDITION_CAR,cartire\NOMC)
  DisableExplicit
EndProcedure

Procedure edition_car()
  EnableExplicit
  Static fin.q,deb.q,fin2.q
  Protected carm.mot\NOMC= GetGadgetText(#EDITION_CAR), car.mot,i,ascii,lcar
  car.mot\NOMC=UCase(carm\NOMC)
  lcar=Len(car.mot\NOMC)
  If lcar > Val(GetGadgetText(#NB_CAR))
    SetGadgetText(#EDITION_CAR,Left(GetGadgetText(#EDITION_CAR),Val(GetGadgetText(#NB_CAR))))
  EndIf  
  For i=0 To lcar-1
    ascii=PeekA(Ascii(car\lettre[i]))
    Select ascii
      Case 192 To 197
        car\lettre[i]="A"
      Case 199
        car\lettre[i]="C"
      Case 200 To 203
        car\lettre[i]="E"
      Case 204 To 207
        car\lettre[i]="I"
      Case 210 To 214
        car\lettre[i]="O"
      Case 217 To 220
        car\lettre[i]="U"
      Case 255,221,253
        car\lettre[i]="Y"
      Case 65 To 90
      Default
        car\NOMC = ReplaceString(car\NOMC, car\Lettre[i], "" ) 
    EndSelect    
  Next
  If car\NOMC<>carm\NOMC
    car\NOMC=UCase(car\NOMC)
    SetGadgetText(#EDITION_CAR,car\NOMC)
  EndIf
  cartire.mot\NOMC=car\NOMC
  DisableExplicit
EndProcedure
Procedure voyelle()
  EnableExplicit
  Protected rnd,tirevoy$,nb_car
  rnd=Random(5,0)
  tirevoy$=Aphabet\Lettre[rnd]
  nb_car=Val(GetGadgetText(#NB_CAR))
  SetGadgetText(#EDITION_CAR,Left(GetGadgetText(#EDITION_CAR)+tirevoy$,nb_car))  
  DisableExplicit
EndProcedure  
Procedure consonne()
  EnableExplicit
  Protected rnd,tirecon$,nb_car
  rnd=Random(25,6)
  tirecon$=Aphabet\Lettre[rnd]
  nb_car=Val(GetGadgetText(#NB_CAR))
  SetGadgetText(#EDITION_CAR,Left(GetGadgetText(#EDITION_CAR)+tirecon$,nb_car))  
  DisableExplicit
EndProcedure  

Procedure Efface_Car()
  SetGadgetText(#EDITION_CAR,"")
EndProcedure

Procedure solution()
  EnableExplicit
  Protected gredt,jj,group,nblign,lnomc,nbli,sort$,a$,b$,nbcar,titre$,mot_de_x_lettre$,lmin,res$,lmot,lsort
  Protected nbslash,  nbcount,nbocc,o,pos,d$,nbmot,ltitre,nbmottotal
  ;;;; exploitation des différents regroupement ************************
  ;;; ******* Il faut trier les lettres avant de faire la recherche 
  edition_car()
  cartret.mot\NOMC=trilettre(cartire.mot\NOMC)
  lnomc=Len(cartret.mot\NOMC)
  If lnomc>10
    ;   MessageRequester("Mot <10lettres ", "limité à 10 lettres"+chr(10)+cartret.mot\NOMC)
    lnomc=10
    cartret.mot\NOMC=Left(cartret.mot\NOMC,10)
  EndIf 
  ClearMap(motrouve()) 
  SetGadgetText(#SOLUT1,"")
  nbmottotal=0
  For group=lnomc To 4 Step -1
    Comb_exp(lnomc,group,cartret.mot\NOMC)
    nblign=res\numelem-1
    For nbli=1 To nblign
      ;;;;******************* Cherche *******************
      Select group;;;;EEQRSTUU
        Case 10
          edite(x)
        Case 9
          edite(9)
        Case 8
          edite(8)
        Case 7
          edite(7)
        Case 6
          edite(6)
        Case 5
          edite(5)
        Case 4
          edite(4)
      EndSelect    
    Next 
  Next
  SetGadgetText(#NBFic,"Nb de Mots trouvés : "+Str(nbmottotal))
  DisableExplicit
EndProcedure

Procedure Choix_Rep()
  EnableExplicit 
  Protected FichierParDefaut$,filtre$,filtre,FichierM$
  FichierParDefaut$ = GetCurrentDirectory()+"LEXIQUE_MOTS_FR2.TXT"   ; Répertoire et fichier par défaut qui seront affichés
  Filtre$ = "Fichiers Textes|*.txt"
  Filtre  = 0    ; utiliser  par défaut le premier des trois filtres possibles
  FichierM$ = OpenFileRequester("Choisissez un fichier à charger", FichierParDefaut$, Filtre$, Filtre)
  creation_fichier(FichierM$)
;   flag_dico=0
  INIT_GEN(0)
  chargementMap(0)
  DisableExplicit
EndProcedure

Procedure choix_ASCII()
  EnableExplicit
  Protected FichierM$
  FichierM$=GetCurrentDirectory()+"LEXIQUE_MOTS_FR2.TXT" 
  InitNetwork()
  ;   result=ReceiveHTTPFile("http://www.pallier.org/extra/liste.de.mots.francais.frgut.txt",FichierM$)
  If ReceiveHTTPFile("http://www.lexique.org/listes/liste_mots.txt",FichierM$)
    If CopyFile(FichierM$, FichierM$+"sav") 
    Else
      MessageRequester("Information","Impossible de copier le fichier!"+#LF$+ FichierM$+"sav")
    EndIf
  Else 
    MessageRequester("Information","Impossible de recevoir le fichier!"+#LF$+ FichierM$)
  EndIf
  creation_fichier(FichierM$)
  INIT_GEN(0)
  chargementMap(0)
  DisableExplicit
EndProcedure

Procedure choix_UTF8()
  EnableExplicit
  Protected fichierUTF8$,mot$,FichierM$
  fichierUTF8$=GetCurrentDirectory()+"LISTE_MOTS_FRANCAIS_UTF8.TXT"
  FichierM$=GetCurrentDirectory()+"LISTE_MOTS_FRANCAIS_ASCII.TXT"
  InitNetwork()
  If ReceiveHTTPFile("http://www.pallier.org/extra/liste.de.mots.francais.frgut.txt",fichierUTF8$)
    ;     result=ReceiveHTTPFile("http://www.lexique.org/listes/liste_mots.txt",FichierM$)
    If CopyFile(fichierUTF8$, fichierUTF8$+"sav")  
      If ReadFile(10, fichierUTF8$, #PB_UTF8   )   ; Si le fichier peut être lu , on continue...
        If CreateFile(100, FichierM$, #PB_Ascii  )
          While Eof(10) = 0                      ; Boucle tant que la fin du fichier n'est pas atteinte. (Eof = 'End Of File') 
            MOT$=ReadString(10)
            WriteStringN(100, mot$) 
          Wend
        Else
          MessageRequester("Information","Impossible de creer le fichier ASCII"+#LF$+ FichierM$)
        EndIf
        CloseFile(100)
        If CopyFile(FichierM$, FichierM$+"sav") 
        Else
          MessageRequester("Information","Impossible de copier le fichier!"+#LF$+ FichierM$+"sav")
        EndIf
      Else
        MessageRequester("Information","Impossible de lire le fichier UTF8"+#LF$+ fichierUTF8$)
      EndIf
    Else
      MessageRequester("Information","Impossible de copier le fichier!"+#LF$+ fichierUTF8$+"sav")
      
    EndIf
  Else
    MessageRequester("Information","Impossible de recevoir le fichier "+#LF$+ fichierUTF8$)
  EndIf
  creation_fichier(FichierM$)
  INIT_GEN(0)
  chargementMap(0)
  DisableExplicit
EndProcedure

Procedure RESTAURER()
  EnableExplicit
  Protected FichierParDefaut$,filtre$,filtre,FichierR$,pos,FICH$
  FichierParDefaut$ = GetCurrentDirectory()+"LEXIQUE_MOTS_FR2.TXTsav"   ; Répertoire et fichier par défaut qui seront affichés
  Filtre$ = "Fichiers Textes|*.txtsav"
  Filtre  = 0    ; utiliser  par défaut le premier des trois filtres possibles
  FichierR$ = OpenFileRequester("Choisissez un fichier à RESTAURer", FichierParDefaut$, Filtre$, Filtre, #PB_Requester_MultiSelection)
  While FichierR$
    pos=FindString(FichierR$,".txt",1,#PB_String_NoCase)
    FICH$=Left(Fichierr$,pos)+"TXT"
    If CopyFile(FichierR$,FICH$)
    Else
      MessageRequester("Information","Impossible de RESTAURer le fichier!"+#LF$+ fichier$+"sav")
    EndIf  
    FichierR$ = NextSelectedFileName()
  Wend
  DisableExplicit
EndProcedure

Procedure EFFACER()
  EnableExplicit
  Protected FichierParDefaut$,filtre$,filtre, FichierM$
  FichierParDefaut$ = GetCurrentDirectory()+"LEXIQUE_MOTS_FR2.TXT"   ; Répertoire et fichier par défaut qui seront affichés
  Filtre$ = "Fichiers Textes|*.txt"
  Filtre  = 0    ; utiliser  par défaut le premier des trois filtres possibles
  FichierM$ = OpenFileRequester("Choisissez un fichier à EFFACER", FichierParDefaut$, Filtre$, Filtre)
  DeleteFile(FichierM$ , #PB_FileSystem_Force)
  DisableExplicit
EndProcedure

Procedure QuitHandler()
  End
EndProcedure
OpenWindow_1()
For i=4 To 10 
  AddGadgetItem(#NB_CAR,0,Str(i) )
Next
SetGadgetText(#NB_CAR,"10")
Lecture_Nom_Fichier_()
INIT_GEN(0) 
chargementmap(0)


BindMenuEvent(0,#RESTAURER, @RESTAURER())
BindMenuEvent(0,#EFFACER, @EFFACER())


BindMenuEvent(0,#FchierRep,  @Choix_Rep())
BindMenuEvent(0,#WEB_1,  @Choix_ASCII())
BindMenuEvent(0,#WEB_2, @Choix_UTF8())
BindMenuEvent(0,#QUITER, @QuitHandler())

BindGadgetEvent(#Efface,@Efface_Car())
BindGadgetEvent(#CONSONNE,@consonne())
BindGadgetEvent(#VOYELLE,@voyelle())
BindGadgetEvent(#EDITION_CAR,@edition_car())
BindGadgetEvent(#SOLUTION,@Solution())
BindGadgetEvent(#CHANGE_TOUT,@TIRAGEALEA())
Repeat
Until WaitWindowEvent(#Window_1) = #PB_Event_CloseWindow
; CloseConsole()


A+
Il est fort peu probable que les mêmes causes ne produisent pas les mêmes effets.(Einstein)
Et en logique positive cela donne.
Il est très fortement probable que les mêmes causes produisent les mêmes effets.
Avatar de l’utilisateur
SPH
Messages : 4722
Inscription : mer. 09/nov./2005 9:53

Re: Le Mot le plus long

Message par SPH »

@PAPPIP :

Voici un dictionnaire francais tres complet :

http://xmas.free.fr/dico/dico-french.zip
http://HexaScrabble.com/
!i!i!i!i!i!i!i!i!i!
!i!i!i!i!i!i!
!i!i!i!
//// Informations ////
Intel Core i7 4770 64 bits - GTX 650 Ti
Version de PB : 6.00 - 64 bits
Répondre