[Free Pascal] Programme qui supprime les espaces inutiles dans une chaîne

[joreveur]

Bonjour,

j'ai fait un petit programme pour supprimer les espaces dans une chaine
un peu à la manière de =SUPPRESPACE(A1) d'un tableur.

votre avis ? il y a plus simple ? c'est déjà implémenté dans le langage ?

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
// via joreveur 15/07/2012  version 0.1
//Programme pour supprimer les espaces inutiles dans une chaine
program Supprespace;
  uses crt;
  var space,chaine:string;
  i,flag:integer;
  const DeuxEpaces='  ';
begin
  clrscr;
  writeln('Programme pour supprimer les espaces inutiles dans une chaine');
 
//saisie de la chaine de départ
  flag:=0;
  while flag=0 do
  begin
	write('entrer une chaine de caractères : ');
	readln(chaine);
	for i:=1 to length(chaine) do
	begin
	  if chaine[i]<>' ' then flag:=flag+1;
	end;
  end;	
 
//suppression des doubles espaces par un seul espace par recurcivité
  space:=DeuxEpaces;
  while space=DeuxEpaces do
  begin
	for i:=length(chaine) downto 1 do
	begin
	  space:=copy(chaine,i,2);
	  if space=DeuxEpaces then
	  begin
		chaine:=copy(chaine,1,i-1)+' '+copy(chaine,i+2,length(chaine)-1);
	  end;
	end;
  end;
 
//suppression de l'espace de début et de fin si nécessaire.
  if chaine[1]=' ' then chaine:=copy(chaine,2,length(chaine)-1);
  if chaine[length(chaine)]=' ' then chaine:=copy(chaine,1,length(chaine)-1);
  writeln(chaine,' (longueur de : ',length(chaine),')');
  write('enter pour quitter');
  readln;
end.

ce qui donne :

Code :

1
2
entrer une chaine de caractères :    La    jument   verte de Marcel  Aymé     
La jument verte de Marcel Aymé (longueur de : 30)

merci d'avance

[Roland Chastain]

Chouette, un exercice !

Voici la solution que j'ai trouvée :

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
 
program essai;
 
// Free Pascal 2.6
// Suppression des espaces inutiles
 
const
  maChaine: string = ' Line(0,  0, 10,   10); ';
 
function f(s: string): string;
var
  i: word;
  temp1: string;
  espace: boolean = true;
  temp2: string;
  dernier_espace: word = 1;
begin
  //
  temp1 := '';
  //
  for i := 1 to length(s) do
  begin
    //
    if not ((s[i] = chr(32)) and espace) then
    begin
      temp1 := temp1 + s[i];
      //
      if s[i] = chr(32) then
        espace := true
      else
        espace := false;
      //
    end;
    //
    if s[i] = chr(32) then dernier_espace := i;
    //
  end;
  //
  temp2 := '';
  //
  for i := 1 to dernier_espace - 1 do temp2 := temp2 + temp1[i];
  //
  f := temp2;
end;
 
