examples/apply/paretn.log

   1 BLOCK\r
   2 (*  auteurs V.Borry et V.Iriart *)\r
   3 (* Licence  GR2.  1993/94       *)\r
   4 \r
   5   Const noir = 0 ,\r
   6         rouge = 1 ,\r
   7         vert = 2 ,\r
   8         jaune = 3 ,\r
   9         bleu = 4 ,\r
  10         magenta = 5 ,\r
  11         cyan = 6 ,\r
  12         blanc = 7 ;\r
  13 \r
  14 (* Fonction qui attend qu'un caract\8are soit tap\82 au clavier *)\r
  15 (* et le renvoie *)\r
  16    UNIT GetChar:function:char;\r
  17    var a:integer;\r
  18    begin\r
  19       pref IIUWGRAPH block\r
  20          begin\r
  21             a:=0;\r
  22             while a=0\r
  23                do\r
  24                   a:=inkey;\r
  25                od;\r
  26             result:=chr(a);\r
  27          end;\r
  28     End GetChar;\r
  29 \r
  30 (* Fonction qui saisit une chaine de caract\8ares et la place dans un tableau *)\r
  31 (* de caract\8ares *)\r
  32    UNIT SaisieString : function : arrayof char ;\r
  33    var a : char ,\r
  34        s , tmp : arrayof char ,\r
  35        i , long : integer ;\r
  36    Begin\r
  37       a:=getchar;\r
  38       array tmp dim (1:255);\r
  39       long:=1;\r
  40       while (ord(a)<>13)\r
  41       do\r
  42          write(a);\r
  43          tmp(long):=a;\r
  44          long:=long+1;\r
  45          a:=getchar;\r
  46       od;\r
  47       writeln;\r
  48       long:=long-1;\r
  49       array s dim (1:long);\r
  50       for i:=1 to long do s(i):=tmp(i); od ;\r
  51       result:=s;\r
  52    End saisiestring;\r
  53 \r
  54 (* Procedure permettant de choisir la couleur d'\82criture et de fond du texte *)\r
  55   UNIT Couleur : procedure ( texte,fond : integer);\r
  56   var t , f : char ;\r
  57   Begin\r
  58      t:=chr(48+texte);\r
  59      f:=chr(48+fond);\r
  60      Write ( chr(27) , "[1;3",t,";4",f,"m");\r
  61   End couleur;\r
  62 \r
  63 (* Procedure permettant d'effacer la ligne courante *)\r
  64   UNIT EraseLine : procedure;\r
  65   Begin\r
  66     Write( chr(27), "[K")\r
  67   End EraseLine;\r
  68 \r
  69 (* Procedure permettant d'effacer enti\8arement l'\82cran *)\r
  70   UNIT Cls : procedure;\r
  71   Begin\r
  72     Write( chr(27), "[2J");\r
  73     Write( chr(27), "[H");\r
  74   End Cls;\r
  75 \r
  76 (* Procedure permettant de positionner le curseur sur l'\82cran *)\r
  77   UNIT  SetCursor : procedure(column, row : integer);\r
  78     var c,d,e,f  : char,\r
  79         i,j : integer;\r
  80   Begin\r
  81     i := row div 10;\r
  82     j := row mod 10;\r
  83     c := chr(48+i);\r
  84     d := chr(48+j);\r
  85     i := column div 10;\r
  86     j := column mod 10;\r
  87     e := chr(48+i);\r
  88     f := chr(48+j);\r
  89     Write( chr(27), "[", c, d, ";", e, f, "H")\r
  90   End SetCursor;\r
  91 \r
  92 \r
  93 (* Procedure permettant de calculer a exposant b *)\r
  94 UNIT exposant : function (a,b:integer) : integer ;\r
  95    Begin\r
  96       result:=round(exp(b*ln(a)));\r
  97    End exposant;\r
  98 \r
  99 (* Procedure affichant le r\82sultat d'un essai de pattern matching *)\r
 100 UNIT afficheresultat : procedure (resultat : boolean);\r
 101 Begin\r
 102       call couleur(cyan,noir);\r
 103       call setcursor(18,18);\r
 104       if resultat then\r
 105          Writeln("Le pattern a ete trouve dans la chaine");\r
 106       else\r
 107          Writeln("Le pattern n'a pas ete trouve dans la chaine");\r
 108       fi;\r
 109       call couleur(blanc,noir);\r
 110       call setcursor(55,24);\r
 111       Write("Appuyez sur ENTREE");\r
 112       readln;\r
 113 End afficheresultat;\r
 114 \r
 115 (* Procedure mettant en place les differents textes sur l'\82cran *)\r
 116 UNIT afficheecran : procedure (p , s : arrayof char);\r
 117 var t : integer ;\r
 118    Begin\r
 119       call couleur(blanc,noir);\r
 120       call Cls;\r
 121       Write("Pattern : ");\r
 122       call couleur(jaune,noir);\r
 123       for t:=1 to upper(p)\r
 124       do\r
 125          Write(p(t));\r
 126       od ;\r
 127       writeln;\r
 128       call couleur(blanc,noir);\r
 129       Writeln;\r
 130       Writeln("Chaine ou on cherche le pattern :");\r
 131       call couleur(jaune,noir);\r
 132       for t:=1 to upper(s)\r
 133       do\r
 134          Write(s(t));\r
 135       od ;\r
 136    End afficheecran ;\r
 137 \r
 138 \r
 139 (**************************************************************************)\r
 140 (*                                                                        *)\r
 141 (*                       ALGORITHME SIMPLE                                *)\r
 142 (*                                                                        *)\r
 143 (**************************************************************************)\r
 144 UNIT AlgoSimple : procedure ( p , s : arrayof char) ;\r
 145 \r
 146 (* Procedure ecrivant diff\82rents textes sur l'\82cran *)\r
 147 \r
 148    UNIT ecran : procedure ;\r
 149    Begin\r
 150       call couleur(blanc,noir);\r
 151       call setcursor(1,10);\r
 152       Writeln("On compare la premiere lettre de : ");\r
 153       Writeln("      avec la premiere lettre de : ");\r
 154       Writeln;\r
 155       Writeln("Si elles sont egales, on reduit le pattern de 1 caractere");\r
 156    End ecran ;\r
 157 \r
 158 (* Procedure permettant d'afficher les diff\82rentes \82tapes de l'ex\82cution de *)\r
 159 (* l'algorithme *)\r
 160 \r
 161    UNIT AfficheChaine : procedure (p,s:arrayof char; posp,poss : integer);\r
 162    Var t , longs , longp , posx , longtest : integer ;\r
 163    var car : char\r
 164       Begin\r
 165          posx:=35;\r
 166          longp:=upper(p);\r
 167          longs:=upper(s);\r
 168          longtest:=longp-posp+1;\r
 169          call couleur(jaune,bleu);\r
 170          call setcursor(35,10);\r
 171          for t:=posp to longp\r
 172          do\r
 173             Write(p(t));\r
 174          od;\r
 175          call couleur(jaune,noir);\r
 176          Write(" ");\r
 177          for t:=1 to longs\r
 178          do\r
 179             if ( (t>=poss) and (t<poss+longtest) ) then\r
 180                call couleur(jaune,bleu);\r
 181                call setcursor(posx,11);\r
 182                Write(s(t));\r
 183                posx:=posx+1;\r
 184                call couleur(jaune,noir);\r
 185                Write(" ");\r
 186                call couleur(jaune,bleu);\r
 187             else\r
 188                call couleur(jaune,noir);\r
 189             fi;\r
 190             call setcursor(t,4);\r
 191             Write(s(t));\r
 192          od;\r
 193          car:=getchar;\r
 194    End AfficheChaine;\r
 195 \r
 196    Var i , j , m , n : integer ,\r
 197        resultat : boolean ;\r
 198 \r
 199 (* corps de l'algorithme simple *)\r
 200    Begin\r
 201    (* initialisations *)\r
 202       call afficheecran (p,s);\r
 203       call ecran ;\r
 204       m:=upper(p);\r
 205       n:=upper(s);\r
 206       i:=1;\r
 207       j:=1;\r
 208 \r
 209    (* boucle principale *)\r
 210       while ((i<=m) and (j<=n))\r
 211       do\r
 212          call AfficheChaine(p,s,i,j);\r
 213          if p(i)=s(j) then\r
 214             i:=i+1;\r
 215             j:=j+1;\r
 216          else\r
 217             i:=1;\r
 218             j:=j-i+2;\r
 219          fi;\r
 220          resultat:=(i>m);\r
 221       od;\r
 222       call afficheresultat(resultat) ;\r
 223 End AlgoSimple;\r
 224 \r
 225 \r
 226 \r
 227 (**************************************************************************)\r
 228 (*                                                                        *)\r
 229 (*                   ALGORITHME DE KNUTH, MORRIS et PRATT                 *)\r
 230 (*                                                                        *)\r
 231 (**************************************************************************)\r
 232 UNIT AlgoKMP : procedure(p , s : arrayof char) ;\r
 233 \r
 234 (* procedure permettant d'effectuer les affichages *)\r
 235 \r
 236    UNIT ecran : procedure (h:arrayof integer) ;\r
 237    var i : integer ;\r
 238    begin\r
 239       call couleur(blanc,noir);\r
 240       call setcursor(1,7);\r
 241       writeln("On compare le caractere en surbrillance du pattern avec celui de la chaine.");\r
 242       writeln("Quand on trouve un caractere non correspondant, on revient en arriere dans le");\r
 243       writeln("pattern d'un nombre n de positions.");\r
 244       writeln("n est donn\82 par la table suivante:");\r
 245       writeln("caractere num  :");\r
 246       writeln("hash code (=n) :");\r
 247       call couleur(jaune,noir);\r
 248       for i:=1 to upper(h)\r
 249       do\r
 250          call setcursor(13+i*4,11);\r
 251          write(i:4);\r
 252          call setcursor(13+i*4,12);\r
 253          write(h(i):4);\r
 254       od;\r
 255    end ecran ;\r
 256 \r
 257 (* procedure d'affichage du texte *)\r
 258 \r
 259    UNIT AfficheChaine : procedure (p,s:arrayof char; posp,poss : integer);\r
 260    Var t , longs , longp : integer ;\r
 261    Var car : char ;\r
 262       Begin\r
 263          longp:=upper(p);\r
 264          longs:=upper(s);\r
 265          call setcursor(11,1);\r
 266          for t:=1 to longp\r
 267          do\r
 268             if (t=posp) then\r
 269                call couleur(jaune,bleu);\r
 270             else\r
 271                call couleur(jaune,noir);\r
 272             fi;\r
 273             Write(p(t));\r
 274          od;\r
 275          call setcursor(1,4);\r
 276          for t:=1 to longs\r
 277          do\r
 278             if (t=poss) then\r
 279                call couleur(jaune,bleu);\r
 280             else\r
 281                call couleur(jaune,noir);\r
 282             fi;\r
 283             Write(s(t));\r
 284          od;\r
 285          car:=getchar;\r
 286    End AfficheChaine;\r
 287 \r
 288 (* Procedure de calcul de la hash function, stockee dans une table *)\r
 289 \r
 290   UNIT KMPhash : function(p : arrayof char) : arrayof integer;\r
 291   var i, j : integer,\r
 292       h : arrayof integer ,\r
 293       sortie: boolean ;\r
 294 \r
 295     Begin\r
 296     (* initialisations *)\r
 297        i := 1;\r
 298        j := 0;\r
 299        m := upper(p);\r
 300        array h dim (1:m);\r
 301        h(1) := 0;\r
 302 \r
 303     (* boucle principale *)\r
 304        while (i < m)\r
 305        do\r
 306           sortie:=false ;\r
 307           while (not sortie)\r
 308           do\r
 309             sortie:=true;\r
 310             if (j>0) then\r
 311                if (p(j) <> p(i)) then\r
 312                   sortie:=false ;\r
 313                   j:=h(j);\r
 314                fi ;\r
 315             fi ;\r
 316           od;\r
 317 \r
 318           i := i+1;\r
 319           j := j+1;\r
 320           if (p(i) = p(j)) then h(i) := h(j);\r
 321             else h(i) := j;\r
 322           fi;\r
 323        od;\r
 324        result:=h;\r
 325     End KMPhash;\r
 326 \r
 327 var i, j, m, n : integer,\r
 328     h : arrayof integer,\r
 329     sortie , resultat : boolean;\r
 330 \r
 331 (* Corps de l'algorithme KMP *******************)\r
 332 \r
 333 Begin\r
 334    call afficheecran(p,s);\r
 335 \r
 336    (* initialisations *)\r
 337    m := upper(p);\r
 338    n := upper(s);\r
 339    array h dim(1:m);\r
 340    h := KMPhash(p);\r
 341    call ecran(h);\r
 342    i := 1;\r
 343    j := 1;\r
 344 \r
 345    (* boucle principale *)\r
 346    while ((i <= m) and (j <= n))\r
 347    do\r
 348        sortie:=false;\r
 349        while (not sortie)\r
 350        do\r
 351          sortie:=true;\r
 352          if (i>0) then\r
 353             if (p(i) <> s(j)) then\r
 354                sortie:=false ;\r
 355                i:=h(i);\r
 356                call setcursor(1,14);\r
 357                call couleur(blanc,noir);\r
 358                write("On se deplace a la position : ",i);\r
 359             fi ;\r
 360          if (i>0) then\r
 361             call affichechaine(p,s,i,j);\r
 362          else\r
 363             call setcursor(1,14);\r
 364             call couleur(blanc,noir);\r
 365             call eraseline;\r
 366             call affichechaine(p,s,i+1,j);\r
 367          fi;\r
 368          fi;\r
 369        od;\r
 370       i := i+1;\r
 371       j := j+1;\r
 372     od;\r
 373     resultat := (i > m);\r
 374     call afficheresultat(resultat);\r
 375  End AlgoKMP;\r
 376 \r
 377 (**************************************************************************)\r
 378 (*                                                                        *)\r
 379 (*                      ALGORITHME DE KARP et RABIN                       *)\r
 380 (*                                                                        *)\r
 381 (**************************************************************************)\r
 382 UNIT AlgoKarpRabin : procedure (p , s : arrayof char);\r
 383 \r
 384 (* Affichage de l'ecran et des commentaires *)\r
 385 \r
 386    UNIT Ecran : Procedure (hash : integer);\r
 387      begin\r
 388         call couleur(blanc,noir);\r
 389         call setcursor(1,8);\r
 390         write("Hash code du pattern           :");\r
 391         call couleur(jaune,noir);\r
 392         writeln(hash);\r
 393         call couleur(blanc,noir);\r
 394         writeln("Hash code du texte selectionne :");\r
 395    end ecran ;\r
 396 \r
 397 (* procedure d'affichage du texte *)\r
 398 \r
 399    UNIT AfficheChaine : procedure (s:arrayof char ; poss ,longp,hash:integer);\r
 400    Var t , longs : integer ;\r
 401    Var car : char ;\r
 402       Begin\r
 403          longs:=upper(s);\r
 404          call couleur(jaune,noir);\r
 405          call setcursor(33,9);\r
 406          write(hash);\r
 407          call setcursor(1,4);\r
 408          for t:=1 to longs\r
 409          do\r
 410             if ( (t>=poss) and (t<poss+longp) ) then\r
 411                call couleur(jaune,bleu);\r
 412             else\r
 413                call couleur(jaune,noir);\r
 414             fi;\r
 415             Write(s(t));\r
 416          od;\r
 417          car:=getchar;\r
 418    End AfficheChaine;\r
 419 \r
 420 (* Procedure de calcul de la premiere valeur de la hash function *)\r
 421 \r
 422     UNIT hashfunction : function( str : arrayof char, m : integer ):integer;\r
 423       var a : integer;\r
 424       Begin\r
 425          result := 0;\r
 426          for a := 1 to m do\r
 427                 result := result + ord(str(a)) ;\r
 428          od;\r
 429       End hashfunction;\r
 430 \r
 431 (* Procedure de calcul des valeurs suivantes de la hash function *)\r
 432 \r
 433       UNIT newhash : function( oldh , m ,j:integer, str : arrayof char ): integer;\r
 434          Begin\r
 435             result:=oldh + ord(str(j+m)) - ord(str(j)) ;\r
 436          End newhash;\r
 437 \r
 438 var j, m, n, a , d : integer,\r
 439     hpat, hstr : integer ,\r
 440     trouve : boolean;\r
 441 \r
 442 (* Corps de l'algorithme KR ************************)\r
 443 \r
 444    Begin\r
 445 \r
 446     (* initialisations *)\r
 447       call afficheecran(p,s);\r
 448       j := 1;\r
 449       trouve := false;\r
 450       m := upper(p);\r
 451       n := upper(s);\r
 452       hpat := hashfunction(p,m);\r
 453       hstr := hashfunction(s,m);\r
 454       call ecran(hpat);\r
 455       j:=1;\r
 456 \r
 457       (* boucle principale *)\r
 458       do\r
 459          if ( hpat = hstr ) then\r
 460               call couleur(blanc,noir);\r
 461               call setcursor(1,12);\r
 462               write("Les deux hashcodes correspondent, on compare le pattern et la selection");\r
 463               a := 1;\r
 464               trouve :=  true;\r
 465               while ((trouve) and (a <= m))\r
 466               do\r
 467                  if ( p(a) = s(j+a-1) ) then\r
 468                     a := a+1\r
 469                  else\r
 470                     trouve := false;\r
 471                  fi\r
 472               od;\r
 473            else\r
 474               call couleur(blanc,noir);\r
 475               call setcursor(1,12);\r
 476               call eraseline;\r
 477            fi;\r
 478            call affichechaine(s,j,m,hstr);\r
 479            if ( (j>= (n-m+1)) or ( trouve) ) then exit fi;\r
 480            hstr := newhash(hstr , m , j , s);\r
 481            j:=j+1;\r
 482 \r
 483       od;\r
 484       call afficheresultat(trouve);\r
 485    End AlgoKarpRabin;\r
 486 \r
 487 (**************************************************************************)\r
 488 (*                                                                        *)\r
 489 (*         ALGORITHME DE BOYER et MOORE (modifi\82 HORSPOOL)                *)\r
 490 (*                                                                        *)\r
 491 (**************************************************************************)\r
 492 UNIT AlgoBoyerMoore : procedure ( p , s : arrayof char);\r
 493 \r
 494 (* procedure d'affichage du texte *)\r
 495 \r
 496    UNIT AfficheChaine : procedure (s:arrayof char; poss : integer);\r
 497    Var t , longs : integer ;\r
 498    Var car : char ;\r
 499       Begin\r
 500          longs:=upper(s);\r
 501          call setcursor(1,4);\r
 502          for t:=1 to longs\r
 503          do\r
 504             if (t=poss) then\r
 505                call couleur(jaune,bleu);\r
 506             else\r
 507                call couleur(jaune,noir);\r
 508             fi;\r
 509             Write(s(t));\r
 510          od;\r
 511          car:=getchar;\r
 512    End AfficheChaine;\r
 513 \r
 514 (* Procedure de remplissage de la table Delta *)\r
 515 \r
 516 UNIT Delta : function (p : arrayof char) : arrayof integer ;\r
 517 \r
 518 Var d : arrayof integer,\r
 519     a : integer;\r
 520 \r
 521 Begin\r
 522    array d dim(1:127);\r
 523    m:=upper(p);\r
 524    (* initialisation *)\r
 525    for a:=1 to 127 do\r
 526      d(a):=m;\r
 527    od;\r
 528    (* calcul pour le pattern *)\r
 529    for a:=1 to m-1 do\r
 530      d(ord(p(a))):=m-a;\r
 531    od;\r
 532    result:=d;\r
 533 End Delta;\r
 534 \r
 535 var j, m, n, a : integer,\r
 536     trouve : boolean,\r
 537     d : arrayof integer;\r
 538 \r
 539 \r
 540 (* Corps de l'algorithme BM ************************)\r
 541 \r
 542 Begin\r
 543   (* initialisations *)\r
 544    call afficheecran(p,s);\r
 545    m:=upper(p);\r
 546    n:=upper(s);\r
 547    d:=Delta(p);\r
 548    j:=m;\r
 549    trouve:=false;\r
 550 \r
 551    (* boucle principale *)\r
 552    while ( (j<=n) and (not trouve) )\r
 553    do\r
 554       call affichechaine(s,j);\r
 555       if (s(j) = p(m)) then\r
 556          trouve:=true;\r
 557          for a:=1 to m\r
 558          do\r
 559             if (p(a)<>s(j-m+a)) then\r
 560                trouve:=false;\r
 561             fi;\r
 562          od;\r
 563       fi;\r
 564          call couleur(blanc,noir);\r
 565          call setcursor(1,8);\r
 566       if (not trouve) then\r
 567          writeln("La derniere lettre du pattern ne correspond pas avec la lettre de la chaine");\r
 568          writeln("en surbrillance, alors on se deplace de ",d(ord(s(j))):2," positions");\r
 569       else\r
 570          call eraseline;\r
 571          writeln;\r
 572          call eraseline;\r
 573       fi;\r
 574       j:=j+d(ord(s(j)));\r
 575    od;\r
 576    call afficheresultat(trouve);\r
 577 \r
 578 End AlgoBoyerMoore ;\r
 579 \r
 580 \r
 581 (* Procedure affichant le premier ecran et saisissant les choix *)\r
 582 \r
 583 UNIT EcranPrincipal : procedure ;\r
 584 var choix : integer ,\r
 585     p , s : arrayof char ;\r
 586    Begin\r
 587    choix:=0;\r
 588    while (choix<>5)\r
 589    do\r
 590       call couleur(blanc,noir);\r
 591       call cls;\r
 592       call setcursor(27,1);\r
 593       Write("Programme Pattern Matcher");\r
 594       call setcursor(27,2);\r
 595       Write("-------------------------");\r
 596       call setcursor(1,22);\r
 597       writeln("Tous les algorithmes s'executent en pas a pas, il faut appuyer sur une touche");\r
 598       write("pour faire s'executer le pas suivant...");\r
 599 \r
 600       call setcursor(1,6);\r
 601       writeln("   1) Algorithme simple");\r
 602       writeln("   2) Algorithme de Karp et Rabin");\r
 603       writeln("   3) Algorithme de Knuth, Morris et Pratt");\r
 604       writeln("   4) Algorithme de Boyer et Moore");\r
 605       writeln("   5) Quitter le programme");\r
 606       writeln;\r
 607       write("Votre choix : ");\r
 608       readln(choix);\r
 609       if (choix < 5) then\r
 610          writeln;\r
 611          writeln("Saisie de la chaine ou on recherche le pattern :");\r
 612          call couleur(jaune,noir);\r
 613          s:=saisiestring;\r
 614          call couleur(blanc,noir);\r
 615          writeln("Saisie du pattern a rechercher :");\r
 616          call couleur(jaune,noir);\r
 617          p:=saisiestring;\r
 618          call couleur(blanc,noir);\r
 619          case choix\r
 620          when 1 : call algoSimple(p,s);\r
 621          when 2 : call algoKarpRabin(p,s);\r
 622          when 3 : call algoKMP(p,s);\r
 623          when 4 : call algoBoyerMoore(p,s);\r
 624          esac ;\r
 625       fi;\r
 626    od;\r
 627    End EcranPrincipal;\r
 628 \r
 629 \r
 630 (***************************************************************************)\r
 631 (*                        PROGRAMME PRINCIPAL                              *)\r
 632 (***************************************************************************)\r
 633 \r
 634 \r
 635 Begin\r
 636    call ecranprincipal;\r
 637 End;\1a