PROGRAM Matrice_booleenne;

{
Epreuve informatique de l'Ecole Polytechnique           94.276
--------------------------------------------------------------
(d'après Gérard LANGLET)


     Soit une matrice d'ordre n à coefficients booléens...

1/   Calculer ...

     Ecrire un programme Pascal qui...



2/   ...


3/   ...


4/   ...

+------------------------------------------------------------+
¦              Imprimer tous les résultats                   ¦
¦     en indiquant chaque fois à quoi ils correspondent      ¦
+------------------------------------------------------------+


                             -=-=-}

uses
  crt, modubase;

Const
     Escape=#27;
     maxn  = 16;


Var
    Ch         : Char ;
   
Type
    Myreal = {real }   extended          ;
    Sequence= array[1..maxn]      of Boolean;
    Matbool = array[1..maxn,1..maxn] of Boolean;


Var
   a  : Matbool;
   x,y,z  : Sequence;
   n      : integer;

Function symbool(b:Boolean):char;
begin
   if b then
      symbool:='1'
   else
      symbool:='0';
end;



Procedure Suivant(VAR x:sequence);
var
   i : integer;
begin
     i:=0;
     repeat
           i:=i+1;
           x[i]:= not x[i];
     until x[i] or (i=n)
end;


Function Egal(x,y:Sequence):Boolean;
Var
   z:Boolean;
   i:Integer;
begin
     z:=false;
     for i:=1 to n do
          z:=z or (x[i] xor y[i]);
     Egal := not z;
end;

Procedure Nul(VAR x:Sequence);
Var
   i:Integer;
begin
     for i:=1 to n do
          x[i]:=false;
end;



Function string_sequence(x:Sequence):string;
Var
   s:string;
   i: integer;
begin
     s:='';
     for i:=1 to n do
           s:=s+symbool(x[i])+' ';
     string_sequence:=copy(s,1,2*n-1);
end;

Procedure affiche_mat(a:Matbool);
Var
   i,j:integer;
begin
     for i:=1 to n do
       begin
         for j:=1 to n do
           Write(symbool(a[i,j]),' ');
         WriteLN;
       end;
end;
Procedure affiche_3_mat(a,b,c:Matbool);
Var
   i,j:integer;
begin
     WriteLN('------ a ----- x ----- b ----- = ------ c ---------');
     for i:=1 to n do
       begin
         for j:=1 to n do
           Write(symbool(a[i,j]),' ');
         Write(' : ');
         for j:=1 to n do
           Write(symbool(b[i,j]),' ');
         Write(' : ');
         for j:=1 to n do
           Write(symbool(c[i,j]),' ');
         WriteLN;
       end;
end;

Procedure ident_mat(VAR a:Matbool);
Var
   i,j:integer;
begin
     for i:=1 to n do
         for j:=1 to n do
           a[i,j]:=(i=j);
end;

Procedure zero_mat(VAR a:Matbool);
Var
   i,j:integer;
begin
     for i:=1 to n do
         for j:=1 to n do
           a[i,j]:=false;
end;

Procedure alea_mat(VAR a:Matbool);
Var
   i,j:integer;
begin
     for i:=1 to n do
         for j:=1 to n do
           a[i,j]:=(random>0.5);
end;

Procedure Transpose_mat(a:matbool;VAR b:Matbool);
Var
   i,j:integer;
begin
     for i:=1 to n do
         for j:=1 to n do
           b[i,j]:=a[j,i];
end;

Procedure Transpose2_mat(a:matbool;VAR b:Matbool);
Var
   i,j:integer;
begin
     for i:=1 to n do
         for j:=1 to n do
           b[i,j]:=a[1+n-j,1+n-i];
end;

function Egal_mat(a,b:Matbool):Boolean;
Var
   i,j:integer;
   done:Boolean;
begin
     Egal_mat:=false;
     i:=1;
     j:=1;
     repeat
           done:= a[i,j] xor b[i,j];
           if not done then
            begin
             if j<n then
              Inc(j)
             else
               if i<n then
                  begin
                       Inc(i);
                       j:=1;
                  end
               else
                   begin
                        done:=true;
                        Egal_mat:=true;
                  end;
             end;
     until done;
end;

procedure Suivant_mat(var a:Matbool);
Var
   i,j:integer;
   b,done:Boolean;
begin
     i:=1;
     j:=1;
     repeat
           a[i,j]:=not a[i,j];
           done:=a[i,j];
           if not done then
            begin
             if j<n then
              Inc(j)
             else
               if i<n then
                  begin
                       Inc(i);
                       j:=1;
                  end
               else
                   done:=true;
             end;
     until done;
end;

Procedure prod_mat(a,b:Matbool;VAR c:Matbool);
Var
   z : Boolean;
   i,j,k:integer;
begin
     for i:=1 to n do
         for j:=1 to n do
          begin
               z:=False;
               for k:=1 to n do
                   z:=z xor (a[i,k] and b[k,j]);
               c[i,j]:=z;
          end;
end;

Procedure cube_mat(a:Matbool;VAR b:Matbool);
begin
     Prod_mat(a,a,b);
     Prod_mat(b,a,b);
end;

Procedure mat_vec(a:Matbool;x:Sequence;VAR y:Sequence);
Var
   z: Boolean;
   i,j:integer;
begin
     for i:=1 to n do
       begin
         z:=False;
         for j:=1 to n do
           z:=z xor (a[i,j] and x[j]);
         y[i]:=z;
       end;
end;

Procedure transforme (VAR a,b,c:Matbool);
begin
     Prod_mat(c,a,a);
     Prod_mat(c,b,b);
     {  illustre(a,b,c);  }
end;


Procedure echange(VAR a,b:matbool;i,j:integer);
var
   k:integer;
   c:Matbool;
begin
   {  WriteLN('<<Echange ',i,' et ',j,'>>');Pause; }
     Ident_mat(c);
     c[i,i]:=false;
     c[j,j]:=false;
     c[i,j]:=true;
     c[j,i]:=true;
     Transforme(a,b,c);
end;


Procedure combine(VAR a,b:matbool;i,j:integer);
var
   k:integer;
   c:Matbool;
begin
    { WriteLN('<<Combine ',i,' et ',j,'>>');Pause;   }
     Ident_mat(c);
     c[i,j]:=true;
     Transforme(a,b,c);
end;




Procedure inv_bool(a:Matbool;VAR b:Matbool;VAR inversible:Boolean);
var
   i,j:integer;
begin
     inversible:=true;
     ident_mat(b);
     j:=0;
     repeat
      i:=j;
      j:=j+1;
      repeat
         i:=i+1;
      until a[i,j] or (i>n);
      if i>n then
         inversible:=false
      else
         begin
           echange(a,b,i,j);
           for i:=1 to n do
               if (i<>j) and a[i,j] then
                  combine(a,b,i,j);
         end;
     until (j=n) or not inversible
end;



function determinant(a:Matbool):boolean;
var
     b:matbool;
     inversible:Boolean;
begin
     Inv_bool(a,b,inversible);
     determinant:=inversible;
end;



Procedure Vecteurs_propres;
Var
   a,b,c: Matbool;
   Nombre:integer;
   m:Matrice;
   inversible : Boolean;
begin
     repeat
      ClrScr;
      alea_mat(a);
      Inv_bool(a,b,inversible);
      if inversible then
        begin
              Prod_mat(a,b,c);
              affiche_3_mat(a,b,c);
        end
      else
          affiche_mat(a);
      WriteLN('========== recherche des vecteurs propres   ax=x  =========');
      Nul(z);
      Nul(x);
      Nombre:=0;
      repeat
            mat_vec(a,x,y);
            if egal(x,y) then
              begin
               Inc(Nombre);
               WriteLN('a(',string_sequence(x),') = ',string_sequence(y));
              end;
            suivant(x);
      until egal(x,z);
      WriteLN('===> Il y a ',Nombre,' vecteur(s) propre(s)');
      if Nombre>4 then
         Pause;
     until KeyPressed;
end;


Procedure Afficher_racines_cubiques(m:matbool);
var
   zero,un,
   a,b,c:matbool;
   compteur1,compteur2:integer;
begin
     Zero_mat(zero);
      Ident_mat(un);
      a:=zero;
      compteur1:=0;
      compteur2:=0;
      repeat
            Prod_mat(a,a,b);
            Prod_mat(b,a,c);
           Inc(compteur2);
           if egal_mat(c,m) then
              begin
                   Inc(compteur1);
                   Affiche_3_mat(a,b,c);
              end;
           Suivant_mat(a);
      until egal_mat(a,zero);
      WriteLN(compteur1,' racines cubiques de A trouvées.');
      PAuse;
end;

Procedure Presentation;
Begin
      Efface;
      n:=8;
    {  Write('Dimension des vecteurs/matrices : n=');
      ReadLN(n);  }


      WriteLN(' ========== Racine cubique de matrice  ================');
      WriteLN('                                        ');
      WriteLN('                                        ');
      WriteLN('   (1) Résolution de J.J.J=I            ');
      WriteLN('   (2) Comptage des solutions de BBB=A  ');
      WriteLN('   (3) Affichage des solutions de BBB=A');
      WriteLN('   (4) Racines cubiques de I           ');
      WriteLN('                              ');
      Write('   Tapez votre Choix  :  ');
end;




procedure Question1;
var
   zero,un,a,b,c,d:Matbool;
   compteur1,compteur2:Longint;
begin

     ClrScr;

     WriteLN('+------------------------------------------------------------+');
     WriteLN('¦ Question n°1 :  Recherche des racines cubiques de I        ¦ ');
     WriteLN('¦                                                            ¦');
     WriteLN('¦ On procède par balayage systématique, par matrices         ¦');
     WriteLN('¦ carrées de poids croissant.                                ¦');
     WriteLN('¦ Si J est une solution toute permutation d''indices P        ¦');
     WriteLN('¦ en donne une autre P-1JP                                   ¦');
     WriteLN('¦                                                            ¦');
     WriteLN('¦ Il y a p! permutations possibles.                          ¦');
     WriteLN('¦ Donc si J est solution, on en déduit p!                    ¦');
     WriteLN('+------------------------------------------------------------+');
     PAuse;
     Efface;
     n:=0;
     repeat
      Inc(n);
      Zero_mat(zero);
      Ident_mat(un);
      a:=zero;
      compteur1:=0;
      compteur2:=0;
      repeat
            Prod_mat(a,a,b);
            Prod_mat(b,a,c);
           Inc(compteur2);
           if egal_mat(c,un) then
              begin
                   Inc(compteur1);
                   if n<4 then Affiche_3_mat(a,b,c);
{                   Transpose2_mat(a,d);
                   If egal_mat(d,b) then
                   begin
                      WriteLN('<<<<<<<<< SYMETRIE >>>>>>>>>>>>>>');
                   end;
                   WriteLN('**** Racine cubique de l''unité ******** ');}
                   Write('.');
              end;
           Suivant_mat(a);
      until egal_mat(a,zero);
      WriteLN;
      WriteLN('======= Pour p=',n,' il y a ',compteur1,'/',compteur2,' solutions === soit',100*compteur1/compteur2:5:1,'%');
      PAuse;
    until false;
end;


procedure Question2;
var
   zero,un,a,a2,a3,b:Matbool;
   compteur1,compteur2:Longint;
   compteur : array[0..1,0..64] of integer;
   i,j:integer;
begin
     WriteLN('+------------------------------------------------------------+');
     WriteLN('¦ Question n°2 :  Comptage des racine cubiques de A pour p=3 ¦ ');
     WriteLN('¦                                                            ¦');
     WriteLN('¦ On procède par balayage systématique.                      ¦');
     WriteLN('+------------------------------------------------------------+');
     PAuse;
     Efface;
     Efface;
     WriteLN('Racine cubique de B');
     Write('Entrez p=');Readln(n);
     Zero_mat(zero);
     Ident_mat(un);
     b:=zero;
      for i:=0 to 1 do
              for j:=0 to 64 do
                  compteur[i,j]:=0;
     repeat
      Affiche_mat(b);
{      Write('Déterminant =',symbool(determinant(b)),' --> ');}
      a:=zero;
      compteur1:=0;
      compteur2:=0;
      repeat
            Prod_mat(a,a,a2);
            Prod_mat(a2,a,a3);
           Inc(compteur2);
           if egal_mat(a3,b) then
              begin
                   Inc(compteur1);
            {       Affiche_3_mat(a,a2,a3);
                   WriteLN('**** Racine cubique de B ******** ');  }
              end;
           Suivant_mat(a);
      until egal_mat(a,zero);
  {    Write('Déterminant =',symbool(determinant(b))); }
      WriteLN(compteur1,'/',compteur2,' solutions.');
{      if determinant(b) then
         inc(compteur[1,compteur1])
      else}
          inc(compteur[0,compteur1]);

      Clrscr;
      for i:=0 to 1 do
          begin
              WriteLN('Determinant(A)=',i,' :');
              for j:=0 to 64 do
                  Write(compteur[i,j],' ');
              WriteLN;
          end;
      suivant_mat(b);
  until egal_mat(b,zero);
  PAuse;
end;


procedure Question3;
var
   zero,un,a:Matbool;
begin

     WriteLN('+------------------------------------------------------------+');
     WriteLN('¦ Question n°3 :  Inventaires des racines cubiques de A      ¦ ');
     WriteLN('¦                                                            ¦');
     WriteLN('¦ choisir le cas :                                           ¦');
     WriteLN('¦  (1)  A=zero                                               ¦');
     WriteLN('¦  (2)  A=identité                                           ¦');
     WriteLN('¦  (3)  A aléatoire                                          ¦');
     WriteLN('+------------------------------------------------------------+');
     n:=3;
      Zero_mat(zero);
      Ident_mat(un);
      repeat
            Repeat
                  Read(Ch)
            until Ch in ['0'..'3'];
          case ch of
               '1':  Afficher_racines_cubiques(zero);
               '2':  Afficher_racines_cubiques(un);
               '3' : begin
                          Alea_mat(a);
                          Afficher_racines_cubiques(a);
                     end;
          end;
      until ch='0';
      Afficher_racines_cubiques(un);
end;

procedure Question4;
var
   zero,un,a:Matbool;
begin

     WriteLN('+------------------------------------------------------------+');
     WriteLN('¦ Question n°4 :  Inventaires des racines cubiques de I      ¦ ');
     WriteLN('¦                                                            ¦');
     WriteLN('+------------------------------------------------------------+');
     n:=0;
     repeat
           Inc(n);
           WriteLN('================== p=',n,' ===========');
           Ident_mat(un);
           Afficher_racines_cubiques(un);
           Pause;
     until false;
end;



Begin
     while true do
     begin
          Presentation;
          Repeat
              Read(Ch)
          until Ch in ['0'..'4'];
          case ch of
               '1':  Question1;
               '2':  Question2;
               '3' : Question3;
               '4' : Question4;
               '0' : Halt
          end;
     Pause;
  end;
end.