PROGRAM cigogne;
{

Epreuve informatique de l'Ecole Polytechnique           92.026
--------------------------------------------------------------


1/   Pour surveiller une variété de cigognes en voie de dis-
     parition, les écologistes voudraient les repérer au moyen
     d'un système de type "code à barres". Le marquage s'ef-
     fectuerait en traçant sur l'animal une séquence de n
     traits équidistants qui ne peuvent avoir chacun que deux
     aspects : trait fin ou trait épais.

     Il existerait a priori 2n séquences différents. Toute-
     fois, comme la séquence de traits peut être lue dans les
     deux sens, on ne saurait pas distinguer deux séquences
     symétriques xi et yi  telles que :

       pour tout i de 1 à n

     Compte tenu de cette restriction, combien au maximum
     d'animaux différents est-il possible d'identifier avec n
     traits ?

     Ecrire un programme Pascal capable d'imprimer une liste
     ordonnée de codes utilisables (c'est-à-dire tous diffé-
     rents et sans que d'eux d'entre eux soient symétriques
     l'un de l'autre) et l'appliquer au cas n=6.


2/   Le procédé de marquage précédent n'ayant pas donné tech-
     niquement satisfaction, les savants s'orientent mainte-
     nant vers un système de bague enfilée autour d'une patte
     de l'échassier. Le code à barres est maintenant constitué
     de n traits disposés régulièrement autour de la bague,
     ayant toujours chacun deux épaisseurs possibles. Deux
     marquages seront alors indiscernables s'ils ne diffèrent
     l'un de l'autre que par une rotation ou par une symétrie.

     Avec cette nouvelle hypothèse, combien d'animaux diffé-
     rents est-il maintenant possible d'identifier avec n
     traits ?
     Ecrire un programme Pascal qui fournit une liste ordonnée
     des codes utilisables et l'appliquer aux cas n=6 et n=7.


3/   On utilise maintenant un code de couleurs, et on remplace
     les barres par n traits d'épaisseur identique, mais dont
     la couleur peut varier à l'intérieur d'une palette de k
     couleurs différentes.

     Que deviennent les résultats des questions (1) et (2)
     précédentes ?

     Ecrire le programme Pascal qui calcule le nombre de codes
     discernables pour toute valeur du couple (n,k). L'appli-
     quer au cas (n=6, k=3) et donner dans ce cas une liste
     exhaustive de codes utilisables.



                            -=-=-=-
     }


uses
  printer, crt, graph, modubase, entrees;



Const

     nmax = 100;
     maxcouleur = 9;
Type
    couleur  = 1..maxcouleur ;
    sequence = array [1..nmax] of couleur;

VAR
    n,k         : integer;
    x0,x,y,z    : sequence;
    nb          : longint;
    trace       : integer;
    Ch          : char;


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

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

end;



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


