DEVOIR PRATIQUE BAC 2013 G2

program cryptage;
uses wincrt;
var
f,g:text;
n:integer;
procedure saisirn(var n:integer);
begin
repeat
writeln('entrer n');
readln(n);
until(n<=50);
end;
function verifmot(ch:string):boolean;
var
i:integer;
aux:string;
begin
aux:='azertyuiopqsdfghjklmwxcvbnAZERTYUIOPQSDFGHJKLMWXCVBN';
i:=1;
repeat
if(not(pos(ch[i],aux)=0))then
inc(i);
until(i>length(ch))or(pos(ch[i],aux)=0);
verifmot:=i>length(ch);
end;
function verif(ch:string):boolean;
var
r:boolean;
c,copie:string;
begin
c:=ch;
r:=true;
while(c<>'') and (r) do
begin
copie:=copy(c,1,pos(' ',c)-1);
delete(c,1,pos(' ',c)-1);
if (verifmot(copie)=false) or (c[1]=c[2]) then
r:=false;
delete(c,1,1);
if(pos(' ',c)=0)then
c:='';
end;
verif:=r;
end;
procedure remplirf(var f : text ; n :integer);
var
i:integer;
ch:string;
begin
rewrite(f);
for i:=1 to n do
begin
repeat
writeln('entrer une phrase');
readln(ch);
until(verif(ch));
writeln(f,ch);
end;
close(f);
end;
function decaler(c:char; p:integer):string;
var
k:char;
r:char;
begin
k:=upcase(c);
if ord(k)+p>ord('Z') then
r:=chr(ord('A')+(p-(ord('Z')-ord(k))))
else
r:=chr(ord(k)+p);
if (ord(c) in [ord('a')..ord('z')]) then
r:=chr(ord(r)+32);
decaler:=r;
end;
function crypter(ch:string):string;
var
resultat:string;
i,p:integer;
begin
resultat:='';
p:=1;
for i:=1 to length(ch) do
begin
if ch[i]<>' ' then
resultat:=resultat+decaler(ch[i],p)
else
begin
inc(p);
resultat:=resultat+' ';
end;
end;
crypter:=resultat;
end;
procedure rempg(var f,g:text);
var
ch:string;
begin
rewrite(g);
reset(f);
while(not(eof(f)))do
begin
readln(f,ch);
writeln(g,crypter(ch));
end;
close(f);
close(g);
end;
begin
assign(f,'d:/Phrases.txt');
assign(g,'d:/Ph_crypter.txt');
saisirn(n);
remplirf(f,n);
rempg(f,g);
end.

Voici ma proposition :
program ex23052013;
uses wincrt;
var p,c:text;
n,nb:integer;
ch:string;
procedure saisirn(var n:integer);
begin
repeat
readln(n);
until n <=50;
end;
function verif(ch:string):boolean;
var j:integer;
begin
j:=0;
repeat
j:=j+1;
until (not (upcase(ch[j]) in ['A'..'Z',' ']))or(j>length(ch));
verif:=(j>length(ch))and(pos(' ',ch)=0);
end;
procedure remplir(var p:text);
var i:integer;ch:string;
begin
rewrite(p);
for i:=1 to n do
begin
repeat
readln(ch);
until verif(ch);
writeln(p,ch);
end;
close(p);
end;

function crypt(ch:string):string;
function cr1(c:char):char;
begin
if (ord(c)+nb)>ord('Z') then
cr1:=chr(ord(c)+nb-26)
else
cr1:=chr(ord(c)+nb);
end;
function cr2(c:char):char;
begin
if (ord(c)+nb)>ord('z') then
cr2:=chr(ord(c)+nb-26)
else
cr2:=chr(ord(c)+nb);
end;
var j,k,m:integer;
ch1:string;
begin
ch1:='';
nb:=1;
for j:=1 to length(ch) do
begin
case ch[j] of
'A'..'Z': ch1:=ch1+cr1(ch[j]);
'a'..'z': ch1:=ch1+cr2(ch[j]);
' ':begin
ch1:=ch1+ch[j];inc(nb);
end;
end;
end;
crypt:=ch1;
end;
procedure crypter(var p,c:text);
var ch:string;
begin
reset(p);rewrite(c);
while not eof(p) do
begin
readln(p,ch);
writeln(c,crypt(ch));
end;
close(p);close(c);
end;

begin
assign(p,'c:\bac2013\Phrases.txt');
assign(c,'c:\bac2013\Ph_crypt.txt');
saisirn(n);
remplir(p);
crypter(p,c);
end.

Merci Monsieur,
moi j'ai une faute dans la procedure verif :
function verif(ch:string):boolean;
var
r:boolean;
c,copie:string;
begin
c:=ch;
r:=true;
if pos(' ',c) <> 0 then
begin
while(c<>'') and (r) do
begin
copie:=copy(c,1,pos(' ',c)-1);
delete(c,1,pos(' ',c)-1);
if (verifmot(copie)=false) or (c[1]=c[2]) then
r:=false;
delete(c,1,1);
if(pos(' ',c)=0)then
c:=c+' ';
end;
verif:=r;
end
else
verif:=false;
end;

verif:=(j>length(ch))and(pos(' ',ch)=0);
deux espaces pas une seule

Oui il faut deux espaces !!