IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)
Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

Contribuez Pascal Discussion :

Recherche d'anagrammes dans une liste


Sujet :

Contribuez Pascal

  1. #1
    Rédacteur/Modérateur

    Avatar de Roland Chastain
    Homme Profil pro
    Enseignant
    Inscrit en
    décembre 2011
    Messages
    3 825
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 48
    Localisation : France, Moselle (Lorraine)

    Informations professionnelles :
    Activité : Enseignant

    Informations forums :
    Inscription : décembre 2011
    Messages : 3 825
    Points : 13 668
    Points
    13 668
    Billets dans le blog
    8
    Par défaut Recherche d'anagrammes dans une liste
    Bonjour !

    J'ai écrit un petit programme qui cherche les anagrammes d'un mot donné.

    Je me suis servi d'une liste de mots français trouvée .

    Pour reconnaître les anagrammes, le programme convertit les chaînes de caractères en ensembles.

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    type
      tSetOfChar = set of char;
     
    function StrToSet(const pS: string): tSetOfChar;
    var
      i: integer;
    begin
      result := [];
      for i := 1 to Length(pS) do result := result + [pS[i]];
    end;
    L'inconvénient de cette méthode, c'est que tous les mots composés des mêmes lettres sont comptés comme des anagrammes (même si par exemple une lettre est présente une fois dans un mot et deux fois dans l'autre).

    En revanche, j'ai été surpris par la vitesse d'exécution. Le programme lisant "bêtement" les 336 000 entrées de la liste, je m'attendais à ce que ça soit long mais en fait il ne faut qu'une seconde ou deux.

    Je propose ce programme comme un premier essai. Améliorations ou variantes bienvenues !

    Votre mot ? rameau
    amure
    amurer
    amurera
    armure
    emmura
    emmurera
    maure
    muera
    murera
    murmurera
    rameau
    ramereau
    rameur
    ramure
    remua
    remuera

  2. #2
    Membre éprouvé
    Avatar de Dr.Who
    Inscrit en
    septembre 2009
    Messages
    980
    Détails du profil
    Informations personnelles :
    Âge : 42

    Informations forums :
    Inscription : septembre 2009
    Messages : 980
    Points : 1 286
    Points
    1 286
    Par défaut
    Petite amélioration qui permet de ne trouver que les anagrammes stricte (même longueur et même nombre de lettres)
    tout en conservant des performances de l'ordre de 0.5 a 1 sec selon les machines sur compilo Delphi 2009.

    modification de la structure de comparaison (TCharWord)
    modification de la fonction de comparaison (isAnagramme)
    amélioration de l'affichage et choix pour quitter ou recommencer

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    program Anagrammes;
     
    {$AppType Console}
     
    uses Windows, SysUtils;
     
    type
      TCharWord = record
         len   : integer; // longueur du mot
         chars : array['a'..'z'] of byte; // total des lettres du mot
      end;
     
    // convertis un mot en TCharWord
    function CharWord(aWord: string): TCharWord;
    var C : char;
        X : integer;
    begin
      // recupération de la longueur du mot
      result.len := Length(aWord);
      // raz du tableau de compteur
      for C := 'a' to 'z' do
        result.chars[C] := 0;
      // remplissage
      for X := 1 to result.len do
        inc(result.chars[aWord[X]]);
    end;
     
    // comparaison de deux mots, est-ce un anagramme ?
    function IsAnagramme(aWord1, aWord2: string): boolean;
    var A, B: TCharWord;
        C   : char;
    begin
      // faux par défaut 
      result := false;
     
      // conversion des deux mots
      A := CharWord(lowercase(aWord1));
      B := CharWord(lowercase(aWord2));
     
      // premier test, sur la longueur (le plus rapide)
      if A.len <> B.len then
        exit;
     
      // vrai par défaut
      result := true;
      for C := 'a' to 'z' do
      begin
        // mais vrai seulement si tout les compteurs correspondent
        result := A.chars[C] = B.chars[C];
     
        // sinon ... paf paf, faux et bye bye
        if not result then
          break;
      end;
    end;
     
    var
      G     : longword;
      s1, s2: string;
      f     : text;
      ac    : integer;
      exitCode : boolean = false;
     
    { Liste d'anagrammes de test :
      armure
      votre
      coulisse
      porte
      quitter
    }
    begin
     
      repeat
        Assign(f, 'Liste_Mots.txt');
        Reset(f);
     
        ac := 0;
        Write('> Votre mot ? ');
        ReadLn(s1);
     
        G := GetTickCount;
        while not Eof(f) do
        begin
          ReadLn(f, s2);
          if (s1<>s2) and isAnagramme(s1, s2) then
          begin
            WriteLn('    ',ac+1,'. ',s2);
            inc(ac);
          end;
        end;
        G := GetTickCount-G;
     
        if ac = 0 then
          Writeln('  Ha ben ',G,' milli-secondes pour ne rien trouver :(')
        else
          Writeln('  Decouvert ',ac,' anagrammes en ', G, ' milli-secondes.');
     
        Writeln('');
        Write('> Recommencer [r/R] - quitter [q/Q] : ');
        ReadLn(s1);
        Writeln('');
        exitCode := (s1 = 'q') or (s1 = 'Q');
        Close(f);
      until exitCode;
     
    end.
    [ Sources et programmes de Dr.Who | FAQ Delphi | FAQ Pascal | Règlement | Contactez l'équipe ]
    Ma messagerie n'est pas la succursale du forum... merci!

  3. #3
    Expert confirmé

    Inscrit en
    août 2006
    Messages
    3 856
    Détails du profil
    Informations forums :
    Inscription : août 2006
    Messages : 3 856
    Points : 5 445
    Points
    5 445
    Par défaut
    Nie,

    Roland Chastain : comparer l'ensemble des caractères constituant différents mots ne permet pas de décider s'il s'agit d'anagrammes.

    Dr.Who : un peu mieux, mais rien de prévu pour les caractères accentués.
    "Mon pied droit est jaloux de mon pied gauche.
    Quand l'un avance, l'autre veut le dépasser.
    Et moi, comme un imbécile, je marche !"
    [Raymond Devos]

  4. #4
    Rédacteur/Modérateur

    Avatar de Roland Chastain
    Homme Profil pro
    Enseignant
    Inscrit en
    décembre 2011
    Messages
    3 825
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 48
    Localisation : France, Moselle (Lorraine)

    Informations professionnelles :
    Activité : Enseignant

    Informations forums :
    Inscription : décembre 2011
    Messages : 3 825
    Points : 13 668
    Points
    13 668
    Billets dans le blog
    8
    Par défaut
    Très joli, très instructif. Respect !

  5. #5
    Rédacteur/Modérateur

    Avatar de Roland Chastain
    Homme Profil pro
    Enseignant
    Inscrit en
    décembre 2011
    Messages
    3 825
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 48
    Localisation : France, Moselle (Lorraine)

    Informations professionnelles :
    Activité : Enseignant

    Informations forums :
    Inscription : décembre 2011
    Messages : 3 825
    Points : 13 668
    Points
    13 668
    Billets dans le blog
    8
    Par défaut
    Citation Envoyé par droggo Voir le message

    Roland Chastain : comparer l'ensemble des caractères constituant différents mots ne permet pas de décider s'il s'agit d'anagrammes.

    Dr.Who : un peu mieux, mais rien de prévu pour les caractères accentués.
    Concernant les caractères accentués, j'ai constaté que ça ne fonctionnait pas (je parle de mon code) parce que la liste était corrompue. Je viens de m'apercevoir qu'en réenregistrant le fichier de mots au format OEM, ça marche.

    Une fois ce problème réglé, j'ajouterais une fonction pour comparer les mots sans tenir compte des accents.

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    program Accents;
     
    {$APPTYPE CONSOLE}
     
    function f(const cS: string): string;
    var
      i: integer;
    begin
      result := cS;
      for i := 1 to Length(cS) do
      case cS[i] of
        'à', 'â': result[i] := 'a';
        'é', 'è', 'ê', 'ë': result[i] := 'e';
        'î', 'ï': result[i] := 'i';
        'ô': result[i] := 'o';
        'ù', 'û': result[i] := 'u';
      end;
    end;
     
    var t: text; s: string;
     
    begin
      WriteLn('dépêche');           // dÚpÛche
      WriteLn('d'#233'p'#234'che'); // dÚpÛche
      WriteLn('d'#130'p'#136'che'); // dépêche
      WriteLn(f('dépêche'));        // depeche
     
      Assign(t, 'Texte_ANSI.txt');
    { Fichier au format ANSI contenant le mot "dépêche". }
      Reset(t);
      Read(t, s);
      WriteLn(s);                   // dÚpÛche
      Close(t);
     
      Assign(t, 'Texte_OEM.txt');
    { Fichier au format OEM contenant le mot "dépêche". }
      Reset(t);
      Read(t, s);
      WriteLn(s);                   // dépêche
      Close(t);
     
      ReadLn;
    end.
    Concernant la définition de l'anagramme, je suis bien conscient du défaut de la méthode que j'ai employée, mais je la trouve quand même intéressante, ne serait-ce que pour présenter la notion d'ensemble et le type Set Of.

  6. #6
    Expert confirmé

    Inscrit en
    août 2006
    Messages
    3 856
    Détails du profil
    Informations forums :
    Inscription : août 2006
    Messages : 3 856
    Points : 5 445
    Points
    5 445
    Par défaut
    Hoe,

    Il y a d'autres sujets permettant de montrer l'utilisation d'un ensemble. Vouloir le faire en utilisant une fonction incapable de donner un résultat correct pour ce qu'elle est censée faire est une très mauvaise idée.
    "Mon pied droit est jaloux de mon pied gauche.
    Quand l'un avance, l'autre veut le dépasser.
    Et moi, comme un imbécile, je marche !"
    [Raymond Devos]

  7. #7
    Rédacteur/Modérateur

    Avatar de Roland Chastain
    Homme Profil pro
    Enseignant
    Inscrit en
    décembre 2011
    Messages
    3 825
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 48
    Localisation : France, Moselle (Lorraine)

    Informations professionnelles :
    Activité : Enseignant

    Informations forums :
    Inscription : décembre 2011
    Messages : 3 825
    Points : 13 668
    Points
    13 668
    Billets dans le blog
    8
    Par défaut
    J'ai trouvé une discussion très intéressante sur la façon de convertir une chaîne accentuée en chaîne sans accents.

    Mais dans le cas présent le problème est plus particulier, puisqu'il s'agit par hypothèse de mots français. Donc je crois que ma petite fonction devrait suffire.

  8. #8
    Membre éprouvé
    Avatar de Dr.Who
    Inscrit en
    septembre 2009
    Messages
    980
    Détails du profil
    Informations personnelles :
    Âge : 42

    Informations forums :
    Inscription : septembre 2009
    Messages : 980
    Points : 1 286
    Points
    1 286
    Par défaut
    Oui les mots accentués ne sont pas pris en compte, ça c'est à force de programmer en anglais :/


    J'avais envie de reprendre la version shell en programme VCL sur delphi et de profiter a fond des possibilités du compilo 2009.Car les writeln et l'utilisation d'un type Text ralentissent énormément le programme et donc la mesure de performance est faussée (trop longue à mon gout)


    les résultats sont très convainquants :

    - chargement de la liste de mots dans un TStringList (>330000 mots)

    - pré-calcul de chaque mots en structure TCharWord stocké directement dans la propriété "objects" de TStringList. (soit une occupation d'un peu plus de 22Mo de ram) pour les prc.

    - Modification de la structure de TCharWord (ajout d'un createur statique et definition des opérateurs Explicite/Implicite avec le type string, opérateur d'égalité entre 2 TCharWord.
    Utilisation d'une superposition de mémoire pour TCharWord.Chars (bytes) et TCharWords.mem (LongWord) pour profiter pleinement de la puissance des registres 32bits et limiter le nombre de boucles (comparaison de 4 totaux de caractères en parallèle).
    Utilisation d'une dépendance à l'API windows en utilisant CompareMem pour comparer les bloc mémoire rapidement entre eux.

    chercher des anagrammes via TEdit pour remplir une TListBox (<65ms),
    fixe du bug des accents.

    l'anagramme de "demanger" ou "démanger" renvois bien :
    démanger, gendarme et gendarmé

    pour "porte" :
    opter, pérot, porte, porté, prote, toper, trope

    pour "déposer" :
    déposer, dropées

    pour "atire" :
    étira, itéra, réait, taire, tarie, tiare, traie

    not a bug : un mot est considéré comme sont propre anagramme donc l'égalité entre les deux mots renvois true.

    en toute logique les mots contenant un trait d'union sont correctement analysé et interprétés.

    "braoutja" renvois bien abat-jour

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    108
    109
    110
    111
    112
    113
    114
    115
    116
    117
    118
    119
    120
    121
    122
    123
    124
    125
    126
    127
    128
    129
    130
    131
    132
    133
    134
    135
    136
    137
    138
    139
    140
    141
    142
    143
    144
    145
    146
    147
    148
    149
    150
    151
    152
    153
    154
    155
    156
    157
    158
    unit VMain;
     
    interface
     
    uses
      Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
      Dialogs, StdCtrls;
     
    type
      TForm8 = class(TForm)
        Edit1: TEdit;
        ListBox1: TListBox;
        Label1: TLabel;
        procedure FormCreate(Sender: TObject);
        procedure FormDestroy(Sender: TObject);
        procedure Edit1Change(Sender: TObject);
      private
        Words: TStringList;
      public
        { Déclarations publiques }
      end;
     
    var
      Form8: TForm8;
     
    implementation
     
    {$R *.dfm}
     
     
    // ci-gît un code qui fût emporté avant d'être commenté.
     
    type
      PCharWord = ^TCharWord;
      TCharWord = record // banzaii ! //
         class function create(const aWord: string): TCharWord; static;
         class operator equal(A, B: TCharWord): boolean;
         class operator explicit(const a: string): TCharWord;
         class operator implicit(const a: string): TCharWord;
         case integer of
          0 :(len: integer; chars: array[byte] of byte);
          1 :(mem: array[0..64] of longword);
      end;
    const
      SizeOfTCharWord = SizeOf(TCharWord);
     
    class function TCharWord.create(const aWord: string): TCharWord;
    var X, L: integer;
        B: byte;
    begin
      for X := 0 to 64 do
        result.mem[X] := 0;
     
      result.len := Length(aWord);
      L := result.len;
      for X := 1 to L do
      begin
        B := byte(aWord[X]);
        case aWord[X] of
         {a} 'à','ä','â','ã' : inc(result.chars[97]);
         {c} 'ç'             : inc(result.chars[99]);
         {e} 'é','è','ë','ê' : inc(result.chars[101]);
         {i} 'ï','î','ì'     : inc(result.chars[105]);
         {o} 'ô','ö','ò'     : inc(result.chars[111]);
         {u} 'ü','û','ù'     : inc(result.chars[117]);
         {y} 'ÿ'             : inc(result.chars[121]);
          else
            if (B >= 97) and (B <= (123)) then
              inc(result.chars[B])
            else
              dec(result.len);
        end;
      end;
    end;
     
    class operator TCharWord.equal(A, B: TCharWord): boolean;
    begin
      result := A.len = B.len;
      if result then
        result := compareMem(@A, @B, SizeOfTCharWord);
    end;
     
    class operator TCharWord.explicit(const a: string): TCharWord;
    begin
      result := TCharWord.create(a);
    end;
     
    class operator TCharWord.implicit(const a: string): TCharWord;
    begin
      result := TCharWord.create(a);
    end;
     
    procedure TForm8.Edit1Change(Sender: TObject);
    var X: integer;
        A, B: TCharWord;
        G: LongWord;
    begin
      if length(Edit1.Text) < 1 then
        exit;
     
      A := string(Edit1.Text);
      ListBox1.Items.BeginUpdate;
      try
        G := GetTickCount;
        ListBox1.Clear;
        for X := 0 to Words.Count-1 do
        begin
          B := PCharWord(Pointer(Words.Objects[X]))^;
          if A = B then
            ListBox1.Items.Add(Words[X])
        end;
        G := GetTickCount-G;
      finally
        ListBox1.Items.EndUpdate;
        Label1.Caption := format('%d anagrammes trouvés, pour %d mots, en %.3f secondes',[ListBox1.Count,Words.Count,G*0.001]);
      end;
    end;
     
    procedure TForm8.FormCreate(Sender: TObject);
    var X: integer;
        P: PCharWord;
        G: LongWord;
    begin
      Edit1.Align := alTop;
      Edit1.AlignWithMargins := true;
     
      Label1.Align := alTop;
      Label1.AlignWithMargins := true;
     
      ListBox1.Align := alClient;
      ListBox1.AlignWithMargins := true;
     
      Words := TStringList.Create;
      Words.LoadFromFile(extractFilePath(ParamStr(0))+'Liste_mots.txt');
      for X := 0 to Words.Count - 1 do
      begin
        new(P);
        P^ := TCharWord.create(Words[X]);
        Words.Objects[X] := TObject(P);
      end;
      Edit1.Text := 'atirer';
    end;
     
    procedure TForm8.FormDestroy(Sender: TObject);
    var X: integer;
        P: PCharWord;
    begin
      // ! //
      for X := 0 to Words.Count - 1 do
      begin
        P := PCharWord(Words.Objects[X]);
        dispose(P);
      end;
      Words.Free;
      // ! //
    end;
     
    end.

    C'est bien marrant de refaire un programme comme ça maintenant (et à mon niveau) ça me rappel les petits concours qu'on faisait y'a 10 ans. (trouver les nombres premier, diviseur communs, suites de Fibonacci, conversion en chiffres romains etc).

    Merci Roland de me rappeler de bons souvenirs !
    [ Sources et programmes de Dr.Who | FAQ Delphi | FAQ Pascal | Règlement | Contactez l'équipe ]
    Ma messagerie n'est pas la succursale du forum... merci!

  9. #9
    Rédacteur/Modérateur

    Avatar de Roland Chastain
    Homme Profil pro
    Enseignant
    Inscrit en
    décembre 2011
    Messages
    3 825
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 48
    Localisation : France, Moselle (Lorraine)

    Informations professionnelles :
    Activité : Enseignant

    Informations forums :
    Inscription : décembre 2011
    Messages : 3 825
    Points : 13 668
    Points
    13 668
    Billets dans le blog
    8
    Par défaut
    Citation Envoyé par Dr.Who Voir le message
    Merci Roland de me rappeler de bons souvenirs !
    Merci pour cette nouvelle contribution.

    J'aurais bien aimé essayer ton programme, mais je n'ai pas su monter le projet. Si tu avais la possibilité de poster les autres fichiers ou un lien vers le projet complet, ce serait bien.

  10. #10
    Expert confirmé

    Inscrit en
    août 2006
    Messages
    3 856
    Détails du profil
    Informations forums :
    Inscription : août 2006
    Messages : 3 856
    Points : 5 445
    Points
    5 445
    Par défaut
    Joa,
    Citation Envoyé par Roland Chastain Voir le message
    Mais dans le cas présent le problème est plus particulier, puisqu'il s'agit par hypothèse de mots français. Donc je crois que ma petite fonction devrait suffire.
    Si tu parles de la fonction utilisant un set of char, non, elle ne suffit pas, puisque elle renvoie un faux positif dans le cas général où au moins un des mots comprend plusieurs fois le même caractère.
    "Mon pied droit est jaloux de mon pied gauche.
    Quand l'un avance, l'autre veut le dépasser.
    Et moi, comme un imbécile, je marche !"
    [Raymond Devos]

  11. #11
    Rédacteur/Modérateur

    Avatar de Roland Chastain
    Homme Profil pro
    Enseignant
    Inscrit en
    décembre 2011
    Messages
    3 825
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 48
    Localisation : France, Moselle (Lorraine)

    Informations professionnelles :
    Activité : Enseignant

    Informations forums :
    Inscription : décembre 2011
    Messages : 3 825
    Points : 13 668
    Points
    13 668
    Billets dans le blog
    8
    Par défaut
    Citation Envoyé par droggo Voir le message
    Joa,

    Si tu parles de la fonction utilisant un set of char, non, elle ne suffit pas, puisque elle renvoie un faux positif dans le cas général où au moins un des mots comprend plusieurs fois le même caractère.
    Je parle de la fonction qui enlève les accents. Je voulais dire qu'on pouvait se contenter de traiter uniquement les accents utilisés dans les mots français, comme dans l'exemple que j'ai proposé.

  12. #12
    Rédacteur/Modérateur

    Avatar de Roland Chastain
    Homme Profil pro
    Enseignant
    Inscrit en
    décembre 2011
    Messages
    3 825
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 48
    Localisation : France, Moselle (Lorraine)

    Informations professionnelles :
    Activité : Enseignant

    Informations forums :
    Inscription : décembre 2011
    Messages : 3 825
    Points : 13 668
    Points
    13 668
    Billets dans le blog
    8
    Par défaut
    J'ai réécrit mon code en ajoutant la gestion des accents, et je me suis permis de réécrire aussi à ma façon le code de Dr.Who (version console) pour voir si j'en comprenais bien le fonctionnement. Les deux versions ont été testées avec Free Pascal, Virtual Pascal et Delphi 7.

    Pour que le traitement des accents se fasse correctement, j'ai enregistré mes fichiers au format OEM (de même que pour le fichier de mots), ce qui donne avec Delphi 7 un affichage faux dans l'éditeur mais un résultat correct à l'exécution.

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
     
    { Recherche d'anagrammes par conversion des chaînes en ensembles.
     
      N.B. Méthode imparfaite qui assimile à des anagrammes tous les mots formés
      d'un même ensemble de lettres, par ex. "lame" et "malle". En comparant la
      longueur des mots, on ne fait que diminuer le nombre de faux résultats.
     
      Compilation Free Pascal, Virtual Pascal, Delphi 7. }
     
    program Anagrammes_v1;
     
    {$IFDEF VPASCAL}{&PMTYPE VIO}
    {$ELSE}{$APPTYPE CONSOLE}
    {$ENDIF}
     
    uses
      SysUtils;
     
    {$R Icone.res}
     
    type
      tEnsemble = set of char;
     
    function fSansAccentsNiMajuscules(const cS: string): string;
    var i: integer;
    begin
      result := LowerCase(cS);
      for i := 1 to Length(result) do
        case result[i] of
          'à','â': result[i] := 'a';
          'é','è','ê','ë': result[i] := 'e';
          'î','ï': result[i] := 'i';
          'ô': result[i] := 'o';
          'ù','û': result[i] := 'u';
        end;
    end;
     
    function StrToSet(const cS: string): tEnsemble;
    var
      lS: string;
      i: integer;
    begin
      lS := fSansAccentsNiMajuscules(cS);
      result := [];
      for i := 1 to Length(lS) do result := result + [lS[i]];
    end;
     
    var
      f: text;
      s1, s2: string;
      ls1: integer;
      e1: tEnsemble;
     
    begin
      Write('Votre mot ? ');
      ReadLn(s1);
      ls1 := Length(s1);
      e1 := StrToSet(s1);
     
      Assign(f, 'Liste_Mots.txt'); { N.B. Fichier enregistré au format OEM }
      Reset(f);
     
      while not EOF(f) do begin
                            ReadLn(f, s2);
                            if Length(s2) = ls1 then
                              if StrToSet(s2) = e1 then
                                WriteLn(s2);
                          end;
     
      Close(f);
     
      ReadLn;
    end.
    Votre mot ? armée
    amère
    armée
    armer
    marée
    marre
    marré
    ramée
    ramer
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
     
    { Recherche d'anagrammes par conversion des chaînes en tableaux de nombres.
     
      D'après Dr.Who.
     
      Compilation Free Pascal, Virtual Pascal, Delphi 7. }
     
    program Anagrammes_v2;
     
    {$IFDEF VPASCAL}{&PMTYPE VIO}
    {$ELSE}{$APPTYPE CONSOLE}
    {$ENDIF}
     
    uses
      SysUtils;
     
    {$R Icone.res}
     
    type
      tMot = record
               n: integer; // nombre de lettres
               lettres: array['a'..'z'] of byte;
             end;
     
    function fSansAccentsNiMajuscules(const cS: string): string;
    var i: integer;
    begin
      result := LowerCase(cS);
      for i := 1 to Length(result) do
        case result[i] of
          'à','â': result[i] := 'a';
          'é','è','ê','ë': result[i] := 'e';
          'î','ï': result[i] := 'i';
          'ô': result[i] := 'o';
          'ù','û': result[i] := 'u';
        end;
    end;
     
    function fMot(const cS: string): tMot;
    var
      c: char;
      i: integer;
      lS: string;
    begin
      lS := fSansAccentsNiMajuscules(cS);
      result.n := Length(lS);
      for c := 'a' to 'z' do result.lettres[c] := 0;
      for i := 1 to result.n do Inc(result.lettres[lS[i]]);
    end;
     
    var
      f: text;
      s1, s2: string;
      m1, m2: tMot;
      c: char;
      anagramme: boolean;
     
    begin
      Write('Votre mot ? ');
      ReadLn(s1);
      m1 := fMot(s1);
     
      Assign(f, 'Liste_Mots.txt'); { N.B. Fichier enregistré au format OEM }
      Reset(f);
     
      while not EOF(f) do
      begin
        ReadLn(f, s2);
        m2 := fMot(s2);
     
        if m2.n = m1.n then
        begin
          anagramme := true;
     
          for c := 'a' to 'z' do
            if m2.lettres[c] <> m1.lettres[c] then
            begin
              anagramme := false;
              Break;
            end;
     
          if anagramme then
            WriteLn(s2);
        end;
     
      end;
     
      Close(f);
     
      ReadLn;
    end.
    Votre mot ? armée
    amère
    armée
    marée
    ramée
    Fichiers attachés Fichiers attachés

  13. #13
    Expert confirmé

    Inscrit en
    août 2006
    Messages
    3 856
    Détails du profil
    Informations forums :
    Inscription : août 2006
    Messages : 3 856
    Points : 5 445
    Points
    5 445
    Par défaut
    Hoe,

    Évidemment, et les problèmes d'encodage ne seront jamais totalement résolus.

    La seule solution viable à ce jour est UniCode, mais il restera toujours les anciens fichiers (et peut-être alors ne saurons-nous même plus les lire correctement ?).
    "Mon pied droit est jaloux de mon pied gauche.
    Quand l'un avance, l'autre veut le dépasser.
    Et moi, comme un imbécile, je marche !"
    [Raymond Devos]

  14. #14
    Membre éprouvé
    Avatar de Dr.Who
    Inscrit en
    septembre 2009
    Messages
    980
    Détails du profil
    Informations personnelles :
    Âge : 42

    Informations forums :
    Inscription : septembre 2009
    Messages : 980
    Points : 1 286
    Points
    1 286
    Par défaut
    Toujours en version delphi 2009 :

    - Ajout de 3 fonctions dans TCharWord et de 1 opérateur :

    applyToStringList -> crée les TCharWord sur un TStringList contenant des mots
    removeFromStringList -> supprimer les TCharWord enregistré dans un TStringList.
    getFromStringList -> retourne le TCharWord correspondant a l'index du mots (necessite l'utilisation des TCharWord avec TStringList).

    operateur "<" (Less than) -> renvois true si des mots plus petit peuvent être fait avec les lettres du mot testé : Porte = Pot, Porte = Rote
    peut être utile au scrabble !

    - refactoring de l'unité pour l'UI, et déport de tout ce qui concerne TCharWord dans une unité propre (Anagrammes).



    Tout est dans le Zip, renomez le .exe_ en .exe pour avoir le programme fonctionnel.

    Regardez les previews (1 & 2)
    Images attachées Images attachées   
    Fichiers attachés Fichiers attachés
    • Type de fichier : zip ana.zip (914,6 Ko, 81 affichages)
    [ Sources et programmes de Dr.Who | FAQ Delphi | FAQ Pascal | Règlement | Contactez l'équipe ]
    Ma messagerie n'est pas la succursale du forum... merci!

  15. #15
    Rédacteur/Modérateur

    Avatar de Roland Chastain
    Homme Profil pro
    Enseignant
    Inscrit en
    décembre 2011
    Messages
    3 825
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 48
    Localisation : France, Moselle (Lorraine)

    Informations professionnelles :
    Activité : Enseignant

    Informations forums :
    Inscription : décembre 2011
    Messages : 3 825
    Points : 13 668
    Points
    13 668
    Billets dans le blog
    8
    Par défaut
    Je viens de m'apercevoir que la liste de mots dont je me suis servi a été utilisée récemment dans un excellent article que j'avais manqué. L'auteur de la liste y est présenté.

    @Dr.Who

    Merci pour ta contribution ! Je me rends compte qu'il manque encore quelque chose dans le dernier code que j'ai posté, à savoir le traitement des traits d'union. Tu avais pourtant signalé ce point dès le début de la discussion :

    Citation Envoyé par Dr.Who Voir le message
    les mots contenant un trait d'union sont correctement analysés et interprétés.
    Ce qui m'étonne, c'est que mon code s'exécute sans bug apparent, alors que cette ligne devrait (me semble-t-il) produire une erreur lorsque la chaîne lue contient un trait d'union :

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    for i := 1 to result.n do Inc(result.lettres[lS[i]]);
    Sachant que le tableau lettres est défini ainsi :

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    lettres: array['a'..'z'] of byte;
    Même en ajoutant la directive {$R+}, je n'arrive pas à obtenir une erreur !

    Pour revenir à la liste, il faut donc retenir qu'elle contient non seulement des accents, mais aussi des traits d'union et même des majuscules :

    hôtel-Dieu

  16. #16
    Rédacteur/Modérateur

    Avatar de Roland Chastain
    Homme Profil pro
    Enseignant
    Inscrit en
    décembre 2011
    Messages
    3 825
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 48
    Localisation : France, Moselle (Lorraine)

    Informations professionnelles :
    Activité : Enseignant

    Informations forums :
    Inscription : décembre 2011
    Messages : 3 825
    Points : 13 668
    Points
    13 668
    Billets dans le blog
    8
    Par défaut
    Voici la version corrigée de mon projet. C'est un programme en mode console, qui se compile avec Free Pascal et Virtual Pascal.

    J'ai inclus de nouveau la liste parce que je l'ai enregistrée dans un format particulier (OEM).
    Fichiers attachés Fichiers attachés

+ Répondre à la discussion
Cette discussion est résolue.

Discussions similaires

  1. Réponses: 4
    Dernier message: 01/03/2010, 21h00
  2. la recherche de clé dans une liste en POO
    Par wafiwafi dans le forum Langages de programmation
    Réponses: 3
    Dernier message: 20/08/2009, 15h50
  3. Réponses: 3
    Dernier message: 03/11/2008, 10h09
  4. recherche par attribut dans une liste d'objet
    Par Jacobian dans le forum Débuter avec Java
    Réponses: 1
    Dernier message: 28/05/2008, 21h11
  5. recherche de valeur dans une liste lag lead
    Par fatsora dans le forum Oracle
    Réponses: 1
    Dernier message: 31/01/2008, 08h28

Partager

Partager
  • Envoyer la discussion sur Viadeo
  • Envoyer la discussion sur Twitter
  • Envoyer la discussion sur Google
  • Envoyer la discussion sur Facebook
  • Envoyer la discussion sur Digg
  • Envoyer la discussion sur Delicious
  • Envoyer la discussion sur MySpace
  • Envoyer la discussion sur Yahoo