examples/examples.old/proj_li1.log

   1 PROGRAM BD;\r
   2         (*******************************************************************)\r
   3         (*      OUTILS CONCERNANT L'AFFICHAGE DU TEXTE A L'ECRAN           *)\r
   4         (*******************************************************************)\r
   5       UNIT gest_ecran:CLASS;\r
   6 \r
   7          (*  Efface l'ecran et positionne le curseur en haut a gauche       *)\r
   8         UNIT cls : PROCEDURE;\r
   9         BEGIN\r
  10                 WRITE( chr(27), "[2J");\r
  11         END CLS;\r
  12 \r
  13 \r
  14          (*  Affiche du texte en video inverse                          *)\r
  15         UNIT Reverse : PROCEDURE;\r
  16         BEGIN\r
  17                 WRITE( chr(27), "[7m");\r
  18         END Reverse;\r
  19 \r
  20 \r
  21         (*  Affiche le texte de maniere normale                            *)\r
  22         UNIT Normal : PROCEDURE;\r
  23         BEGIN\r
  24                 WRITE( chr(27), "[0m")\r
  25         END Normal;\r
  26 \r
  27 \r
  28         UNIT Setcursor : PROCEDURE (row,column : INTEGER);\r
  29         VAR c,d,e,f : CHAR,\r
  30         i,j : INTEGER;\r
  31         BEGIN\r
  32                 i:=row div 10;\r
  33                 j:=row mod 10;\r
  34                 c:=chr(48+i);\r
  35                 d:=chr(48+j);\r
  36                 i:=column div 10;\r
  37                 j:=column mod 10;\r
  38                 e:=chr(48+i);\r
  39                 f:=chr(48+j);\r
  40 \r
  41                 Write(chr(27), "[",c,d, ";",e,f, "H");\r
  42         END Setcursor;\r
  43 \r
  44    (*  unite qui sert a tracer un cadre *)\r
  45 \r
  46        UNIT cadre: PROCEDURE (x1,y1,x2,y2 : integer);\r
  47        var i , j : integer;\r
  48        BEGIN\r
  49            for i := x1 to x2 do\r
  50                CALL setcursor(i,y1);\r
  51                write("*");\r
  52            od;\r
  53            for i := x1 to x2 do\r
  54               CALL setcursor(i,y2);\r
  55               write ("*");\r
  56            od;\r
  57            for i := y1 to y2 do\r
  58               CALL setcursor(x1,i);\r
  59               write ("*");\r
  60            od;\r
  61           for i := y1 to y2 do\r
  62               CALL setcursor(x2,i);\r
  63               write ("*");\r
  64           od;\r
  65        END cadre;\r
  66 \r
  67      END gest_ecran;\r
  68 \r
  69   (**************************** CADRE_T **********************************************)\r
  70   UNIT cadre_t:gest_ecran PROCEDURE;\r
  71   BEGIN\r
  72         CALL cls;\r
  73         CALL cadre (1,1,22,80);\r
  74         CALL cadre (1,1,3,80);\r
  75         CALL setcursor (2,32);\r
  76         CALL reverse;\r
  77         write (" GESTION DE BIBLIOTHEQUE ");\r
  78         CALL normal;\r
  79   END cadre_t;\r
  80 \r
  81 \r
  82   (*************************** PRESENTS_1*********************************************)\r
  83   UNIT presents_1:gest_ecran PROCEDURE;\r
  84   BEGIN\r
  85         CALL cadre_t;\r
  86         CALL setcursor (10,32);\r
  87         CALL reverse;\r
  88         write (" PROJET REALISE PAR : ");\r
  89         CALL setcursor (12,32);\r
  90         Write (" BOURGEAT - MANDONNAUD ");\r
  91         CALL setcursor(14,32);\r
  92         Write (" LICENCE INFORMATIQUE ");\r
  93         CALL normal;\r
  94   END presents_1;\r
  95   \r
  96   (****************************** chaine *****************)\r
  97 \r
  98   UNIT chaine:CLASS;\r
  99   VAR long:integer;\r
 100   VAR ch : arrayof char;\r
 101 \r
 102     UNIT lit : PROCEDURE;\r
 103     VAR i:integer,\r
 104          car:char;\r
 105     BEGIN\r
 106       i:=1;\r
 107       read(car);\r
 108       WHILE i<=long AND car=/=chr(10)\r
 109       DO\r
 110         ch(i):=car;\r
 111         read(car);\r
 112         i:=i+1;\r
 113       OD;\r
 114     END lit;\r
 115 \r
 116     UNIT afi:PROCEDURE;\r
 117     VAR i:integer;\r
 118     BEGIN\r
 119       i:=1;\r
 120       FOR i:=1 TO long\r
 121       DO\r
 122         write(ch(i));\r
 123       OD;\r
 124       writeln;\r
 125     END afi;\r
 126 \r
 127     UNIT inff:FUNCTION(c2:chaine):boolean;\r
 128     VAR i:integer;\r
 129     BEGIN\r
 130       i:=1;\r
 131       IF long<=c2.long\r
 132       THEN\r
 133         WHILE ch(i)=c2.ch(i)\r
 134         DO\r
 135           i:=i+1;\r
 136           IF i=long THEN exit; FI;\r
 137         OD;\r
 138         result:=ord(ch(i))<ord(c2.ch(i));\r
 139       ELSE\r
 140         WHILE ch(i)=c2.ch(i)\r
 141         DO \r
 142           i:=i+1;\r
 143           IF i=c2.long THEN exit FI;\r
 144         OD;\r
 145         IF ord(ch(i))<ord(c2.ch(i)) \r
 146         THEN result:=i<c2.long \r
 147         ELSE result:=false \r
 148         FI;\r
 149       FI;\r
 150     END inff;\r
 151 \r
 152     UNIT eqq:FUNCTION(c2:chaine):boolean;\r
 153     VAR  i:integer;\r
 154     BEGIN\r
 155       i := 1;\r
 156       IF long=c2.long\r
 157       THEN\r
 158         WHILE ord(ch(i)) = ord(c2.ch(i))\r
 159         DO\r
 160           i := i + 1;\r
 161           IF i=long THEN exit FI;\r
 162         OD;\r
 163         result:=ch(i)=c2.ch(i);\r
 164       ELSE\r
 165         result:=FALSE;\r
 166       FI;\r
 167     END eqq;\r
 168 \r
 169     UNIT copyy : PROCEDURE(xx : chaine);\r
 170     VAR i:integer;\r
 171     BEGIN\r
 172       i:=1;\r
 173       WHILE i<long\r
 174       DO\r
 175         ch(i):= xx.ch(i);\r
 176         i:=i+1;\r
 177       OD;\r
 178     END copyy;\r
 179 \r
 180   BEGIN\r
 181     long:=30;\r
 182     ARRAY ch DIM (1:long);\r
 183   END chaine;\r
 184 \r
 185 \r
 186 \r
 187 \r
 188 \r
 189 \r
 190 (********************************** ELEMENT *****************************************)\r
 191   UNIT element:CLASS;\r
 192   VAR e:chaine;\r
 193 \r
 194     UNIT sup:FUNCTION(e2:element):boolean;\r
 195     BEGIN\r
 196       result:=NOT (e.inff(e2.e)) AND NOT (e.eqq(e2.e));\r
 197     END sup;\r
 198 \r
 199     UNIT inf:FUNCTION(e2:element):boolean;\r
 200     BEGIN\r
 201       result:=e.inff(e2.e);\r
 202     END inf;\r
 203 \r
 204     UNIT eq:FUNCTION(e2:element):boolean;\r
 205     BEGIN\r
 206       result:=e.eqq(e2.e);\r
 207     END eq;\r
 208 \r
 209     UNIT lire : PROCEDURE;\r
 210     BEGIN\r
 211       CALL e.lit;\r
 212     END lire;\r
 213 \r
 214     UNIT VIRTUAL affich : PROCEDURE;\r
 215     END affich;\r
 216 \r
 217   BEGIN\r
 218     e:=new chaine;\r
 219   END element;\r
 220 \r
 221  (************************ article ***************************)\r
 222 \r
 223   UNIT article:element CLASS;\r
 224   VAR i:integer,\r
 225       c:arrayof chaine;\r
 226 \r
 227     UNIT VIRTUAL affich:PROCEDURE;\r
 228     BEGIN\r
 229       CALL  e.afi;\r
 230     END affich;\r
 231 \r
 232   BEGIN\r
 233     ARRAY c DIM (1:2);\r
 234     for i := 1 to 2\r
 235     do\r
 236       c(i) := new chaine;\r
 237     od;\r
 238   END article;\r
 239 \r
 240  (******************* LISTE ***********************)\r
 241 \r
 242   UNIT liste : CLASS;\r
 243   VAR debut: noeud;\r
 244 \r
 245     UNIT noeud : CLASS;\r
 246     VAR clen   : chaine,\r
 247         suivant: noeud;\r
 248     BEGIN\r
 249       clen := new chaine;\r
 250     END noeud;\r
 251 \r
 252     UNIT insert : PROCEDURE(cle : chaine);\r
 253     VAR nd,ndaux : noeud;\r
 254     BEGIN\r
 255       nd:=new noeud;\r
 256       call nd.clen.copyy(cle);\r
 257       IF debut=none\r
 258       THEN\r
 259         debut:=nd;\r
 260       ELSE\r
 261         ndaux:=debut;\r
 262         debut:=nd;\r
 263         debut.suivant:=ndaux;\r
 264       FI;\r
 265     END insert;\r
 266 \r
 267     UNIT suppr : PROCEDURE(cle : chaine);\r
 268     VAR nd,ndaux:noeud;\r
 269     BEGIN\r
 270       IF debut.clen.eqq(cle)\r
 271       THEN\r
 272         debut:=debut.suivant;\r
 273       ELSE\r
 274         ndaux:=debut;\r
 275         nd:=ndaux.suivant;\r
 276         WHILE NOT(nd.clen.eqq(cle))\r
 277         DO\r
 278           ndaux:=nd;\r
 279           nd:=nd.suivant;\r
 280           IF nd=none THEN EXIT FI;\r
 281         OD;\r
 282         IF nd<>none THEN ndaux:=nd.suivant FI;\r
 283       FI;  \r
 284      END suppr;\r
 285 \r
 286     UNIT affi:PROCEDURE;\r
 287     VAR i:integer,\r
 288         nd:noeud;\r
 289     BEGIN\r
 290       nd:=debut;\r
 291       i:=1;\r
 292       WHILE nd =/= none\r
 293       DO\r
 294         write("reference :");write(i); write(" ");\r
 295         CALL nd.clen.afi;\r
 296         i := i + 1;\r
 297         nd:=nd.suivant;\r
 298       OD;\r
 299     END affi;\r
 300   END liste;\r
 301 \r
 302  (********************************** index_elem **********************************)\r
 303   UNIT index_elem : element CLASS;\r
 304   VAR lis : liste;\r
 305     UNIT sup:FUNCTION(e2:element):boolean;\r
 306     BEGIN\r
 307       result:=NOT (e.inff(e2.e)) AND NOT (e.eqq(e2.e));\r
 308     END sup;\r
 309 \r
 310     UNIT inf:FUNCTION(e2:element):boolean;\r
 311     BEGIN\r
 312       result:=e.inff(e2.e);\r
 313     END inf;\r
 314 \r
 315     UNIT eq:FUNCTION(e2:element):boolean;\r
 316     BEGIN\r
 317       result:=e.eqq(e2.e);\r
 318     END eq;\r
 319 \r
 320     UNIT VIRTUAL affich : PROCEDURE ;\r
 321     BEGIN\r
 322       CALL e.afi;\r
 323     END affich;\r
 324 \r
 325   BEGIN\r
 326       lis := new liste;\r
 327   END index_elem;\r
 328 \r
 329   (*********************** item ***************************************)\r
 330 \r
 331   UNIT item : CLASS;\r
 332   VAR key:element,\r
 333       ptr:page;\r
 334   BEGIN\r
 335     key:=new element;\r
 336   END item;\r
 337 \r
 338 \r
 339 (************************************** PAGE *****************************************)\r
 340 \r
 341   UNIT page : CLASS(n:integer);\r
 342   VAR m :  integer,\r
 343       p0:  page,\r
 344       e :  arrayof item;\r
 345 \r
 346   BEGIN   (* creation de la page *)\r
 347     array e dim(1:n*2);\r
 348     for m:=1 to n*2 do e(m):=new item; od;\r
 349   END page;\r
 350 \r
 351 \r
 352 \r
 353 (************************************** B_ARB ******************************************)\r
 354 UNIT Barb :gest_ecran CLASS(n : integer);\r
 355 \r
 356 VAR ROOT:page;\r
 357 \r
 358         UNIT Search : PROCEDURE(input x:element,a:page; inout h:boolean,v:item);\r
 359                 VAR k,l,r:integer,\r
 360                          q:page,\r
 361                          u:item;\r
 362 \r
 363                 UNIT insert : PROCEDURE;\r
 364                 VAR i:integer, b:page;\r
 365                 BEGIN\r
 366                         IF a.m<(n*2) THEN\r
 367                           a.m:=a.m+1; h:=FALSE;\r
 368                           for i:=a.m downto (r+2)\r
 369                           do\r
 370                                   a.e(i):=a.e(i-1);\r
 371                           od;\r
 372                           a.e(r+1):=u;\r
 373                         ELSE\r
 374                           b:=new page(n);\r
 375                           IF r<=n THEN\r
 376                                   IF r=n THEN v:=u;\r
 377                                   ELSE\r
 378                                           v:=a.e(n);\r
 379                                           for i:=n downto (r+2)\r
 380                                           do\r
 381                                                   a.e(i):=a.e(i-1);\r
 382                                           od;\r
 383                                           a.e(r+1):=u;\r
 384                                   FI;\r
 385                                   for i:=1 to n\r
 386                                   do\r
 387                                           b.e(i):=a.e(i+n);\r
 388                                   od;\r
 389                           ELSE\r
 390                                   r:=r-n;\r
 391                                   v:=a.e(n+1);\r
 392                                   for i:=1 to (r-1)\r
 393                                   do\r
 394                                           b.e(i):=a.e(i+n+1);\r
 395                                   od;\r
 396                                   b.e(r):=u;\r
 397                                   for i:=r+1 to n\r
 398                                   do\r
 399                                           b.e(i):=a.e(i+n);\r
 400                                   od;\r
 401                           FI;\r
 402                           a.m:=n;\r
 403                           b.m:=n;\r
 404                           b.p0:=v.ptr;\r
 405                           v.ptr:=b;\r
 406                         FI;\r
 407                 END insert;\r
 408 \r
 409         BEGIN (* Search *)\r
 410                 u:=new item;\r
 411          IF a=none THEN\r
 412                 h:=TRUE;\r
 413                 v.key:=x;\r
 414                 v.ptr:=none;\r
 415          ELSE\r
 416                 l:=1; r:=a.m;\r
 417                 DO\r
 418                         k:=(l+r) div 2;\r
 419                         (* writeln(" "); *)\r
 420                         IF NOT x.sup(a.e(k).key) THEN r:=k-1; FI;\r
 421                         IF NOT x.inf(a.e(k).key) THEN l:=k+1; FI;\r
 422                         IF r<l THEN exit; FI;\r
 423                 OD;\r
 424                 IF l-r>1 THEN h:=FALSE;\r
 425                           CALL setcursor(33,20);\r
 426                           WRITE ("Element deja dans l'arbre!");\r
 427                 ELSE\r
 428                         IF r=0 THEN q:=a.p0 ELSE q:=a.e(r).ptr; FI;\r
 429                         CALL Search(x,q,h,u);\r
 430                         IF h THEN CALL insert; FI;\r
 431                 FI;\r
 432          FI;\r
 433         END Search;\r
 434 \r
 435 \r
 436         UNIT Inserer : PROCEDURE (newe : element);\r
 437         VAR h:boolean,\r
 438                         pgaux:page,\r
 439                         u:item;\r
 440         BEGIN\r
 441           u:=new item;\r
 442           CALL Search(newe,ROOT,h,u);\r
 443           IF h THEN\r
 444                   pgaux:=ROOT;\r
 445                   ROOT:=new page(n);\r
 446                   ROOT.m:=1; ROOT.p0:=pgaux; ROOT.e(1):=u;\r
 447           FI;\r
 448         END Inserer;\r
 449 \r
 450 \r
 451 \r
 452 \r
 453 \r
 454         UNIT delete :PROCEDURE(INPUT x:element, a:page; INOUT h:boolean);\r
 455          VAR i,k,l,r : INTEGER,\r
 456                   q:page;\r
 457 \r
 458          UNIT underflow : PROCEDURE(INPUT c,a: page, s:integer;  INOUT h:boolean);\r
 459          VAR  b: page,\r
 460                         i,k,mb,mc: integer;\r
 461          BEGIN\r
 462                  mc:=c.m;\r
 463                  IF s<mc THEN   (* b <-- page qui se trouve a droite de a *)\r
 464                          s:=s+1;\r
 465                          b:=c.e(s).ptr;\r
 466                          mb:=b.m; k:=(mb-n+1) DIV 2;\r
 467                                 (* k= Nombre d'elements disponibles sur la page b *)\r
 468                          a.e(n):=c.e(s);\r
 469                          a.e(n).ptr:=b.p0;\r
 470 \r
 471                          IF k>0 THEN  (* Deplacer k elements de b vers a *)\r
 472                                  FOR i:=1 TO k-1 DO a.e(i+n):=b.e(i) OD; i:=i-1;\r
 473                                  c.e(s):=b.e(k);\r
 474                                  b.p0:=b.e(k).ptr;\r
 475                                  c.e(s).ptr:=b;\r
 476                                  mb:=mb-k;\r
 477                                  FOR i:=1 TO mb DO b.e(i):=b.e(i+k) OD;  i:=i-1;\r
 478                                  b.m:=mb;\r
 479                                  a.m:=n-1+k;\r
 480                                  h:=FALSE;\r
 481                          ELSE   (* Il faut fusionner a et b *)\r
 482                                  FOR i:=1 TO n DO a.e(i+n):=b.e(i) OD;  i:=i-1;\r
 483                                  FOR i:=s TO mc-1 DO c.e(i):=c.e(i+1) OD;   i:=i-1;\r
 484                                  a.m:=2*n; c.m:=mc-1;\r
 485                                  h:=c.m<n; (*kill(b);*)\r
 486                          FI;\r
 487                  ELSE           (* b <-- page qui se trouve a gauche de a *)\r
 488                          IF s=1 THEN b:=c.p0 ELSE b:=c.e(s-1).ptr FI;\r
 489                          mb:=b.m+1;\r
 490                          k:=(mb-n) DIV 2;\r
 491                          IF k>0 THEN   (* Deplacer k elements de b vers a *)\r
 492                                  FOR i:=n-1 DOWNTO 1 DO a.e(i+k):=a.e(i) OD; i:=i+1;\r
 493                                  a.e(k):=c.e(s);\r
 494                                  a.e(k).ptr:=a.p0;\r
 495                                  mb:=mb-k;\r
 496                                  FOR i:=k-1 DOWNTO 1 DO a.e(i):=b.e(i+mb) OD; i:=i+1;\r
 497                                  a.p0:=b.e(mb).ptr;\r
 498                                  c.e(s):=b.e(mb);\r
 499                                  c.e(s).ptr:=a;\r
 500                                  b.m:=mb-1; a.m:=n-1+k; h:=FALSE;\r
 501                          ELSE   (* Il faut fusionner a et b *)\r
 502                                  b.e(mb):=c.e(s);\r
 503                                  b.e(mb).ptr:=a.p0;\r
 504                                  FOR i:=1 TO n-1 DO b.e(i+mb):=a.e(i) OD; i:=i-1;\r
 505                                  b.m:=2*n; c.m:=mc-1; h:=(c.m<n);\r
 506                          FI;\r
 507                  FI;\r
 508          END underflow;\r
 509 \r
 510          UNIT del : PROCEDURE(p:page; INOUT h:boolean);\r
 511                  VAR q:page;\r
 512          BEGIN\r
 513                  q:=p.e(p.m).ptr;\r
 514                  IF q<>none THEN\r
 515                          CALL del(q,h);\r
 516 \r
 517                          IF h THEN CALL underflow(p,q,p.m,h);FI;\r
 518                  ELSE\r
 519                          p.e(p.m).ptr:=a.e(k).ptr;\r
 520                          a.e(k):=p.e(p.m);\r
 521                          p.m:=p.m-1;\r
 522                          h:=(p.m<n);\r
 523                  FI;\r
 524          END del;\r
 525 \r
 526  BEGIN\r
 527          IF a=none THEN\r
 528                  WRITELN("L'element n'est pas dans l'arbre");\r
 529                  h:=FALSE;\r
 530          ELSE\r
 531                  l:=1; r:=a.m;\r
 532                  DO   (* recherche binaire dans la page a *)\r
 533                          k:=(l+r) div 2;\r
 534                          IF NOT x.sup(a.e(k).key) THEN r:=k-1; FI;\r
 535                          IF NOT x.inf(a.e(k).key) THEN l:=k+1; FI;\r
 536                          IF (l>r) THEN exit; FI;\r
 537                  OD;\r
 538                  IF r=0 THEN q:=a.p0 ELSE q:=a.e(r).ptr FI;\r
 539                  IF l-r >1 THEN\r
 540                          IF q=none THEN  (* a est une feuille *)\r
 541                                  a.m:=a.m-1;\r
 542                                  h:=(a.m<n);\r
 543                                  FOR i:=k TO a.m DO a.e(i):=a.e(i+1); OD; i:=i-1;\r
 544                          ELSE\r
 545                                  CALL del (q,h);\r
 546                                  IF h THEN CALL underflow(a,q,r,h); FI;\r
 547                          FI;\r
 548                  ELSE\r
 549                          CALL delete(x,q,h);\r
 550                          IF h THEN CALL underflow(a,q,r,h); FI;\r
 551                  FI;\r
 552          FI;\r
 553  END delete;\r
 554 \r
 555 \r
 556  UNIT supprimer : PROCEDURE(newe:element);\r
 557  VAR h:boolean,\r
 558           pgaux:page;\r
 559  BEGIN\r
 560          CALL delete(newe,ROOT,h);\r
 561          IF h THEN\r
 562                  IF root.m=0 THEN\r
 563                          pgaux:=root; root:=pgaux.p0; (* kill(pgaux); *)\r
 564                  FI;\r
 565          FI;\r
 566  END supprimer;\r
 567 \r
 568 (*************************************** MEMBER ****************************************************)\r
 569 \r
 570  UNIT Member : FUNCTION(inout ele:element):boolean;\r
 571         VAR existe:boolean,\r
 572                  k:integer,\r
 573                  paux:page;\r
 574 \r
 575         UNIT Rech_page:FUNCTION(p:page) : integer;\r
 576                 VAR i:integer;\r
 577         BEGIN\r
 578                 FOR i:=1 TO p.m\r
 579                 DO\r
 580                         IF ele.eq(p.e(i).key) THEN exit; FI;\r
 581                         IF ele.inf(p.e(i).key) THEN\r
 582                                 i:=i-1;\r
 583                                 exit;\r
 584                         FI;\r
 585                 OD;\r
 586                 if i>p.m then i:=i-1; fi;\r
 587                 result:=i;\r
 588         END Rech_page;\r
 589 \r
 590  BEGIN\r
 591         existe:=FALSE;\r
 592         paux:=root;\r
 593         DO\r
 594                 IF (paux=none OR existe) THEN exit; FI;\r
 595                 k:= Rech_page(paux);\r
 596                 IF k=0 THEN paux:=paux.p0;\r
 597                 ELSE\r
 598                         IF paux.e(k).key.eq(ele) THEN\r
 599                                 existe:=TRUE;\r
 600                                 ele:= paux.e(k).key;\r
 601                         ELSE\r
 602                                 paux:=paux.e(k).ptr;\r
 603                         FI;\r
 604                 FI;\r
 605         OD;\r
 606         result:=existe;\r
 607  END Member;\r
 608 \r
 609 \r
 610 (********************************************* MIN ****************************************************)\r
 611 \r
 612  UNIT Min : FUNCTION(p:page): element;\r
 613  BEGIN\r
 614         IF p<>none THEN\r
 615          DO\r
 616                 IF p.p0=none THEN\r
 617                         result:=p.e(1).key; exit;\r
 618                 ELSE\r
 619                         p:=p.p0;\r
 620                 FI;\r
 621          OD;\r
 622    FI;\r
 623  END Min;\r
 624 \r
 625 (********************************************* MAX ****************************************************)\r
 626  UNIT Max : FUNCTION(p:page): element;\r
 627  BEGIN\r
 628         IF p<>none THEN\r
 629          DO\r
 630                 IF p.e(p.m).ptr=none THEN\r
 631                         result:=p.e(p.m).key; exit;\r
 632                 ELSE\r
 633                         p:=p.e(p.m).ptr;\r
 634                 FI;\r
 635          OD;\r
 636         FI;\r
 637  END Max;\r
 638 \r
 639 (********************************************* LIST ****************************************************)\r
 640  UNIT List : PROCEDURE(p:page;inout ligne,colonne : integer);\r
 641  var\r
 642       i   :  integer;\r
 643 \r
 644  BEGIN\r
 645 \r
 646  IF ligne = 24  THEN\r
 647     ligne := 8;\r
 648     colonne := colonne + 10;\r
 649  FI;\r
 650 \r
 651  IF P<>none THEN\r
 652          IF (p.p0=none) THEN\r
 653                 IF (p.m>0) THEN\r
 654                   CALL setcursor(ligne,colonne);\r
 655                   CALL p.e(1).key.Affich;\r
 656                   ligne := ligne + 1;\r
 657                 fi;\r
 658          ELSE\r
 659                 ligne := ligne + 1;\r
 660                 CALL list(p.p0,ligne,colonne);\r
 661                 CALL setcursor(ligne,colonne);\r
 662                 CALL p.e(1).key.Affich;\r
 663 \r
 664          FI;\r
 665                 FOR i:=1 TO p.m\r
 666                 DO\r
 667                   IF p.e(i).ptr=none THEN\r
 668                          IF i<p.m THEN\r
 669                           CALL setcursor(ligne,colonne);\r
 670                           CALL p.e(i+1).key.Affich;\r
 671                           ligne := ligne +1;\r
 672                          FI;\r
 673                   ELSE\r
 674                           ligne := ligne + 1;\r
 675                           CALL List(p.e(i).ptr,ligne,colonne);\r
 676                           IF i<p.m THEN\r
 677                                 CALL setcursor(ligne,colonne);\r
 678                                 CALL p.e(i+1).key.Affich;\r
 679                                 (* ligne := ligne + 1; *)\r
 680                           FI;\r
 681                   FI;\r
 682                 OD;\r
 683   FI;\r
 684  END List;\r
 685 \r
 686 (****************************************** ERASE ******************************************************)\r
 687 \r
 688 UNIT Erase : PROCEDURE(p:page);\r
 689          var i:integer;\r
 690  BEGIN\r
 691  IF P<>none THEN\r
 692          IF (p.p0=none) THEN\r
 693                 IF (p.m>0) THEN Kill(p.e(1).key); fi;\r
 694          ELSE\r
 695                 CALL Erase(p.p0);\r
 696                 Kill(p.p0);\r
 697                 Kill(p.e(1).key);\r
 698          FI;\r
 699                 FOR i:=1 TO p.m\r
 700                 DO\r
 701                   IF p.e(i).ptr=none THEN\r
 702                          IF i<p.m THEN\r
 703                           Kill(p.e(i+1).key);\r
 704                          FI;\r
 705                   ELSE\r
 706                           CALL Erase(p.e(i).ptr);\r
 707                           Kill(p.e(i).ptr);\r
 708                           IF i<p.m THEN\r
 709                                 Kill(p.e(i+1).key);\r
 710                           FI;\r
 711                   FI;\r
 712                   Kill(p.e(i));\r
 713                 OD;\r
 714   FI;\r
 715  END Erase;\r
 716 \r
 717 \r
 718 BEGIN (* DEBUT BARB *)\r
 719          ROOT:=none;\r
 720 END Barb;\r
 721 \r
 722 \r
 723 (**************************************************)\r
 724 (**************************************************)\r
 725 (**************************************************)\r
 726 \r
 727 \r
 728 \r
 729 \r
 730     UNIT finn :gest_ecran PROCEDURE;\r
 731     BEGIN\r
 732          CALL setcursor(18,50);\r
 733          write("menu pr\82c\82dent taper RC : ");\r
 734          readln;\r
 735     END finn;\r
 736 \r
 737     UNIT menu :gest_ecran PROCEDURE;\r
 738 \r
 739     var\r
 740        ii : integer;\r
 741     BEGIN\r
 742       CALL presents_1;\r
 743       CALL finn;\r
 744       do\r
 745          CALL cls;\r
 746          CALL cadre(1,1,24,80);\r
 747          CALL setcursor(1,30);\r
 748          CALL reverse;\r
 749          write("menu principal");\r
 750          CALL setcursor(10,30);\r
 751          write("1   :  Inserer un livre");\r
 752          CALL SETCURSOR(12,30);\r
 753          WRITE("2   :  supprimer un livre");\r
 754          CALL SETCURSOR(14,30);\r
 755          WRITE("3   :  recherche");\r
 756          CALL SETCURSOR(16,30);\r
 757          WRITE("4   :  liste");\r
 758 \r
 759          CALL SETCURSOR(18,30);\r
 760          WRITE("10  :  fin");\r
 761 \r
 762          CALL normal;\r
 763          CALL setcursor(18,50);\r
 764          readln(ii);\r
 765          case ii\r
 766               when 1 : CALL insertlivre;\r
 767               when 2 : CALL supprilivre;\r
 768               when 3 : CALL recherche;\r
 769               when 4 : CALL llist;\r
 770               when 10 : exit;\r
 771          esac;\r
 772       od;\r
 773     END menu;\r
 774 \r
 775     UNIT insertlivre :gest_ecran PROCEDURE;\r
 776     VAR x,xret : article,\r
 777         xmatiere,xm,xauteur,xa : index_elem;\r
 778     BEGIN\r
 779       CALL cls;\r
 780       CALL cadre(1,1,22,80);\r
 781       CALL setcursor(1,30);\r
 782       CALL reverse;\r
 783       write("inserer un livre");\r
 784       CALL normal;\r
 785 \r
 786       x := new article;\r
 787       xmatiere := new index_elem;\r
 788       xauteur := new index_elem;\r
 789 \r
 790       CALL setcursor(10,15);\r
 791       write("titre     : ..............................");\r
 792       CALL setcursor(10,27);\r
 793       CALL x.e.lit;\r
 794       CALL SETCURSOR(12,15);\r
 795       WRITE("auteur    : ..............................");\r
 796       CALL setcursor(12,27);\r
 797       CALL xauteur.e.lit;\r
 798       CALL SETCURSOR(14,15);\r
 799       WRITE("matiere   : ..............................");\r
 800       CALL setcursor(14,27);\r
 801       CALL xmatiere.e.lit;\r
 802 \r
 803       CALL x.c(1).copyy(xauteur.e);\r
 804       CALL x.c(2).copyy(xmatiere.e);\r
 805 \r
 806       IF bfiche.member(x)\r
 807       THEN\r
 808         write("existe deja");\r
 809       ELSE\r
 810         IF bmatiere.member(xmatiere)\r
 811         THEN\r
 812           CALL xmatiere.lis.insert(x.e);\r
 813         ELSE\r
 814           CALL bmatiere.inserer(xmatiere);\r
 815           CALL xmatiere.lis.insert(x.e);\r
 816         FI;\r
 817           \r
 818         IF bauteur.member(xauteur) \r
 819         THEN\r
 820           CALL xauteur.lis.insert(x.e);\r
 821         ELSE\r
 822           CALL xauteur.lis.insert(x.e);\r
 823           CALL bauteur.inserer(xauteur);\r
 824         FI;\r
 825         CALL bfiche.inserer(x);\r
 826       \r
 827       FI;\r
 828       CALL finn;\r
 829 \r
 830     END insertlivre;\r
 831 \r
 832 \r
 833     UNIT supprilivre :gest_ecran PROCEDURE;\r
 834     VAR x : article,\r
 835         xauteur,xa,xmatiere,xm:index_elem;\r
 836     BEGIN\r
 837       CALL cls;\r
 838       CALL cadre(1,1,22,80);\r
 839       CALL setcursor(1,30);\r
 840       CALL reverse;\r
 841       write("supprimer un livre");\r
 842       CALL normal;\r
 843       x:=new article;\r
 844       xmatiere:=new index_elem;\r
 845       xauteur:=new index_elem;\r
 846 \r
 847       CALL setcursor(10,15);\r
 848       write("titre     : ..............................");\r
 849       CALL setcursor(10,27);\r
 850       CALL x.e.lit;\r
 851       CALL SETCURSOR(12,15);\r
 852       WRITE("auteur    : ..............................");\r
 853       CALL setcursor(12,27);\r
 854       CALL xauteur.e.lit;\r
 855       CALL SETCURSOR(14,15);\r
 856       WRITE("matiere   : ..............................");\r
 857       CALL setcursor(14,27);\r
 858       CALL xmatiere.e.lit;\r
 859 \r
 860       CALL bfiche.supprimer(x);\r
 861 \r
 862       IF bmatiere.member(xmatiere)\r
 863       THEN\r
 864         CALL xmatiere.lis.suppr(x.e);\r
 865         IF xmatiere.lis.debut=none THEN CALL bmatiere.supprimer(xmatiere) FI;\r
 866       FI;\r
 867 \r
 868       IF bauteur.member(xauteur)\r
 869       THEN\r
 870         CALL xauteur.lis.suppr(x.e);\r
 871         IF xauteur.lis.debut=none THEN CALL bauteur.supprimer(xauteur) FI;\r
 872       FI;\r
 873 \r
 874       CALL setcursor(18,50);\r
 875       CALL finn;\r
 876     END supprilivre;\r
 877 \r
 878     UNIT recherche :gest_ecran PROCEDURE;\r
 879     var\r
 880        i : integer,\r
 881        x : article,\r
 882        xx : index_elem,\r
 883        reponse : boolean,\r
 884        c : chaine;\r
 885     BEGIN\r
 886          c := new chaine;\r
 887          x := new article;\r
 888          xx := new index_elem;\r
 889          CALL cadre_t;\r
 890          CALL reverse;\r
 891          CALL setcursor(2,30);\r
 892          write("recherche");\r
 893          CALL normal;\r
 894 \r
 895          CALL setcursor(10,15);\r
 896          write("titre     : 1");\r
 897          CALL SETCURSOR(12,15);\r
 898          WRITE("auteur    : 2");\r
 899          CALL SETCURSOR(14,15);\r
 900          WRITE("matiere   : 3");\r
 901          CALL SETCURSOR(16,15);\r
 902          WRITE("quel champ de recherche  ");readln(i);\r
 903          CALL SETCURSOR(18,15);\r
 904          write("..............................");\r
 905          CALL SETCURSOR(18,15);\r
 906          CALL c.lit;\r
 907          case i\r
 908               when 1 :\r
 909                    CALL x.e.copyy(c);\r
 910                    reponse := bfiche.member(x);\r
 911                    CALL cadre_t;\r
 912                    CALL setcursor(4,30);\r
 913                    CALL reverse;\r
 914                    write("     RECHERCHE OUVRAGE       ");\r
 915                    IF reponse \r
 916                    THEN\r
 917                      CALL normal;\r
 918                      CALL setcursor(10,15);\r
 919                      write("titre   : ");\r
 920                      CALL setcursor(10,30);\r
 921                      CALL x.e.afi;\r
 922                      CALL SETCURSOR(12,15);\r
 923                      WRITE("auteur  : ");\r
 924                      CALL setcursor(12,30);\r
 925                      CALL x.c(1).afi;\r
 926                      CALL SETCURSOR(14,15);\r
 927                      WRITE("matiere : ");\r
 928                      CALL SETCURSOR(14,30);\r
 929                      CALL x.c(2).afi;\r
 930                    ELSE\r
 931                      CALL normal;\r
 932                      CALL setcursor(10,15);\r
 933                      write("element inexistant");\r
 934                    FI;\r
 935               when 2 :\r
 936                    CALL cadre_t;\r
 937                    CALL setcursor(4,30);\r
 938                    CALL reverse;\r
 939                    write("     RECHERCHE AUTEUR      ");\r
 940                    CALL normal;\r
 941                    CALL xx.e.copyy(c);\r
 942                    reponse := bauteur.member(xx);\r
 943                    if reponse then\r
 944                       CALL reverse;\r
 945                       CALL setcursor(5,10);\r
 946                       CALL xx.e.afi;\r
 947                       CALL normal;\r
 948                       CALL xx.lis.affi;\r
 949                    else\r
 950                      CALL setcursor(10,15);\r
 951                      write("introuvable");\r
 952                    fi;\r
 953               when 3 :\r
 954                    CALL cadre_t;\r
 955                    CALL setcursor(4,30);\r
 956                    CALL reverse;\r
 957                    write("     RECHERCHE MATIERE    ");\r
 958                    CALL normal;\r
 959                    CALL xx.e.copyy(c);\r
 960                    reponse := bmatiere.member(xx);\r
 961                    CALL cls;\r
 962                    CALL cadre(1,1,22,80);\r
 963                    if reponse then\r
 964                       CALL reverse;\r
 965                       CALL setcursor(5,10);\r
 966                       CALL xx.e.afi;\r
 967                       CALL normal;\r
 968                      (* CALL setcursor(1,2); *)\r
 969                       CALL xx.lis.affi;\r
 970                     else\r
 971                       CALL setcursor(10,15);\r
 972                         write("introuvable");\r
 973                     fi;\r
 974               esac;\r
 975          CALL finn;\r
 976 \r
 977     END recherche;\r
 978 \r
 979 \r
 980     UNIT llist :gest_ecran PROCEDURE;\r
 981     var\r
 982        i,fin : integer,\r
 983        lig,col : integer;\r
 984     BEGIN\r
 985 \r
 986          CALL cadre_t;\r
 987          CALL reverse;\r
 988          CALL setcursor(2,30);\r
 989          write("recherche");\r
 990          CALL normal;\r
 991 \r
 992          CALL setcursor(10,15);\r
 993          write("titre     : 1");\r
 994          CALL SETCURSOR(12,15);\r
 995          WRITE("auteur    : 2");\r
 996          CALL SETCURSOR(14,15);\r
 997          WRITE("matiere   : 3");\r
 998          CALL SETCURSOR(16,15);\r
 999          WRITE("quel champ de liste ");readln(i);\r
1000          case i\r
1001               when 1 :\r
1002                 CALL cadre_t;\r
1003                 CALL setcursor(2,30);\r
1004                 CALL reverse;\r
1005                 write("          liste des ouvrages          ");\r
1006                 CALL normal;\r
1007                 lig := 4;\r
1008                 col := 2;\r
1009                 CALL bfiche.list(bfiche.root,lig,col);\r
1010                 CALL setcursor(18,50);\r
1011                 CALL finn;\r
1012               when 2:\r
1013                 CALL cadre_t;\r
1014                 CALL setcursor(2,30);\r
1015                 CALL reverse;\r
1016                 write("             liste des auteurs             ");\r
1017                 CALL normal;\r
1018                 lig := 4;\r
1019                 col := 2;\r
1020                 CALL bauteur.list(bauteur.root,lig,col);\r
1021                 CALL finn;\r
1022              when 3 :\r
1023                 CALL cadre_t;\r
1024                 CALL setcursor(4,30);\r
1025                 CALL reverse;\r
1026                 write("              liste des matiere          ");\r
1027                 CALL normal;\r
1028                 lig := 4;\r
1029                 col := 2;\r
1030                 CALL bmatiere.list(bmatiere.root,lig,col);\r
1031                 CALL finn;\r
1032              esac;\r
1033     END llist;\r
1034 \r
1035 \r
1036 var\r
1037 \r
1038    bfiche,bmatiere,bauteur : barb;\r
1039 \r
1040 \r
1041 \r
1042 BEGIN\r
1043     bmatiere := new barb(2);\r
1044     bauteur := new barb(2);\r
1045     bfiche := new barb(2);\r
1046     CALL menu;\r
1047 \r
1048 END;\r