[Lazarus] Transpositions d'une chaîne de caractères

Bonsoir !

Je viens d'écrire mon premier programme avec Lazarus. :)

C'est une application console, pardon c'est un projet de type programme.

Ce programme, par un savant mélange d'itération et de récursion :P, génère toutes les transpositions possibles d'une chaîne de caractères.

J'ai utilisé le type tStringList (ce qui n'est pas très difficile).

Je vous propose mon code. Si je peux j'en ferai une version "fenêtre". :)

Code:

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
 
program Transpositions;
 
{ Génération de toutes les transpositions d'une chaîne de caractères.
  Le résultat est recueilli dans une liste de chaînes (tStringList).
 
  wiki.freepascal.org/TString_List-TString_Tutorial
  lazarus.developpez.com/cours/mots-croises/?page=pg_02
 
  Programme testé avec Lazarus 1.0.2.
}
 
{$APPTYPE CONSOLE}
{$mode objfpc}{$H+}
 
uses
  Classes, Console, Crt;
 
{$R Icone}
 
var
  Liste: tStringList;
 
procedure Proc1(var vS: string; const cI: integer);
 
{ vS = abcde
  cI = 3
 
  abcde
    ---
     3
 
  ..cde
  ..cd e
  ..e cd
  ..ecd
 
  abecd
}
var
  n, i: integer;
  lS: string;
begin
  n := Length(vS);
  if (cI > n) or (cI < 1) then
    Exit;
  lS := vS;
 
  lS[n - cI + 1] := vS[n];
 
  for i := n - cI + 2 to n do lS[i] := vS[i - 1];
 
  vS := lS;
end;
 
procedure Proc2(const cS: string; const cI: integer);
var
  lS: string;
  i: integer;
begin
  lS := cS;
  for i := 1 to cI do
  begin
  { Autant de fois qu'il y a de caractères concernés, on applique le
    traitement précédent à une copie locale de la chaîne passée en
    paramètre. }
    Proc1(lS, cI);
    if cI = 2 then
    { S'il n'y a plus que deux caractères concernés, on enregistre le
      résultat. }
      Liste.Add(lS)
    else
    { Autrement on refait la même chose avec un caractère de moins. }
      Proc2(lS, cI - 1);
  end;
end;
 
procedure Proc3(const cS: string);
{ Le traitement précédent, appliqué à toute la longueur d'une chaîne . }
begin
  Proc2(cS, Length(cS));
end;
 
var
  sTest: string;
  i, d: integer;
 
begin
  TextBackground(LightGray);
  ClrScr;
  TextColor(Black);
  Console.Intitule('Lazarus');
  WriteLn(#13#10'Transpositions d''une chaine de caracteres.'#10);
 
  Write('Veuillez saisir une chaine : ');
  TextColor(Red);
  ReadLn(sTest);
  TextColor(Black);
 
  if Length(sTest) > 0 then
  begin
    Liste := tStringList.Create;
    Proc3(sTest);
    WriteLn(#13#10'Nombre de transpositions : ', Liste.Count);
 
    Write(#10, Liste.Count, ' = ');
    i := Liste.Count;
    d := 1 ;
    while (i > 1) and not keyPressed do
    begin
      i := i div d;
      Write(d);
      if i > 1 then Write(' * ') else WriteLn(#10);
      Inc(d);
    end;
 
    Liste.SaveToFile(sTest + '.txt');
    WriteLn('Resultats enregistres dans le fichier "', sTest, '.txt".'#13#10);
    Liste.Free;
  end;
 
  while not keyPressed do Delay(100);
end.