Function Compare_sequence(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_sequence := 0
     else
      if y[i]>x[i] then
        compare_sequence := 1
      else
         compare_sequence := -1
end;

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

Procedure Next_sequence(VAR x:sequence);
var
   i : integer;
begin
     i:= n;
     while (i>0) and (x[i]=k) 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 Show_sequence(x:sequence);
var
   i : integer;
begin
     for i:=1 to n do
         write(x[i]:1);
end;




Procedure Presentation;
begin;
      Efface;
      WriteLN(' ======= Les cigognes ========');
      WriteLN('                              ');
      WriteLN('                              ');
      WriteLN('                              ');
      WriteLN('   (1) Question 1             ');
      WriteLN('   (2) Question 2             ');
      WriteLN('   (3) Question 3             ');
      WriteLN('   (4) Question 4             ');
      WriteLN('                              ');
      WriteLN('   Tapez votre choix          ');
      WriteLN('                              ');
      WriteLN('                              ');
end;

Function C(n,k:integer):real;  (* combinatoire k parmi n  *)
var
   i :integer;
   y : real;
begin
     y:=1;
     for i:=1 to k do
         begin
              y:=y*n/i;
              n:=n-1;
         end;
     c:=y;
end;



Function bnk(n,k:integer):real;
begin
   Case n of
     1 : bnk := C(k,1);
     2 : bnk := C(k,1) +C(k,2);
     3 : bnk := C(k,1)+2*C(k,2)+C(k,3);
     4 : bnk := C(k,1)+4*C(k,2)+6*C(k,3)+3*C(k,4);
   else
       bnk:=0;
   end;
end;

Procedure Question1;


begin
     Efface;
     Writeln('  ============ Question n°1 ===============                ');
     Writeln('                                                           ');
     Writeln('         n                                                 ');
     Writeln(' Il y a k    séquences possibles,                          ');
     Writeln('                           ent((n+1)/2)                    ');
     Writeln(' parmi elles, il y en a  k             qui sont symétriques');
     Writeln(' les autres vont par paires, à diviser par deux, d''où     ');
     Writeln('                                                           ');
     Writeln('       ent((n+1)/2)     1     n    ent((n+1)/2)            ');
     Writeln(' nb = k              + --- ( k  - k            )           ');
     Writeln('                        2                                  ');
     Writeln('                                                           ');
     Writeln('            n        ent((n+1)/2)                          ');
     Writeln(' A(n,k) = (k   +   k               )/2                     ');
     Writeln('                                                           ');
     Writeln(' --------------------------------------------------------- ');
     Writeln('                                                           ');

(*  Assign(Lst,'CRT');   *)

  for k:=2 to 100 do
  begin
     nb:=0;
     n:=0;
     Writeln(Lst,'');
     while nb<1000 do
     begin
      n:=n+1;
      Write(Lst,'n,k=',n:4,k:4,'  ');
      nb:=0;
      First_sequence(x0);
      Copy_sequence(x,x0);
      repeat
      begin
          Inverse_sequence(y,x);
          if Compare_sequence(y,x)<0 then
              begin
      {          Write('.');        }
              end
          else
              begin
      {         show_sequence(x);   }
                nb:=nb+1;
              end;
      {   write(' ');               }
          Next_sequence(x);
      end
      until compare_sequence(x,x0)=0;
      Writeln(Lst,'  ---->>> A(',n:2,',',k:2,')=',nb:9,'=',
      (puiss(k,n)+Puiss(k,trunc((n+1)/2)))/2:9:0);
     end;
  end;
end;

Procedure Question2;
var
   i:integer;
   ok : Boolean;
begin
     Efface;
     Writeln('  ============ Question n°2 ===============                ');
     Writeln('                                                           ');

     Writeln('         n');
     Writeln(' Il y a 2    séquences possibles,');
     Writeln(' Nous allons regrouper les séquences par rapport à la');
     Writeln(' relation d''équivalence R(x,y), qui indique si x et y peuvent');
     Writeln(' se déduire l''un de l''autre par rotation ou par symétrie.    ');
     Writeln('                                                             ');
     Writeln(' Pour ce faire, pour chaque x, on génère ses (n-1) permutés  ');
     Writeln(' par rotation et les n symétriques correspondants, et on ne  ');
     Writeln(' compte x que s''il est le plus petit au sens de la           ');
     Writeln(' relation d''ordre.                                           ');
     Writeln('                                                             ');
     Writeln('  B(1,k) = C(k,1)=k                                          ');
     Writeln('  B(2,k)=  C(k,1) +C(k,2)                                  ');
     Writeln('  B(3,k)=  C(k,1)+2*C(k,2)+C(k,3)                            ');
     Writeln('  B(4,k)=  C(k,1)+4*C(k,2)+6*C(k,3)+3*C(k,4)               ');
     Writeln('                                                             ');
     Writeln('                                                             ');

  for k:=2 to 20 do
  begin
     nb:=0;
     n:=0;
     Writeln(lst,'');
     while nb<1000 do
     begin
      n:=n+1;
      Write(lst,'n,k=',n:4,k:4,'  ');
      nb:=0;
      First_sequence(x0);
      Copy_sequence(x,x0);
      repeat
      begin
          Copy_sequence(z,x);
          Inverse_sequence(y,x);
          i:=0;
          ok := true;
          if trace>1 then
           begin
              Write('(');
              show_sequence(x);
              Write('#');
           end ;
          while ok and (i<n) do
          begin
              i:=i+1;
              if trace>1 then
              begin
                   Write('(');
                   show_sequence(z);
                   Write('?');
                   show_sequence(y);
                   Write('?');
              end;
              ok:= (compare_sequence(y,x)>=0) and
                   (compare_sequence(z,x)>=0);
              Rotate_sequence(y);
              Rotate_sequence(z);
          end;
          if trace >1 then
              write(')');
          if ok then
             begin
               if trace>0 then
                  show_sequence(x);
               nb:=nb+1;
             end
          else
             begin
                  if trace>1 then
                     begin
                         Write('(');
                         show_sequence(x);
                         Write(')');
                     end;
                     if trace>0 then
                         Write('.');
             end;
          if trace>0 then
                Write(' ');
          if trace >1 then
                Pause;
          Next_sequence(x);
      end
      until compare_sequence(x,x0)=0;
      Writeln(Lst,'  ---->>> B(',n:2,',',k:2,')=',nb:9,'=',bnk(n,k):9:0,
      '  B(n,k)/k^n=',nb/puiss(k,n):10:6);
     end;
    end;
end;



Procedure Question3;
var
   i:integer;
   ok : Boolean;
begin
     Efface;
     Writeln('  ============ Question n°3 ===============                ');
     Writeln('                                                           ');

     k:= 3;
  begin
     trace := 1;
     begin
      n:=5;
      Write('k,n=',k:4,n:4,'  ');
      nb:=0;
      First_sequence(x0);
      Copy_sequence(x,x0);
      repeat
      begin
          Copy_sequence(z,x);
          Inverse_sequence(y,x);
          i:=0;
          ok := true;
          if trace>1 then
           begin
              Write('(');
              show_sequence(x);
              Write('#');
           end ;
          while ok and (i<n) do
          begin
              i:=i+1;
              if trace>1 then
              begin
                   Write('(');
                   show_sequence(z);
                   Write('?');
                   show_sequence(y);
                   Write('?');
              end;
              ok:= (compare_sequence(y,x)>=0) and
                   (compare_sequence(z,x)>=0);
              Rotate_sequence(y);
              Rotate_sequence(z);
          end;
          if trace >1 then
              write(')');
          if ok then
             begin
               if trace>0 then
                  show_sequence(x);
               nb:=nb+1;
             end
          else
             begin
                  if trace>1 then
                     begin
                         Write('(');
                         show_sequence(x);
                         Write(')');
                     end;
                     if trace>0 then
                         Write('.');
             end;
          if trace>0 then
                Write(' ');
          if trace >1 then
                Pause;
          Next_sequence(x);
      end
      until compare_sequence(x,x0)=0;
      Writeln(' ---->>     nb=',nb:9);
     end;
  end;
end;


Procedure Question4;
var
   i:integer;
   ok : Boolean;
begin
     Efface;
     Writeln('  ============ Question n°4 ===============                ');
     Writeln('                                                           ');


  k:=3;
  begin
     trace := 0;
     for n:= 1 to 100 do
     begin

      Write('n,k=',n:4,k:4,'  ');
      nb:=0;
      First_sequence(x0);
      Copy_sequence(x,x0);
      repeat
      begin
          Copy_sequence(z,x);
          Inverse_sequence(y,x);
          i:=0;
          ok := true;
          if trace>1 then
           begin
              Write('(');
              show_sequence(x);
              Write('#');
           end ;
          while ok and (i<n) do
          begin
              i:=i+1;
              if trace>1 then
              begin
                   Write('(');
                   show_sequence(z);
                   Write('?');
                   show_sequence(y);
                   Write('?');
              end;
              ok:= (compare_sequence(y,x)>=0) and
                   (compare_sequence(z,x)>=0);
              Rotate_sequence(y);
              Rotate_sequence(z);
          end;
          if trace >1 then
              write(')');
          if ok then
             begin
               if trace>0 then
                  show_sequence(x);
               nb:=nb+1;
             end
          else
             begin
                  if trace>1 then
                     begin
                         Write('(');
                         show_sequence(x);
                         Write(')');
                     end;
                     if trace>0 then
                         Write('.');
             end;
          if trace>0 then
                Write(' ');
          if trace >1 then
                Pause;
          Next_sequence(x);
      end
      until compare_sequence(x,x0)=0;
      Writeln(' --->>  B(',n:2,',',k:2,')=',nb:9,'  B(n,k)/k^n=',nb/puiss(k,n):10:6);
     end;
  end;
end;


begin

  while true do
  begin
     trace := 0;
     Presentation;

     While not Keypressed do
     begin
     end;
     Ch:= ReadKey;
     case ch of

     '1':  Question1;
     '2':  Question2;
     '3' : Question3;
     '4' : Question4;

     end;
     Pause;
  end;