PureBasic

Forums PureBasic
Nous sommes le Jeu 18/Avr/2019 22:03

Heures au format UTC + 1 heure




Poster un nouveau sujet Répondre au sujet  [ 14 messages ] 
Auteur Message
 Sujet du message: Le Mot le plus long
MessagePosté: Lun 28/Jan/2019 12:47 
Hors ligne

Inscription: Sam 23/Fév/2008 17:58
Messages: 553
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:
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+

_________________
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.


Dernière édition par PAPIPP le Mar 29/Jan/2019 7:37, édité 1 fois.

Haut
 Profil  
Répondre en citant le message  
 Sujet du message: Re: Le Mot le plus long
MessagePosté: Lun 28/Jan/2019 14:05 
Hors ligne
Avatar de l’utilisateur

Inscription: Dim 02/Oct/2011 16:17
Messages: 2106
Localisation: 50200 Coutances
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 GT 640 : Processeur AMD FX 6300 6 cœurs 12 threads 3,50 GHz PB 5.62, 5.70 LTS
Un homme doit être poli, mais il doit aussi être libre !


Haut
 Profil  
Répondre en citant le message  
 Sujet du message: Re: Le Mot le plus long
MessagePosté: Ven 01/Fév/2019 4:05 
Hors ligne
Avatar de l’utilisateur

Inscription: Jeu 08/Déc/2005 5:19
Messages: 935
Localisation: Guadeloupe
Hello,
Tout cela a l'air très intéressant !

J'ai un soucis ligne 253
Code:
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 !


Haut
 Profil  
Répondre en citant le message  
 Sujet du message: Re: Le Mot le plus long
MessagePosté: Ven 01/Fév/2019 8:46 
Hors ligne
Avatar de l’utilisateur

Inscription: Dim 02/Oct/2011 16:17
Messages: 2106
Localisation: 50200 Coutances
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 GT 640 : Processeur AMD FX 6300 6 cœurs 12 threads 3,50 GHz PB 5.62, 5.70 LTS
Un homme doit être poli, mais il doit aussi être libre !


Haut
 Profil  
Répondre en citant le message  
 Sujet du message: Re: Le Mot le plus long
MessagePosté: Ven 01/Fév/2019 9:09 
Hors ligne

Inscription: Sam 23/Fév/2008 17:58
Messages: 553
@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.


Haut
 Profil  
Répondre en citant le message  
 Sujet du message: Re: Le Mot le plus long
MessagePosté: Ven 01/Fév/2019 10:06 
Hors ligne

Inscription: Sam 08/Fév/2014 15:19
Messages: 1521
Citation:
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:

_________________
http://mdacme.com


Haut
 Profil  
Répondre en citant le message  
 Sujet du message: Re: Le Mot le plus long
MessagePosté: Ven 01/Fév/2019 10:55 
Hors ligne

Inscription: Sam 23/Fév/2008 17:58
Messages: 553
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.

Citation:
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.


Haut
 Profil  
Répondre en citant le message  
 Sujet du message: Re: Le Mot le plus long
MessagePosté: Ven 01/Fév/2019 16:15 
Hors ligne

Inscription: Ven 29/Juin/2007 17:50
Messages: 3315
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...)


Haut
 Profil  
Répondre en citant le message  
 Sujet du message: Re: Le Mot le plus long
MessagePosté: Sam 02/Fév/2019 2:16 
Hors ligne
Avatar de l’utilisateur

Inscription: Jeu 08/Déc/2005 5:19
Messages: 935
Localisation: Guadeloupe
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 !


Haut
 Profil  
Répondre en citant le message  
 Sujet du message: Re: Le Mot le plus long
MessagePosté: Sam 02/Fév/2019 15:06 
Hors ligne

Inscription: Sam 23/Fév/2008 17:58
Messages: 553
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:
; ; --- 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.


Haut
 Profil  
Répondre en citant le message  
 Sujet du message: Re: Le Mot le plus long
MessagePosté: Sam 02/Fév/2019 16:32 
Hors ligne

Inscription: Sam 23/Fév/2008 17:58
Messages: 553
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.
Citation:
LEICNESCRA


Résultats /

Citation:
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:

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+

_________________
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.


Dernière édition par PAPIPP le Dim 17/Fév/2019 11:28, édité 1 fois.

Haut
 Profil  
Répondre en citant le message  
 Sujet du message: Re: Le Mot le plus long
MessagePosté: Sam 16/Fév/2019 9:44 
Hors ligne
Avatar de l’utilisateur

Inscription: Dim 10/Mar/2013 22:22
Messages: 25
Localisation: France
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.


Haut
 Profil  
Répondre en citant le message  
 Sujet du message: Re: Le Mot le plus long
MessagePosté: Lun 18/Fév/2019 0:39 
Hors ligne

Inscription: Sam 23/Fév/2008 17:58
Messages: 553
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:
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:
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.


Haut
 Profil  
Répondre en citant le message  
 Sujet du message: Re: Le Mot le plus long
MessagePosté: Lun 18/Fév/2019 6:24 
Hors ligne
Avatar de l’utilisateur

Inscription: Mer 09/Nov/2005 9:53
Messages: 3896
@PAPPIP :

Voici un dictionnaire francais tres complet :

http://xmas.free.fr/dico/dico-french.zip

_________________
http://xmas.free.fr/
!i!i!i!i!i!i!i!i!i!
!i!i!i!i!i!i!
!i!i!i!
//// Informations ////
Portable LENOVO ideapad 110-17ACL 64 bits
Version de PB : 5.70LTS - 32 bits


Haut
 Profil  
Répondre en citant le message  
Afficher les messages postés depuis:  Trier par  
Poster un nouveau sujet Répondre au sujet  [ 14 messages ] 

Heures au format UTC + 1 heure


Qui est en ligne

Utilisateurs parcourant ce forum: Aucun utilisateur enregistré et 2 invités


Vous ne pouvez pas poster de nouveaux sujets
Vous ne pouvez pas répondre aux sujets
Vous ne pouvez pas éditer vos messages
Vous ne pouvez pas supprimer vos messages

Rechercher:
Aller à:  

 


Powered by phpBB © 2008 phpBB Group | Traduction par: phpBB-fr.com
subSilver+ theme by Canver Software, sponsor Sanal Modifiye