Fichiers texte

Voici le programme qui permet de traiter un fichier texte:
program bac;
uses wincrt;
var
f,f2:text;
nl,nm:integer;
m:real;
procedure remplir;
var
ch: string;
c:char;
begin
rewrite(f);
repeat
write('Donner une phrase : ');readln(ch);
writeln (f,ch);
write ('voulez vous continuez : ');
readln (c);
until upcase(c)='N';
close(f);
end;

procedure espace;
var
ch: string;
begin
reset (f);
assign(f2,'phrases2.txt');
rewrite(f2);
while not eof(f) do
begin
readln (f,ch);
while ch[1]=' ' do
delete (ch,1,1);
while ch[length(ch)]=' ' do
delete(ch,length(ch),1);
while pos (' ',ch)<> 0 do
delete(ch,pos (' ',ch),1);
if ch[length(ch)]<>'.' then
ch:=ch+'.';
writeln(f2,ch);
end;
reset(f2);
rewrite(f);
while not eof(f2) do
begin
readln(f2,ch);
writeln(f,ch);
end; close(f);
close(f2);
erase(f2);
end;

procedure compte(var nl,nm:integer;var m:real);
var
ch:string;
function comptemot(ch:string):integer;
var
nm,i:integer;
begin
nm:=1;
i:=1;
while i<length(ch) do
begin
i:=i+1;
if ch[i]=' ' then
nm:=nm+1;
end;
comptemot:=nm;
end;
begin
reset(f);
nl:=0;
nm:=0;
while not eof(f) do
begin
readln(f,ch);
nm:=nm+comptemot(ch);
nl:=nl+1;
end;
m:=nm/nl;
end;

procedure affiche;
var
ch:string;
begin
clrscr;
reset(f);
while not eof(f) do
begin
readln(f,ch);
writeln(ch);
end;
close(f);
end;
begin
assign(f,'phrases.txt');
remplir;
espace;
compte(nl,nm,m);
affiche;
writeln('Nombre de lignes = ',nl);
writeln('Nombre de mots = ',nm);
writeln('moyenne des mots = ',m:0:5);
writeln(' ILYES Copyright 2009');
writeln(' tous droits réserver');
end.

Merci, Ilyes, pour le partage. Juste une petite remarque : votre programme efface tous les espaces dans une phrase. On a besoin de laisser 1 espace entre deux mots. On peut faire la comparaison entre les deux caractères de phrase :
si ph[j]=' ' et ph[j+1]=' ' ou peut être il y a une autre solution ? A vous de la trouver ...


Et encore, selon énoncée, la correction des ces phrases sera sauvegerdée dans un deuxième fichier intitulé phr_cor.txt. Donc, on n'a pas besoin de faire cette partie de programme :

reset(f2);
rewrite(f);
while not eof(f2) do
begin
readln(f2,ch);
writeln(f,ch);
end;
close(f);
close(f2);
erase(f2);

Bonne continuation

J'ai compris : c'était pendant la copie un espace dans une instruction while pos (' ',ch)<> 0 do a été effacé. Avec 2 espaces ça marche.
Très bien Ilyes !!!