BLOCK
(*  auteurs V.Borry et V.Iriart *)
(* Licence  GR2.  1993/94       *)

  Const noir = 0 ,
	rouge = 1 ,
	vert = 2 ,
	jaune = 3 ,
	bleu = 4 ,
	magenta = 5 ,
	cyan = 6 ,
	blanc = 7 ;

(* Fonction qui attend qu'un caractŠre soit tap‚ au clavier *)
(* et le renvoie *)
   UNIT GetChar:function:char;
   var a:integer;
   begin
      pref IIUWGRAPH block
         begin
            a:=0;
            while a=0
	       do
                  a:=inkey;
               od;
            result:=chr(a);
         end;
    End GetChar;

(* Fonction qui saisit une chaine de caractŠres et la place dans un tableau *)
(* de caractŠres *)
   UNIT SaisieString : function : arrayof char ;
   var a : char ,
       s , tmp : arrayof char ,
       i , long : integer ;
   Begin
      a:=getchar;
      array tmp dim (1:255);
      long:=1;
      while (ord(a)<>13)
      do
	 write(a);
         tmp(long):=a;
	 long:=long+1;
         a:=getchar;
      od;
      writeln;
      long:=long-1;
      array s dim (1:long);
      for i:=1 to long do s(i):=tmp(i); od ;
      result:=s;
   End saisiestring;

(* Procedure permettant de choisir la couleur d'‚criture et de fond du texte *)
  UNIT Couleur : procedure ( texte,fond : integer);
  var t , f : char ;
  Begin
     t:=chr(48+texte);
     f:=chr(48+fond);
     Write ( chr(27) , "[1;3",t,";4",f,"m");
  End couleur;

(* Procedure permettant d'effacer la ligne courante *)
  UNIT EraseLine : procedure;
  Begin
    Write( chr(27), "[K")
  End EraseLine;

(* Procedure permettant d'effacer entiŠrement l'‚cran *)
  UNIT Cls : procedure;
  Begin
    Write( chr(27), "[2J");
    Write( chr(27), "[H");
  End Cls;

(* Procedure permettant de positionner le curseur sur l'‚cran *)
  UNIT  SetCursor : procedure(column, row : integer);
    var c,d,e,f  : char,
        i,j : integer;
  Begin
    i := row div 10;
    j := row mod 10;
    c := chr(48+i);
    d := chr(48+j);
    i := column div 10;
    j := column mod 10;
    e := chr(48+i);
    f := chr(48+j);
    Write( chr(27), "[", c, d, ";", e, f, "H")
  End SetCursor;


(* Procedure permettant de calculer a exposant b *)
UNIT exposant : function (a,b:integer) : integer ;
   Begin
      result:=round(exp(b*ln(a)));
   End exposant;

(* Procedure affichant le r‚sultat d'un essai de pattern matching *)
UNIT afficheresultat : procedure (resultat : boolean);
Begin
      call couleur(cyan,noir);
      call setcursor(18,18);
      if resultat then
         Writeln("Le pattern a ete trouve dans la chaine");
      else
         Writeln("Le pattern n'a pas ete trouve dans la chaine");
      fi;
      call couleur(blanc,noir);
      call setcursor(55,24);
      Write("Appuyez sur ENTREE");
      readln;
End afficheresultat;

(* Procedure mettant en place les differents textes sur l'‚cran *)
UNIT afficheecran : procedure (p , s : arrayof char);
var t : integer ;
   Begin
      call couleur(blanc,noir);
      call Cls;
      Write("Pattern : ");
      call couleur(jaune,noir);
      for t:=1 to upper(p)
      do
         Write(p(t));
      od ;
      writeln;
      call couleur(blanc,noir);
      Writeln;
      Writeln("Chaine ou on cherche le pattern :");
      call couleur(jaune,noir);
      for t:=1 to upper(s)
      do
         Write(s(t));
      od ;
   End afficheecran ;


(**************************************************************************)
(*                                                                        *)
(*                       ALGORITHME SIMPLE                                *)
(*                                                                        *)
(**************************************************************************)
UNIT AlgoSimple : procedure ( p , s : arrayof char) ;

(* Procedure ecrivant diff‚rents textes sur l'‚cran *)

   UNIT ecran : procedure ;
   Begin
      call couleur(blanc,noir);
      call setcursor(1,10);
      Writeln("On compare la premiere lettre de : ");
      Writeln("      avec la premiere lettre de : ");
      Writeln;
      Writeln("Si elles sont egales, on reduit le pattern de 1 caractere");
   End ecran ;

(* Procedure permettant d'afficher les diff‚rentes ‚tapes de l'ex‚cution de *)
(* l'algorithme *)

   UNIT AfficheChaine : procedure (p,s:arrayof char; posp,poss : integer);
   Var t , longs , longp , posx , longtest : integer ;
   var car : char
      Begin
         posx:=35;
         longp:=upper(p);
         longs:=upper(s);
         longtest:=longp-posp+1;
         call couleur(jaune,bleu);
         call setcursor(35,10);
         for t:=posp to longp
         do
            Write(p(t));
         od;
         call couleur(jaune,noir);
         Write(" ");
         for t:=1 to longs
         do
            if ( (t>=poss) and (t<poss+longtest) ) then
               call couleur(jaune,bleu);
               call setcursor(posx,11);
               Write(s(t));
               posx:=posx+1;
               call couleur(jaune,noir);
               Write(" ");
               call couleur(jaune,bleu);
            else
               call couleur(jaune,noir);
            fi;
            call setcursor(t,4);
            Write(s(t));
         od;
         car:=getchar;
   End AfficheChaine;

   Var i , j , m , n : integer ,
       resultat : boolean ;

(* corps de l'algorithme simple *)
   Begin
   (* initialisations *)
      call afficheecran (p,s);
      call ecran ;
      m:=upper(p);
      n:=upper(s);
      i:=1;
      j:=1;

   (* boucle principale *)
      while ((i<=m) and (j<=n))
      do
         call AfficheChaine(p,s,i,j);
         if p(i)=s(j) then
            i:=i+1;
            j:=j+1;
         else
            i:=1;
            j:=j-i+2;
         fi;
         resultat:=(i>m);
      od;
      call afficheresultat(resultat) ;
End AlgoSimple;



(**************************************************************************)
(*                                                                        *)
(*                   ALGORITHME DE KNUTH, MORRIS et PRATT                 *)
(*                                                                        *)
(**************************************************************************)
UNIT AlgoKMP : procedure(p , s : arrayof char) ;

(* procedure permettant d'effectuer les affichages *)

   UNIT ecran : procedure (h:arrayof integer) ;
   var i : integer ;
   begin
      call couleur(blanc,noir);
      call setcursor(1,7);
      writeln("On compare le caractere en surbrillance du pattern avec celui de la chaine.");
      writeln("Quand on trouve un caractere non correspondant, on revient en arriere dans le");
      writeln("pattern d'un nombre n de positions.");
      writeln("n est donn‚ par la table suivante:");
      writeln("caractere num  :");
      writeln("hash code (=n) :");
      call couleur(jaune,noir);
      for i:=1 to upper(h)
      do
	 call setcursor(13+i*4,11);
	 write(i:4);
	 call setcursor(13+i*4,12);
	 write(h(i):4);
      od;
   end ecran ;

(* procedure d'affichage du texte *)

   UNIT AfficheChaine : procedure (p,s:arrayof char; posp,poss : integer);
   Var t , longs , longp : integer ;
   Var car : char ;
      Begin
         longp:=upper(p);
         longs:=upper(s);
         call setcursor(11,1);
         for t:=1 to longp
         do
            if (t=posp) then
               call couleur(jaune,bleu);
            else
               call couleur(jaune,noir);
            fi;
            Write(p(t));
         od;
         call setcursor(1,4);
         for t:=1 to longs
         do
            if (t=poss) then
               call couleur(jaune,bleu);
            else
               call couleur(jaune,noir);
            fi;
            Write(s(t));
         od;
         car:=getchar;
   End AfficheChaine;

(* Procedure de calcul de la hash function, stockee dans une table *)

  UNIT KMPhash : function(p : arrayof char) : arrayof integer;
  var i, j : integer,
      h : arrayof integer ,
      sortie: boolean ;

    Begin
    (* initialisations *)
       i := 1;
       j := 0;
       m := upper(p);
       array h dim (1:m);
       h(1) := 0;

    (* boucle principale *)
       while (i < m)
       do
          sortie:=false ;
          while (not sortie)
          do
            sortie:=true;
            if (j>0) then
               if (p(j) <> p(i)) then
                  sortie:=false ;
                  j:=h(j);
               fi ;
            fi ;
          od;

          i := i+1;
          j := j+1;
          if (p(i) = p(j)) then h(i) := h(j);
            else h(i) := j;
          fi;
       od;
       result:=h;
    End KMPhash;

var i, j, m, n : integer,
    h : arrayof integer,
    sortie , resultat : boolean;

(* Corps de l'algorithme KMP *******************)

Begin
   call afficheecran(p,s);

   (* initialisations *)
   m := upper(p);
   n := upper(s);
   array h dim(1:m);
   h := KMPhash(p);
   call ecran(h);
   i := 1;
   j := 1;

   (* boucle principale *)
   while ((i <= m) and (j <= n))
   do
       sortie:=false;
       while (not sortie)
       do
         sortie:=true;
         if (i>0) then
            if (p(i) <> s(j)) then
               sortie:=false ;
               i:=h(i);
	       call setcursor(1,14);
	       call couleur(blanc,noir);
	       write("On se deplace a la position : ",i);
            fi ;
         if (i>0) then
	    call affichechaine(p,s,i,j);
	 else
	    call setcursor(1,14);
	    call couleur(blanc,noir);
	    call eraseline;
	    call affichechaine(p,s,i+1,j);
	 fi;
         fi;
       od;
      i := i+1;
      j := j+1;
    od;
    resultat := (i > m);
    call afficheresultat(resultat);
 End AlgoKMP;

(**************************************************************************)
(*                                                                        *)
(*                      ALGORITHME DE KARP et RABIN                       *)
(*                                                                        *)
(**************************************************************************)
UNIT AlgoKarpRabin : procedure (p , s : arrayof char);

(* Affichage de l'ecran et des commentaires *)

   UNIT Ecran : Procedure (hash : integer);
     begin
        call couleur(blanc,noir);
	call setcursor(1,8);
	write("Hash code du pattern           :");
        call couleur(jaune,noir);
        writeln(hash);
        call couleur(blanc,noir);
	writeln("Hash code du texte selectionne :");
   end ecran ;

(* procedure d'affichage du texte *)

   UNIT AfficheChaine : procedure (s:arrayof char ; poss ,longp,hash:integer);
   Var t , longs : integer ;
   Var car : char ;
      Begin
         longs:=upper(s);
         call couleur(jaune,noir);
         call setcursor(33,9);
         write(hash);
         call setcursor(1,4);
         for t:=1 to longs
         do
            if ( (t>=poss) and (t<poss+longp) ) then
               call couleur(jaune,bleu);
            else
               call couleur(jaune,noir);
            fi;
            Write(s(t));
         od;
         car:=getchar;
   End AfficheChaine;

(* Procedure de calcul de la premiere valeur de la hash function *)

    UNIT hashfunction : function( str : arrayof char, m : integer ):integer;
      var a : integer;
      Begin
         result := 0;
         for a := 1 to m do
                result := result + ord(str(a)) ;
         od;
      End hashfunction;

(* Procedure de calcul des valeurs suivantes de la hash function *)

      UNIT newhash : function( oldh , m ,j:integer, str : arrayof char ): integer;
         Begin
	    result:=oldh + ord(str(j+m)) - ord(str(j)) ;
         End newhash;

var j, m, n, a , d : integer,
    hpat, hstr : integer ,
    trouve : boolean;

(* Corps de l'algorithme KR ************************)

   Begin

    (* initialisations *)
      call afficheecran(p,s);
      j := 1;
      trouve := false;
      m := upper(p);
      n := upper(s);
      hpat := hashfunction(p,m);
      hstr := hashfunction(s,m);
      call ecran(hpat);
      j:=1;

      (* boucle principale *)
      do
         if ( hpat = hstr ) then
	      call couleur(blanc,noir);
	      call setcursor(1,12);
	      write("Les deux hashcodes correspondent, on compare le pattern et la selection");
              a := 1;
              trouve :=  true;
              while ((trouve) and (a <= m))
              do
                 if ( p(a) = s(j+a-1) ) then
                    a := a+1
                 else
                    trouve := false;
                 fi
              od;
	   else
	      call couleur(blanc,noir);
	      call setcursor(1,12);
	      call eraseline;
           fi;
           call affichechaine(s,j,m,hstr);
           if ( (j>= (n-m+1)) or ( trouve) ) then exit fi;
           hstr := newhash(hstr , m , j , s);
	   j:=j+1;

      od;
      call afficheresultat(trouve);
   End AlgoKarpRabin;

(**************************************************************************)
(*                                                                        *)
(*         ALGORITHME DE BOYER et MOORE (modifi‚ HORSPOOL)                *)
(*                                                                        *)
(**************************************************************************)
UNIT AlgoBoyerMoore : procedure ( p , s : arrayof char);

(* procedure d'affichage du texte *)

   UNIT AfficheChaine : procedure (s:arrayof char; poss : integer);
   Var t , longs : integer ;
   Var car : char ;
      Begin
         longs:=upper(s);
         call setcursor(1,4);
         for t:=1 to longs
         do
            if (t=poss) then
               call couleur(jaune,bleu);
            else
               call couleur(jaune,noir);
            fi;
            Write(s(t));
         od;
         car:=getchar;
   End AfficheChaine;

(* Procedure de remplissage de la table Delta *)

UNIT Delta : function (p : arrayof char) : arrayof integer ;

Var d : arrayof integer,
    a : integer;

Begin
   array d dim(1:127);
   m:=upper(p);
   (* initialisation *)
   for a:=1 to 127 do
     d(a):=m;
   od;
   (* calcul pour le pattern *)
   for a:=1 to m-1 do
     d(ord(p(a))):=m-a;
   od;
   result:=d;
End Delta;

var j, m, n, a : integer,
    trouve : boolean,
    d : arrayof integer;


(* Corps de l'algorithme BM ************************)

Begin
  (* initialisations *)
   call afficheecran(p,s);
   m:=upper(p);
   n:=upper(s);
   d:=Delta(p);
   j:=m;
   trouve:=false;

   (* boucle principale *)
   while ( (j<=n) and (not trouve) )
   do
      call affichechaine(s,j);
      if (s(j) = p(m)) then
	 trouve:=true;
         for a:=1 to m
         do
            if (p(a)<>s(j-m+a)) then
	       trouve:=false;
	    fi;
         od;
      fi;
         call couleur(blanc,noir);
         call setcursor(1,8);
      if (not trouve) then
         writeln("La derniere lettre du pattern ne correspond pas avec la lettre de la chaine");
	 writeln("en surbrillance, alors on se deplace de ",d(ord(s(j))):2," positions");
      else
	 call eraseline;
	 writeln;
	 call eraseline;
      fi;
      j:=j+d(ord(s(j)));
   od;
   call afficheresultat(trouve);

End AlgoBoyerMoore ;


(* Procedure affichant le premier ecran et saisissant les choix *)

UNIT EcranPrincipal : procedure ;
var choix : integer ,
    p , s : arrayof char ;
   Begin
   choix:=0;
   while (choix<>5)
   do
      call couleur(blanc,noir);
      call cls;
      call setcursor(27,1);
      Write("Programme Pattern Matcher");
      call setcursor(27,2);
      Write("-------------------------");
      call setcursor(1,22);
      writeln("Tous les algorithmes s'executent en pas a pas, il faut appuyer sur une touche");
      write("pour faire s'executer le pas suivant...");

      call setcursor(1,6);
      writeln("   1) Algorithme simple");
      writeln("   2) Algorithme de Karp et Rabin");
      writeln("   3) Algorithme de Knuth, Morris et Pratt");
      writeln("   4) Algorithme de Boyer et Moore");
      writeln("   5) Quitter le programme");
      writeln;
      write("Votre choix : ");
      readln(choix);
      if (choix < 5) then
         writeln;
      	 writeln("Saisie de la chaine ou on recherche le pattern :");
         call couleur(jaune,noir);
       	 s:=saisiestring;
         call couleur(blanc,noir);
      	 writeln("Saisie du pattern a rechercher :");
         call couleur(jaune,noir);
      	 p:=saisiestring;
         call couleur(blanc,noir);
      	 case choix
	 when 1 : call algoSimple(p,s);
         when 2 : call algoKarpRabin(p,s);
         when 3 : call algoKMP(p,s);
         when 4 : call algoBoyerMoore(p,s);
         esac ;
      fi;
   od;
   End EcranPrincipal;


(***************************************************************************)
(*                        PROGRAMME PRINCIPAL                              *)
(***************************************************************************)


Begin
   call ecranprincipal;
End;