Proposition Exercice

Program exercice;
Uses Wincrt;
Type
  mat = Array [1..15,1..15] Of Char;
Var
  f: Text;
  m: mat;
  n: Integer;
Procedure creation (Var f:Text);
Begin
  Assign (f,'c:\bac\mots.txt');
End;
Function alphanum (ch:String): Boolean;
Var
  test: Boolean;
  i: Integer;
Begin
  i := 0;
  Repeat
    i := i+1;
    test := Upcase (ch[i]) In ['A'..'Z','0'..'9'];
  Until (test=False) Or (i=Length(ch));
  alphanum := test;
End;
Procedure remplir_m (Var m:mat;Var n:Integer);
Var
  i,j,x: Integer;
  c: Char;
  ch: String;
Begin
  Repeat
    Writeln ('Saisir N: ');
    Readln (n);
  Until n In [3..15];
  Repeat
    Writeln ('Saisir la chaine :');
    Readln (ch);
  Until (alphanum(ch)) And (Length(ch)<=Sqr(n));
  Randomize;
  While (Length(ch)<Sqr(n)) Do
    Begin
      c := Chr(Random(Ord('Z')-Ord('A')+1)+Ord('A'));
      ch := ch+c;
    End;
  x := 0;
  For i:=1 To n Do
    For j:=1 To n Do
      Begin
        x := x+1;
        m[i,j] := ch[x];
      End;
End;

Function tri (ch:String): String;
Var
  n,i: Integer;
  aux: Char;
Begin
  n := Length(ch);
  Repeat
    For i:=1 To n-1 Do
      If ch[i]>ch[i+1] Then
        Begin
          aux := ch[i];
          ch[i] := ch[i+1];
          ch[i+1] := aux;
        End;
    n := n-1;
  Until (n=0);
  tri := ch;
End;

Procedure remplir_f (Var f:Text;m:mat;n:Integer);
Var
res,mot:string;
i,j:integer;
Begin
  res := '';
  For i:=1 To n Do
    res := res+m[i,i];
  For i:=2 To n Do
    For j:=1 To i-1 Do
      res := res+m[i,j];
  For i:=1 To n-1 Do
    For j:=i+1 To n Do
      res := res+m[i,j];
  Rewrite (f);
  Repeat
    mot := Copy(res,1,n);
    Delete (res,1,n);
    Writeln (f,tri(mot));
  Until (res='');
  Close (f);
End;
Procedure affiche (Var f:Text);
Var
  ch: String;
Begin
  Reset (f);
  While Not (Eof(f)) Do
    Begin
      Readln (f,ch);
      Writeln (ch);
    End;
  Close (f);
End;
Begin
  creation (f);
  remplir_m (m,n);
  remplir_f (f,m,n);
  affiche (f);
End.