Bac 2011 (Problème)

Program probleme2011;
Uses Wincrt;
Type
  mat = Array [1..50,1..50] Of Integer;
Var
  f1,f2: Text;
  m: mat;
Procedure creation (Var f1,f2:Text);
Begin
  Assign(f1,'C:\bac\TxtInit.txt');
  Assign(f2,'C:\bac\TxtCryp.txt');
End;
Function long (Var f1:Text): Integer;
Var
  x: Integer;
  ch: String;
Begin
  Reset (f1);
  Readln (f1,ch);
  x := Length(ch);
  While Not (Eof(f1)) Do
    Begin
      Readln (f1,ch);
      If (Length(ch)>x) Then
        x := Length(ch);
    End;
  long := x;
  Close (f1);
End;
Function convert (n:Integer): String;
Var
  x,x1,e: Integer;
  ch1,ch: String;
Function invers (ch:String): String;
Var
  i: Integer;
  ch1: String;
Begin
  ch1 := '';
  For i:=Length(ch) Downto 1 Do
    ch1 := ch1+ch[i];
  invers := ch1;
End;
Begin
  ch := '';
  Repeat
    Str (n Mod 8,ch1);
    ch := ch+ch1;
    n := n Div 8;
  Until (n Mod 8=0) And (n=0);
  convert := invers(ch);
End;
Procedure traitement (Var f1,f2:Text;Var m:mat);
Var
  long_max: Integer;
  i,j,l: Integer;
  ch: String;
Begin
  long_max := long(f1);
  Reset (f1);
  i := 0;
  While Not (Eof(f1)) Do
    Begin
      i := i+1;
      Readln (f1,ch);
      For j:=1 To long_max Do
        If j<=Length(ch) Then
          m[i,j] := Ord(ch[j])
        Else
          m[i,j] := Ord(' ');
    End;
  Close (f1);
  l := i;
  Rewrite (f2);
  For j:=1 To long_max Do
    Begin
      If j<>1 Then Writeln (f2);
      For i:=1 To l Do
        Write (f2,convert(m[i,j]),' ');
    End;
  Close (f2);
End;
Procedure affiche (Var f2:Text);
Var
  ch: String;
Begin
  Reset (f2);
  While Not (Eof(f2)) Do
    Begin
      Readln (f2,ch);
      Writeln (ch);
    End;
  Close (f2);
End;
Begin
  creation (f1,f2);
  traitement (f1,f2,m);
  affiche (f2);
End.