PROGRAM marquise;

{
Epreuve informatique de l'Ecole Polytechnique           92.027
--------------------------------------------------------------




1/   On appelle involution d'un ensemble E toute application f: E->E
      qui vérifie :

          f(f(x))=x
                                    -1
     ce qui peut se noter aussi  f.f   =I si I  désigne l'appli-
     cation identique.

     Montrer que f  est une bijection.

     En supposant que E contient un nombre fini n d'éléments,
     écrire un programme Pascal capable d'établir la liste des
     involutions de E. Imprimer cette liste pour de petites
     valeurs de n, jusqu'à 5 ou 6 par exemple .

2/   Ecrire le programme Pascal qui compte par récurrence le nombre
     d'involutions de E pour toute valeur de n.
     Imprimer le résultat pour des valeurs de n allant par exemple
     jusqu'à 30.


3/   On appelle permutation élémentaire une involution qui n'ad-
     met aucune décomposition de la forme


           f = k1.k2


     où k1  et k2  sont deux involutions distinctes de E .

     Montrer que toute bijection f  est de la forme :

             f = k1.k2.... kp

     où chaque ki est une permutation élémentaire.
     Une telle décomposition, qui n'est pas unique, est dite
     décomposition minimale s'il n'existe pas d'autre décomposition
     de f ayant moins de p éléments. Ainsi :

        p=0   pour l'indentité I
        p=1   pour une permutation élémentaire.


     Ecrire un programme Pascal capable de trouver une décom-
     position minimale de n'importe quelle bijection f de E
     dans lui-même.
     Soit p le nombre d'éléments obtenus.
     En variant le choix de f, quelle est la plus grande valeur
     de p observée, et pour quel type de bijection ?


4/   Combien existe-t-il, pour chaque valeur de p, de bijections
     différentes de E dans E dont la décomposition minimale
     contient p permutations élémentaires ? Vérifier que le total
     des résultats pour toutes les valeurs de p est égal
     au nombre total des bijections de E dans lui-même.

5/   Déduire de ce qui précède que le tri par ordre alphabétique
     des mots d'un texte quelconque peut se décomposer en un
     minimum de permutations élémentaires.

     Ecrire un programme capable, pour un texte quelconque, de
     déterminer une décomposition minimale en permutations
     élementaires permettant de trier les mots de ce texte par
     ordre alphabétique. Vérifier le bon fonctionnement de ce
     programme en lui faisant imprimer la suite des textes
     intermédiaires obtenus à chaque étape de l'enchaînement de
     p permutations élémentaires trouvées.

     Illuster en triant les neuf mots du texte suivant :

     "belle marquise vos beaux yeux me font mourir d'amour"


                            -=-=-=- }


uses
  crt, modubase;

Const
     nmax=100;

Type
    sequence =  array[1..nmax] of integer;
    bijection = sequence;

VAR
   n,c         : integer;
   res         : array[0..nmax]of real;
   x,y,z       : sequence;
   x0,xt       : sequence;
   question    : char;
   mot         : array[1..nmax] of string;



Procedure Dimension;
begin
  {   repeat
     begin
      Write('Entrez la longueur n d''une séquence :');
      ReadLN(n);
     end
     until (n>0) and (n<=nmax);
     }
     n:=16;
end;


Procedure Show(x:sequence);
var
   p : integer;
begin
     write('(');
     for p:=1 to n do
         begin
              write(x[p],' ');
         end;
     write(')');
end;


Procedure Identite(VAR x:sequence);
var
   i : integer;
begin
     for i:=1 to n do
         x[i] := i;
end;

Procedure Rotate(VAR x:sequence);
var
   i : integer;
   u : integer;
begin
     u:=x[1];
     for i:=2 to n do
         x[i-1] := x[i];
     x[n]:=u;
end;



Procedure Next(VAR x:sequence);
var
   i : integer;
begin
     i:= n;
     while (i>0) and (x[i]=n) do
          i:=i-1;
     if i>0 then
           x[i]:=x[i]+1;
     for i:=i+1 to n do
           x[i]:=1;

end;

Procedure Next_Permu(VAR x:sequence);
var
   i,j : integer;
   ok : boolean;
begin
   repeat
   begin
     Next(x);
     ok:=true;
     for i:=1 to n do
      for j:=i+1 to n do
        begin
              ok:=ok and (x[i]<>x[j])
        end;
   end
   until ok
end;

Procedure Hasard(VAR x:sequence);
var
   i,j : integer;
   ok : boolean;
begin
     for i:=1 to n do
     begin
          repeat
          begin
               x[i]:=random(n)+1;
               ok:=true;
               for j:=1 to i-1 do
                    ok:= ok and (x[i]<>x[j])
          end
          until ok;
    end;
end;



Procedure Copie(VAR y:sequence;x:sequence);
var
   i : integer;
begin
     for i:=1 to n do
         y[i] := x[i];
