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