Suite Robinson

Program Robin;
Uses Wincrt;
Type
  tab = Array [1..15] Of Integer;
Var
k: Integer;
f: Text;

Function compt (t:tab;i:Integer;n:Integer): Integer;
Var
  compteur: Integer;
  x: Integer;
  j: Integer;
Begin
  compteur := 0;
  x := t[i];
  For j:=1 To n Do
    If t[j]=x Then
      compteur := compteur+1;
  compt := compteur;
End;

Procedure tableau (Var t:tab;ch:String);
Var
i,x,e:integer;
Begin
  For i:=1 To Length(ch) Do
    Begin
      Val(ch[i],x,e);
      t[i] := x;
    End;
End;

Procedure TriBulle (Var Tab:tab;n:Integer) ;
Var
  i, j, t : Integer;
Begin
  For i := N Downto 1 Do
    For j := 2 To i Do
      If Tab[j-1] > Tab[j] Then
        Begin
          t := Tab[j-1];
          Tab[j-1] := Tab[j];
          Tab[j] := t;
        End;
End;
Function comptage (n:Integer;t:tab;ch:String): Integer;
Var
  j: Integer;
  i: Integer;
  nchaine: String;
Begin
  j := 0;
  Str(n,nchaine);
  For i:=1 To Length(ch) Do
    If n=t[i] Then
      j := j+1;
  comptage := j;
End;
Function invers (ch:String): String;
Var
  x: String;
  i: Integer;
Begin
  x := '' ;
  For i:=Length(ch) Downto 1 Do
    Begin
      x := x+Copy(ch,i-1,2);
      Delete (ch,i-1,2);
      i := i-1;
    End;
  invers := x;
End;
Procedure creation (Var f:Text);
Begin
  Assign (f,'c:/bac/result.text');
End;
procedure saisie (var k:integer);
Begin
    Repeat
        writeln ('Saisir k: ');
        readln (k);
    Until (2<=k) and (k<=15);
end;
Procedure traitement (Var f:Text; k:Integer);
Var
  t: tab;
  ch,TEST,TEST1,TEST2,final: String;
    compteur,j,i:integer;
Begin
    rewrite (f);
  ch:='0';
    writeln (f,'0');
    for compteur:=1 to k-1 Do
    begin
        final := '';
        tableau (t,ch);
      TriBulle(t,Length(ch));
      j := 1;
      For i:=1 To Length(ch) Do
        Begin
          Str (comptage (t[i],t,ch),TEST1);
          Str (t[i],TEST2);
          TEST := TEST1+TEST2;
          final := final+TEST;
          If comptage (t[i],t,ch)>1 Then
            i := i+comptage (t[i],t,ch)-1;
        End;
        ch:=invers(final);
        Writeln (f,ch);
    end;
    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);
    saisie(k);
  traitement (f,k);
  affiche (f);
End.