Bac 2011 (Cours particulier)

Program bac2011;
Uses Wincrt;
Var
    m,n:integer;
    f:text;
Procedure saisie (Var m,n:Integer);
Begin
  Repeat
    Write ('Saisir M: ');
    Readln (m);
    Write ('Saisir N: ');
    Readln (n);
  Until (100<m) And (m<n) And (n<1000);
End;

Function fact (n:Integer): String;
Var
ch,ch1:string;
r:integer;
Begin
  r := 2;
  ch := '';
  Repeat
    If n Mod r =0 Then
      Begin
        Str (r,ch1);
        ch := ch+ch1+'*';
        n := n Div r;
      End
    Else
      r := r+1;
  Until (n=1);
  fact := ch;
End;
function somme (ch:string):integer;
Var
s,x,e,i:integer;
Begin
    s:=0;
    for i:=1 to Length(ch) Do
        Begin
            val (ch[i],x,e);
            s:=s+x;
        end;
    somme:=s;
end;
Procedure traitement (Var f:Text;m,n:Integer);
Var
  x,e,i,s: Integer;
    ch,ch1:string;
Begin
  Rewrite (f);
  For i:=m To n Do
    Begin
      ch := fact(i);
      s := 0;
      Repeat
        If Length(Copy(ch,1,Pos('*',ch)-1))>1 Then
          Begin
            s := s+somme(Copy(ch,1,Pos('*',ch)-1));
            Delete (ch,1,Pos('*',ch));
          End
        Else
          Begin
            Val (Copy(ch,1,Pos('*',ch)-1),x,e);
            s := s+x;
            Delete (ch,1,Pos('*',ch));
          End;
      Until (ch='');
      Str(i,ch1);
      If somme(ch1)=s Then
        Writeln (f,i,'=',Copy(fact(i),1,Length(fact(i))-1));
    End;
  Close (f);
End;
procedure affiche (var f:text);
Var
ch:string;
Begin
    reset (f);
    if (eof(f)) Then
        writeln ('Il n''ya aucun nombre rigolo')
    else
        while not (eof(f)) Do
            Begin
                readln (f,ch);
                writeln (ch);
            end;
    close (f);
end;
Begin
    saisie (m,n);
    assign (f,'c:\bac\resultat.txt');
    traitement (f,m,n);
    affiche (f);
End.