По исходной перестановке вывести все циклы, которые в ней есть, в лексикографическом порядке

Program Prg59;
 
Const NMAX = 100;
 
Var P1,P2 : Array[1..NMAX] of integer;
Var i,n   : integer;
 
Procedure NextLoop(Var P,R : Array[1..NMAX] of integer; n : integer);
 
Var i,k,u,v : integer;
 
Begin
 
     for i:=1 to n Do R[i]:=0;
 
     k:= 0;
     
     For i:= 1 To n Do
         If P[i] <> 0 Then Begin
            k:=i;
            break;
         End;
 
     If k= 0 Then Exit;
     
     v:=1;
     R[1]:=k;
     
     While (True) Do Begin
        u:=P[k];
        P[k]:=0;
        If R[1]=u Then exit;
        v:=v+1;
        R[v]:=u;
        k:=u;
     End;
     
End;
 
Begin
 
     write('n=');
     readln(n);
     write('Enter permutation: ');
     
     for i:=1 to n do read(P1[i]);
     
     While (true) Do begin
     
         NextLoop(P1,P2,n);
         
         if P2[1]=0 Then break;
         
         write('(');
         for i:=1 to n do
             if P2[i]<>0 then write(P2[i]) else break;
         writeln(')');
         
      End;
      
      Writeln('OK');
      
End.

uses crt;
var
p,i,j,a,count,min,imin: integer;
mas: array[1..30] of integer;
mas2: array[1..30] of byte;
 
begin
readln(p);
 
for i:=1 to p do read(mas[i]);
 
for i:=1 to p do mas2[i]:=0;
 
i:=1;
while (i<=p) do
  if mas2[i]=0 then begin
      a:=mas[i];
      mas2[i]:=1;
      write('(',i);
        while a<>i do begin
         write(a);
 
         mas2[a]:=1;
          a:=mas[a];
            end;
          i:=i+1;
          write(')') end
  else
i:=i+1;
end.