end;




Procedure Compose(VAR z:sequence;x,y:sequence);
var
   i:integer;
begin
     for i:=1 to n do
     begin
          z[i]:= x[y[i]];
     end;
end;


Function Compare(y,x:sequence):integer;
{   =  0 si x=y,
    =  1 si y>x
    = -1 si y<x
}

var
   i : integer;
begin
     i:=1;
     while(i<=n) and (x[i]=y[i]) do
         i:= i+1 ;
     if i>n then
        compare := 0
     else
      if y[i]>x[i] then
        compare := 1
      else
         compare := -1
end;

{Solution gracieusement apportée par S.Monsallier (16) 32 54 22 02}
{               revue et corrigée par R. Potdevin (16) 35 98 20 25}
Function Nb_Sym(n:integer):real;
begin
     if n>1 then
        begin

             res[n-1]:=Nb_Sym(n-1);
             Nb_Sym:=res[n-1]+(n-1)*res[n-2];
        end
     else
         Nb_Sym:=1;
end;

procedure element(var x:sequence;i,j:integer);
var
   k:integer;
begin
    for k:=1 to n do
         x[k]:=k;
    if i<>j then
       begin
          x[i]:=j;
          x[j]:=i;
       end;
end;


Procedure decompose(var e,x:sequence);
var
   i,j:integer;
begin
     i:=0;
     repeat
           i:=i+1
     until (x[i]<>i) or (i>n);
     j:=i;
     if j<=n then
     repeat
           j:=j+1
     until (x[j]=i) or (j>n);
     element(e,i,j);
     Compose(x,e,x);
end;



Procedure Question1;
begin
     writeLN('');
     writeLN('');
     writeLN('  On déduit de l''énoncé que                        ');
     writeLN('  f est injective car s''il deux x et x'' vérifient   ');
     writeLN('  f(x)=f(x''), on aurait aussi f.f(x)=f.f(x'')        ');
     writeLN('  et donc x=x''.                                    ');
     writeLN('  f est surjectif car pour tout y                   ');
     writeLN('  il existe un x=f(y) tel que f(x)=y                ');
     writeLN('  donc f est une bijection.');
     writeLN('');
     writeLN('');
     for n:=1 to 10 do
     begin
          writeln('== Liste des involutions pour    n=',n,'=======>');
          c:=0;
          Identite(x0);
          Copie(x,x0);
          repeat
          begin
               compose(y,x,x);
               if compare(y,x0)=0 then
                  begin
                       c:=c+1;
                       show(x);
                  end
               else
                   write('.');
               write(':');
               next_permu(x);
          end
          until compare(x0,x)=0;

          Writeln('');
          WriteLN('--------> Pour n=',n,'  il y a ',c,' involutions.');
          Pause;
     end;
end;

Procedure Question2;
var
   s:real;
   k:integer;
begin
     {Solution gracieusement fournie par S.Monsallier (16) 32 54 22 02}
     {              revue et corrigée par R. Potdevin (16) 35 98 20 25}
     WriteLn('On appelle Sn le nombre d''involutions dans l''ensemble En.      ');
     WriteLN('Une involution peut avoir sur l''élément n de En deux effets.    ');
     WriteLN('1) soit elle le laisse invariant, dans ce cas l''involution      ');
     WriteLN('   restreinte aux n-1 éléments restants est une involution sur   ');
     WriteLN('   un ensemble de cardinal n-1 il y a donc Sn-1 façons de        ');
     WriteLN('   la déterminer.');
     WriteLN('2) soit elle échange l''élément n avec un autre élément i,      ');
     WriteLN('   choisi parmis les n-1 premiers éléments; dans ce cas,         ');
     WriteLN('   l''involution restreinte à En privé des éléments n et i est   ');
     WriteLN('   une involution sur un ensemble de cardinal n-2; il y a donc    ');
     WriteLN('   Sn-2 façons de déterminer l''involution sur le reste de En    ');
     WriteLN(' S1=                           =1             =1      ');
     WriteLN(' S2=                           =2             =2      ');
     WriteLN(' S3=S2+2*S1                    =2+2*1         =4      ');
     WriteLN(' S4=S3+3*S2                    =4+3*2         =10     ');
     WriteLN(' S5=S4+4*S3                    =10+4*4        =26     ');
     WriteLN(' S6=S5+5*S4                    =26+5*10       =76     ');
     WriteLN(' . . .                                                ');
     WriteLN(' Sn=Sn-1+(n-1)*Sn-2                                   ');
     WriteLN('                                                      ');
     Pause;
     res[0]:=1;
     res[1]:=1
     for n:=1 to nmax do
     begin
          write('Pour n=',n:2,', il y a ');
          s:=0;
          s:=Nb_Sym(n);
          WriteLN(s:24:0,' involutions.');
          Pause;
     end;
end;

Procedure Question3;
var
   e,z:sequence;
   p : integer;