begin
  writeln('''' + maChaine + '''');
  writeln('''' + f(maChaine) + '''');
  readln;
end.

[Paul TOTH]

à vu de nez tu as un bug si la chaîne ne se termine pas par un espace

[joreveur]

Bonjour,

Envoyé par Roland Chastain

Chouette, un exercice !

Voici la solution que j'ai trouvée :

merci de ton programme. J'envisageai de faire une fonction et tu as deja travaillé dans ce sens là.

Envoyé par Paul TOTH

à vu de nez tu as un bug si la chaîne ne se termine pas par un espace

dans quel programme?

à bientôt.

[joreveur]

Envoyé par Roland Chastain

Chouette, un exercice !

Voici la solution que j'ai trouvée :

un bug dans ton programme....
exemple si je demande de travailler cette chaine

'la jument verte'

ça va me donner çà

'la jument verteument

'

[Paul TOTH]

FreePascal ne possède-t-il pas les fonction StringReplace et Trim de Delphi ?

[Roland Chastain]

J'ai pris mes rêves pour des réalités.

Voici une nouvelle version qui paraît mieux fonctionner :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
  temp2 := '';
  //
  if (temp1 <> '') and (temp1[length(temp1)] = chr(32)) then
  begin
    for i := 1 to dernier_espace - (1 + length(s) - length(temp1)) do
    begin
      temp2 := temp2 + temp1[i];
    end;
  end else
  begin
    temp2 := temp1;
  end;
  //
  f := temp2;

Code :

1
2
3
4
 
  writeln('''' + f('') + '''');                // ''
  writeln('''' + f(' ') + '''');               // ''
  writeln('''' + f('La jument verte') + ''''); // 'La jument verte'

[batyann811]

Envoyé par Paul TOTH

FreePascal ne possède-t-il pas les fonction StringReplace et Trim de Delphi ?

Elles existent, mais :

1. StringReplace ne me semble pas vraiment adaptée au problème
2. C'est plus drôle de le faire tout seul comme un grand

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
program SuprEsp;
{$mode objfpc}{$h+}
 
{$ifdef WINDOWS}
  {$APPTYPE CONSOLE}
{$endif}
 
function SupprEspace(const S: String) : String;
var
  I, Len : Integer;
begin
  Result := '';
  Len := Length(S);
  I := 1;
 
  while I <= Len do
  begin
 
    // Eliminer une suite d'espaces
    while (I <= Len) and (S[I] = ' ') do
      Inc(I);
 
    // Copier une séquence de caractères affichables
    while (I <= Len) do
    begin
      Result := Result + S[I];
      Inc(I);
 
      if S[I - 1] = ' ' then
        Break;
    end;
 
  end;
 
  // Eliminer l'espace de fin
  Len := Length(Result);
  if Len > 0 then
    if Result[Len] = ' ' then
      SetLength(Result, Len - 1);
end;
 
procedure Test(const S: String);
begin
  WriteLn('SupprEspace(''', S, ''') => ''', SupprEspace(S), '''');
end;
 
 
begin
  Test('');
  Test(' ');
  Test('A');
  Test(' A');
  Test('A ');
  Test(' A ');
  Test('ABCD');
  Test('AB CD');
  Test(' AB CD ');
  Test('A B    C  D');
  Test(' A B    C  D    ');
  Test('  La    jument    verte de Marcel    Aymé    ');
  ReadLn;
end.

[Roland Chastain]

@batyann811

J'aime bien ton programme, surtout le Break. C'est bien pensé.

Par contre j'ai remarqué que les caractères accentués ne sont pas rendus correctement. Cela tient au mode de compilation, n'est-ce pas ?

[batyann811]

Envoyé par Roland Chastain

@batyann811
Par contre j'ai remarqué que les caractères accentués ne sont pas rendus correctement. Cela tient au mode de compilation, n'est-ce pas ?

C'est du à un problème d'encodage. Tu as du enregistrer ton fichier source dans un encodage différent de celui de la console. Si tu utilises Lazarus, par exemple, il a du encoder ton fichier en UTF-8. Sous linux, pas de problème car la console est aussi en UTF-8 (dans 99,99% des cas). Sous windows la console est en CP-847 (à vérifier c'est juste un souvenir) et le programme sort donc du texte UTF-8 sur un encodage différent ce qui donne des hyérogliphes. Normalement il y a 2 façons de corriger cela.

La première est de faire concorder l'encodage du fichier source et de la console.

La seconde est d'indiquer l'encodage dans le fichier source avec une directive {$CODEPAGE UTF8} pour que la RTL fasse la traduction automatiquement. Malheureusement, sous windows, ça ne fonctionne pas parce que la console et l'environnement graphique n'utilisent pas le même encodage.

[mick605]

Ca me parait un peu lourd vos méthodes (récursivité, 2 while)...

Si j'ai bien compris, SupprEspace enlève les espaces en doubles, les espaces avant et après la chaine ?

J'aurais vu un truc du genre :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
function SupprEspace(Txt : string):String;
var i : integer;
    Espace : boolean;
begin
  Result:='';
  Espace=false;
 
  for i:=1 to Length(Txt) do
  begin
    if Txt[i]=' ' then Espace:=true
    else
    begin
      if Espace and (Result<>'') then Result:=Result+' '+Txt[i];
                                 else Result:=Result+Txt[i];
      Espace=false;
    end;
  end;
end;

(Non testé)

[batyann811]

Envoyé par mick605

Ca me parait un peu lourd vos méthodes (récursivité, 2 while)...

A l'origine j'avais pensé faire comme toi. Et puis je me suis dit que différencier le traitement des zones blanches du traitement des zones imprimables (les 2 while) devrait rendre la fonction plus rapide.

Je viens de tester. Et en fait non c'est même plus lent...

[mick605]

Merci pour le retour.

Il faut dire aussi que dans les zones "blanches", il n'y a qu'un test et une affectation, donc c'est assez rapide...

[batyann811]

En trichant légèrement j'ai rendu ma méthode beaucoup plus rapide (environ 4 fois plus rapide que la méthode mick605 qui était déjà 15 à 20% plus rapide que ma pseudo méthode optimisée bidon) :

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
 
{--- SupprimerEspace ---}
function SupprimerEspace(const S: String) : String;
var
  I, Len, J : Integer;
begin
  Result := '';
  Len := Length(S);
 
  if Len = 0 then
    Exit;
 
  SetLength(Result, Len);  // La "triche" est ici
 
  I := 1;
  J := 1;
  while I <= Len do
  begin
 
    // Eliminer une suite d'espaces
    while (I <= Len) and (S[I] = ' ') do
      Inc(I);
 
    // Copier une séquence de caractères affichables
    while (I <= Len) do
    begin
      Result[J] := S[I];
      Inc(I);
      Inc(J);
 
      if S[I - 1] = ' ' then
        Break;
    end;
 
  end;
 
  // Eliminer l'espace de fin
  if J > 1 then
    if Result[J - 1] = ' ' then
      Dec(J);
 
  SetLength(Result, J - 1);
end;

La même méthode en utilisant des pointeurs est même encore un peu plus rapide.

[Paul TOTH]

voici une autre idée

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
 
function XTrim(const Str: string): string;
var
  Index      : Integer;
  IgnoreSpace: Boolean;
  AddSpace   : Boolean;
begin
  IgnoreSpace := True; // au début on ignore les espaces
  AddSpace := False; // il ne faudra donc pas en insérer un
  Result := ''; // chaîne vide
  for Index := 1 to Length(Str) do
  begin
    if Str[Index] = ' ' then // un espace ?
    begin
      if IgnoreSpace then Continue; // doit-on les ignorer ?
      AddSpace := True; // il faudra en ajouter un (sauf en fin de chaîne)
      IgnoreSpace := True; // et ignorer les autres
    end else begin // sinon
      IgnoreSpace := False; // il faudra compter le prochain espace
      if AddSpace then // a-t-on rencontré au moins un espace ?
      begin
        Result := Result + ' '; // l'ajouter avant
        AddSpace := False; // une seule fois
      end;
      Result := Result + Str[Index]; // ajouter le caractère non espace
    end;
  end;
end;

et une version plus adaptée pour Delphi et ses chaînes "longues" (une seule allocation puis un ajustement de la taille)

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
 
function XTrim(const Str: string): string;
var
  Index      : Integer;
  Offset     : Integer;
  IgnoreSpace: Boolean;
  AddSpace   : Boolean;
begin
  IgnoreSpace := True;
  AddSpace := False;
  SetLength(Result, Length(Str));
  Offset := 0;
  for Index := 1 to Length(Str) do
  begin
    if Str[Index] = ' ' then
    begin
      if IgnoreSpace then Continue;
      AddSpace := True;
      IgnoreSpace := True;
    end else begin
      IgnoreSpace := False;
      if AddSpace then
      begin
        Inc(Offset);
        Result[Offset] := ' ';
        AddSpace := False;
      end;
      Inc(Offset);
      Result[Offset] := Str[Index];
    end;
  end;
  SetLength(Result, Offset);
end;

[mick605]

Alala, si vous trichez en plus !!

En bidouillant avec les allocations

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
procedure SupprEspace(var Txt : string);
var i, j : integer;
    Espace : boolean;
begin
  j:=0;
  Espace=false;
 
  for i:=1 to Length(Txt) do
  begin
    if Txt[i]=' ' then Espace:=true
    else
    begin
      if Espace and (j<>0) then 
      begin
        Txt[j+1]=' ';
        Txt[j+2]=Txt[i];
        inc(j,2);
      end
      else
      begin
        inc(j);
        Txt[j]=Txt[i];
      end;
      Espace=false;
    end;
  end;
 
  Delete(Txt,j+1,MaxInt);  //Je sais jamais si c'est j ou j+1
end;

C'est faux, je n'ai pas transformé la fonction en procedure ... Personne a dit que c'était interdit

[joreveur]

merci de tous vos avis et coding

voila une nouvelle mouture ... peut-être à revoir ..

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
 
function s2(a: string): string;
  var i:integer;
 
  begin
	for i:=length(a) downto 2 do
	  if (a[i]=' ') and (a[i-1]=' ') then  a:=copy(a,1,i-1)+copy(a,i+1,length(a)-1);
 
	if (length(a)>1) and (a[length(a)]=' ') then delete(a,length(a),1);
	if (length(a)>1) and (a[1]=' ') then delete(a,1,1);
 
	s2:=a;
  end;

[hackc]

Pourquoi ne pas faire tout simplement un truc du genre :

Code :

1
2
3
4
While St[1] = ' ' Do
  Delete(St, 1, 1);
While St(Length(St))=' ' Do
  Delete(St, Length(St), 1);

[Roland Chastain]

1° parce que ça ne fonctionnerait pas

Code :

While St(Length(St))=' ' Do

2° parce que, même si ça marchait, ça ne répondrait pas au problème, qui est de supprimer les espaces superflus partout dans la chaîne, et pas seulement aux extrémités.