begin
     writeLN('== Decomposition de permutations =====');
     writeLN('                                      ');
     writeLN('   en p étapes (p<=n-1)               ');
     writeLN('                                      ');
     n:=5;
     Repeat
     begin
          Identite(x0);
          Hasard(x);
          Show(x);
          Write('=');
          p:= 0;
          while compare(x,x0)<>0 do
          begin
               decompose(e,x);
               compose(z,e,x);
               show(e);
               Write('.');
               p:=p+1;
          end;
          WriteLN('  <p=',p,'>');
          Pause;
      end
      until false;

end;




Procedure Question4;
var
   c : array[0..nmax] of longint;
   s : longint;
   i,p : integer;
   e,z : sequence;
begin
     writeLN('== Calcul de B(p,n)  =====');
     writeLN('                                             ');
     writeLN('   B(0,n)=1        identité                  ');
     writeLN('   B(1,n)=C(2,n)   Transpositions  ');
     writeLN('   B(2,n)=                                    ');
     writeLN('                                             ');
     writeLN('                   ');
     writeLN('     ');

     for n:=1 to 10 do
     begin
          for i:=0 to n do
              c[i]:=0;
          Identite(x0);
          Copie(y,x0);
          repeat
          begin
                 Copie(x,y);
{                 Show(x);
                 Write('=');   }
                 p:= 0;
                 while compare(x,x0)<>0 do
                 begin
                 decompose(e,x);
                 compose(z,e,x);
          {      show(e);
                 Write('.');    }
                 p:=p+1;
          end;
      {    WriteLN('  <p=',p,'>'); }
          Inc(c[p]);
          next_permu(y);
       end
       until compare(x0,y)=0;
       Writeln('');
       writeln('== Décomposition des bijections pour    n=',n,'=======>');
       s:=0;
       For i:=0 to n-1 do
           begin
                s:=s+c[i];
                writeLN('B(',i,',',n,')=',c[i]);
           end;
           WriteLN('=====Total des B(p,n) : ',s);
{       Pause;  }
     end;

end;

Function scan(var t:string):string;
var
   i,j:integer;
begin
     i:=1;
     while (i<=length(t)) and (t[i]=' ') do
           i:=i+1;
     if i>length(t) then
        t:='
     else
        begin
             j:=i;
             while (j<=length(t)) and (t[j]<>' ') do
                   j:=j+1
             scan:=copy(t,i,j-i);
             t:=copy(t,j,length(t)-j+1);
         end;
end;

Procedure Affiche_phrase(s:sequence);
var
   i:integer;
begin
     for i:=1 to n do
         write(mot[s[i]],' ');
     WriteLN('');
end ;

Procedure tri(phrase:string);
var
   i,j,u,p : integer;
   more : Boolean;
   e,z : sequence;
begin
     n:=0;
     while phrase<>'' do
     begin
        Inc(n);
        mot[n]:=scan(phrase);
     end;
     Identite(x0);
     Copie(x,x0);
     Affiche_phrase(x);
     more:=true;
     while more do
      begin
        more:=false;
        for i:=1 to n do
         for j:=i+1 to n do
             begin
                  if mot[x[i]]>mot[x[j]] then
                     begin
                          u:=x[i];
                          x[i]:=x[j];
                          x[j]:=u;
                          write('<',i,',',j,'>');
                          more:=true;
                     end
             end;
      end;
      WriteLN('');
      p:= 0;
      Copie(z,x0);
      while compare(x,x0)<>0 do
      begin
           decompose(e,x);
           compose(z,z,e);
           show(e);
           Write(':');
           Affiche_phrase(z);
           p:=p+1;
      end;
      WriteLN('  <p=',p,'>');
end;



Procedure Question5;
var
   phrase : string;
begin
     Tri('belle marquise vos beaux yeux me font mourir d''amour');
     repeat
     begin
          Write('Entrez votre phrase :');
          ReadLN(phrase);
          Tri(phrase);
     end
     until phrase='';
end;

Procedure Presentation;
begin
    ModeTexte;
    Efface;
    WriteLN('====== Involution =======================');
    WriteLN('                                       ');
    WriteLN('                                       ');
    WriteLN(' (1)  Liste des involutions de En        ');
    WriteLN(' (2)  Nombre d''involutions de En        ');
    WriteLN(' (3)  Décomposition de f               ');
    WriteLN(' (4)  Calcul de B(p,n)                ');
    WriteLN(' (5)  Tri alphabétique d''une phrase    ');
    WriteLN('                                       ');
end;



begin

  while true do
  begin
     Presentation;
     write('Question choisie ? ');
     readln(question);
     Efface;
     writeln('======== Question n°',question,'===============');
     writeln('');

     case question of
          '1':  Question1;
          '2':  Question2;
          '3' : Question3;
          '4' : Question4;
          '5' : Question5;
     end;
     Pause;
  end;

end.