examples/data_str/barbre.log

   1 Program BArbres;\r
   2 (*****************************************************************************)\r
   3 (*                                                                           *)\r
   4 (*                PROJET LI1 Nø1              pour le 15/01/94               *)\r
   5 (*                                                                           *)\r
   6 (* PATAUD Frederic                                                           *)\r
   7 (* PEYRAT Francois                                                           *)\r
   8 (*                                                                           *)\r
   9 (*                           Structure des Barbres                           *)\r
  10 (*                                                                           *)\r
  11 (*****************************************************************************)\r
  12 \r
  13 \r
  14 (*****************************************************************************)\r
  15 (*                         Structure d'une donnees                           *)\r
  16 (*****************************************************************************)\r
  17 Unit STData : class;\r
  18 var data : integer;\r
  19 End STData;\r
  20 \r
  21 \r
  22 \r
  23 (*****************************************************************************)\r
  24 (*                    Structure d'une page d'un B_Arbre                      *)\r
  25 (*****************************************************************************)\r
  26 Unit STPage : class (N : integer);\r
  27 Var pere   : STPage;\r
  28 var nbdata : integer;\r
  29 var data   : arrayof STData;\r
  30 var fils   : arrayof STPage;\r
  31 Begin\r
  32  nbdata:=0;               (* A l'initialisation il n'y a pas de data         *)\r
  33  array data dim (1:2*N);  (* Il y a au plus 2n donnees dans une page         *)\r
  34  array fils dim (1:2*N+1);(* et au plus 2n+1 fils.                           *)\r
  35  pere:=none;              (* Aucun pere n'est definit \85 la creation.         *)\r
  36 End STPage;\r
  37 \r
  38 \r
  39 \r
  40 (*****************************************************************************)\r
  41 (*                 retourne 1 si elmt1 > elmt2  sinon 0                      *)\r
  42 (*****************************************************************************)\r
  43 Unit Superieur : function (elmt1,elmt2 : STData) : boolean;\r
  44 Begin\r
  45  if elmt1.data>elmt2.data\r
  46  then result:=true\r
  47  else result:=false\r
  48  fi\r
  49 End Superieur;\r
  50 \r
  51 \r
  52 \r
  53 (*****************************************************************************)\r
  54 (*                 retourne 1 si elmt1 < elmt2  sinon 0                      *)\r
  55 (*****************************************************************************)\r
  56 Unit Inferieur : function (elmt1,elmt2 : STData) : boolean;\r
  57 Begin\r
  58  if elmt1.data<elmt2.data\r
  59  then result:=true\r
  60  else result:=false\r
  61  fi\r
  62 End Inferieur;\r
  63 \r
  64 \r
  65 \r
  66 (*****************************************************************************)\r
  67 (*                 retourne 1 si elmt1 = elmt2  sinon 0                      *)\r
  68 (*****************************************************************************)\r
  69 Unit Egalite : function (elmt1,elmt2 : STData) : boolean;\r
  70 Begin\r
  71  if elmt1.data=elmt2.data\r
  72  then result:=true\r
  73  else result:=false\r
  74  fi\r
  75 End Egalite;\r
  76 \r
  77 \r
  78 \r
  79 (*****************************************************************************)\r
  80 (*                                                                           *)\r
  81 (*****************************************************************************)\r
  82 Unit Barbre : class (N : integer);\r
  83 Var root : STPage;\r
  84 \r
  85 \r
  86  (****************************************************************************)\r
  87  (*            Retourne un booleen indiquant si l'arbre est vide             *)\r
  88  (****************************************************************************)\r
  89  Unit Vide : function : boolean;\r
  90  Begin\r
  91   result:=root.nbdata=0;  (* Si la racine n'a pas d'element alors arbre vide *)\r
  92  End Vide;\r
  93 \r
  94 \r
  95  (****************************************************************************)\r
  96  (*                Retourne la valeur du minimun de l'arbre                  *)\r
  97  (****************************************************************************)\r
  98  Unit Minimum : function (output data : STData) : boolean;\r
  99  var page : STPage\r
 100  Begin\r
 101   call outgtext("Recherche minimum... ");\r
 102   if not vide\r
 103   then page:=root;\r
 104        do\r
 105         if page.fils(1)=none        (* le minimum se trouve le plus en bas  *)\r
 106         then data:=page.data(1);    (* \85 gauche de l'arbre                  *)\r
 107              exit\r
 108         fi;\r
 109         page:=page.fils(1)\r
 110        od;\r
 111        result:=true;\r
 112   else call outgtext("L'arbre est vide !!!");          (* il y a une erreur  *)\r
 113        result:=false\r
 114   fi\r
 115  End Minimum;\r
 116 \r
 117 \r
 118  (****************************************************************************)\r
 119  (*                 Retourne la valeur du maximum de l'arbre                 *)\r
 120  (****************************************************************************)\r
 121  Unit Maximum : function (output data : STData) : boolean;\r
 122  Var page : STPage;\r
 123  Begin\r
 124   call outgtext("Recherche maximum... ");\r
 125   if not vide\r
 126   then page:=root;\r
 127        do\r
 128         if page.fils(page.nbdata)=none       (* le maximum est l'element le *)\r
 129         then data:=page.data(page.nbdata); (* plus \85 droite de l'arbre    *)\r
 130              exit\r
 131         fi;\r
 132         page:=page.fils(page.nbdata+1);\r
 133        od;\r
 134        result:=true;\r
 135   else call outgtext("L'arbre est vide !!!");\r
 136        result:=false;\r
 137   fi;\r
 138  End Maximum;\r
 139 \r
 140 \r
 141  (****************************************************************************)\r
 142  (*   Retourne vraie si l'element elmt est dans l'arbre ainsi que la page    *)\r
 143  (*     la recherche va se faire par dichotomie, ameliorant le nombre de     *)\r
 144  (*  comparaisons necessaire pour trouver :                                  *)\r
 145  (*                                    -soit l'element dans la page courante *)\r
 146  (*                                    -soit la page suivante a examiner     *)\r
 147  (****************************************************************************)\r
 148  Unit Membre : function (input elmt : STData; output page : STPage) : boolean;\r
 149  Var a,milieu,b : integer;\r
 150  Begin\r
 151   call outgtext("Recherche donn\82e...");\r
 152   result:=false;\r
 153   if not vide\r
 154   then page:=root;\r
 155        do\r
 156         a:=0;                            (* a=debut de l'intervalle         *)\r
 157         b:=page.nbdata+1;                (* b=fin de l'intervalle           *)\r
 158         do\r
 159          milieu:=(a+b) div 2;            (* milieu = milieu de l'intervalle *)\r
 160          if Superieur(page.data(milieu),elmt)\r
 161          then b:=milieu\r
 162          else a:=milieu\r
 163          fi;\r
 164          if Egalite(page.data(milieu),elmt)\r
 165          then result:=true;             (* on a trouve l'element           *)\r
 166               exit\r
 167          else if (b-a)=1                (* on sort sans avoir touver       *)\r
 168               then exit\r
 169               fi;\r
 170          fi\r
 171         od;\r
 172         if result\r
 173         then exit\r
 174         fi;\r
 175         if page.fils(1)=none             (*  si plus de page alors on sort  *)\r
 176         then exit\r
 177         fi;\r
 178         if Superieur(page.data(milieu),elmt)     (* sinon on change de page *)\r
 179         then page:=page.fils(milieu)\r
 180         else page:=page.fils(milieu+1)\r
 181         fi\r
 182        od\r
 183   else call outgtext("L'arbre est vide!!!")\r
 184   fi\r
 185  End Membre;\r
 186 \r
 187 \r
 188 \r
 189  (****************************************************************************)\r
 190  (*                         Insertion d'un element                           *)\r
 191  (****************************************************************************)\r
 192  Unit Insertion : procedure (elmt : STData);\r
 193  Var a,milieu,b,i : integer;\r
 194  var aux_fils     : arrayof STPage;\r
 195  var aux_data     : arrayof STData;\r
 196  var pagenew,page : STPage;\r
 197  var sauv1,sauv2  : STPage;\r
 198  Begin\r
 199   page:=root;\r
 200   if vide                       (* on insert la premiere donnee dans l'arbre *)\r
 201   then page.data(1):=elmt;\r
 202        page.nbdata:=1;\r
 203        call outgtext("L'\82l\82ment a \82t\82 ajout\82.")\r
 204   else if not membre(elmt,page)          (* l'element elmt n'existe pas deja *)\r
 205        then do\r
 206              if page <> none    (* s'il ne faut pas creer une nouvelle page *)\r
 207              then a:=0;\r
 208                   b:=page.nbdata+1;\r
 209                   do  (* recherche dichotomique de la position dans la page *)\r
 210                    milieu:=(a+b) div 2;\r
 211                    if Superieur(page.data(milieu),elmt)\r
 212                    then b:=milieu\r
 213                    else a:=milieu\r
 214                    fi;\r
 215                    if (b-a)=1\r
 216                    then exit\r
 217                    fi;\r
 218                   od;\r
 219                   if Inferieur(page.data(milieu),elmt)\r
 220                   then milieu:=milieu+1\r
 221                   fi;\r
 222                   if page.nbdata < 2*N (* si on n'a pas le maximum d'elments*)\r
 223                   then for i:=page.nbdata downto milieu\r
 224                        do               (* on decale pour inserer l'element *)\r
 225                         page.data(i+1):=page.data(i);\r
 226                         page.fils(i+2):=page.fils(i+1)\r
 227                        od;\r
 228                        page.data(milieu):=elmt;      (* on insert l'element *)\r
 229                        page.fils(milieu+1):=pagenew;\r
 230                        page.nbdata:=page.nbdata+1;\r
 231                        exit\r
 232                   else a:=1;\r
 233                        b:=page.nbdata+1;\r
 234                        array aux_data dim (a:b);\r
 235                        array aux_fils dim (a:b+1);\r
 236                        for i:=1 to milieu-1         (* on sauve les donnees *)\r
 237                        do\r
 238                         aux_data(i):=page.data(i);\r
 239                         aux_fils(i):=page.fils(i);\r
 240                        od;\r
 241                        aux_fils(i):=page.fils(i);\r
 242                        aux_data(milieu):=elmt;\r
 243                        aux_fils(milieu+1):=pagenew;\r
 244                        for i:=milieu to 2*N\r
 245                        do\r
 246                         aux_data(i+1):=page.data(i);\r
 247                         aux_fils(i+2):=page.fils(i);\r
 248                        od;\r
 249                        pagenew:= new STPage(N);\r
 250                        page.nbdata:=n;\r
 251                        pagenew.nbdata:=n;\r
 252                        for i:=1 to n                    (* on coupe en deux *)\r
 253                        do\r
 254                         pagenew.data(i):=aux_data(n+1+i);\r
 255                         page.data(i):=aux_data(i);\r
 256                         pagenew.fils(i):=aux_fils(n+1+i);\r
 257                         page.fils(i):=aux_fils(i);\r
 258                        od;\r
 259                        pagenew.fils(i):=aux_fils(n+1+i);\r
 260                        page.fils(i):=aux_fils(i);\r
 261                        elmt:=aux_data(n+1);\r
 262                        sauv1:=page;\r
 263                        if page.fils(1) <> none   (* on rechaine les parents *)\r
 264                        then for i:=1 to n+1\r
 265                             do\r
 266                              pagenew.fils(i).pere:=pagenew;\r
 267                             od\r
 268                        fi;\r
 269                        pagenew.pere:=page.pere;\r
 270                        page:=page.pere;\r
 271                        kill(aux_data);          (* on efface les            *)\r
 272                        kill(aux_fils);          (* variables intermediaires *)\r
 273                   fi\r
 274              else sauv2:=pagenew;\r
 275                   pagenew:= new STPage(N);  (* creation d'une nouvelle page *)\r
 276                   pagenew.nbdata:=1;\r
 277                   pagenew.data(1):=elmt;\r
 278                   pagenew.fils(1):=sauv1;\r
 279                   pagenew.fils(2):=sauv2;\r
 280                   sauv1.pere:=pagenew;\r
 281                   sauv2.pere:=pagenew;\r
 282                   root:=pagenew;             (* il y a changement de racine *)\r
 283                   exit\r
 284              fi\r
 285             od;\r
 286             call outgtext("L'\82l\82ment a \82t\82 ajout\82.");\r
 287        else call outgtext("L'\82l\82ment existe deja!") (* l'element existe deja *)\r
 288        fi\r
 289   fi\r
 290  End Insertion;\r
 291 \r
 292 \r
 293  (****************************************************************************)\r
 294  (*                       Suppression d'un element                           *)\r
 295  (****************************************************************************)\r
 296  Unit Supprimer : procedure (elmt : STData);\r
 297  var a,milieu,b,i : integer;\r
 298  var aux_data     : arrayof STData;\r
 299  var aux_fils     : arrayof STPage;\r
 300  var page,avant   : STPage;\r
 301  var courant,pere : STPage;\r
 302  var pred,aux     : integer;\r
 303 \r
 304  Begin\r
 305   if vide                                             (* l'arbre est vide ?! *)\r
 306   then call outgtext("L'arbre est vide!!!")\r
 307   else page:=root;\r
 308        if not membre(elmt,page)       (* l'element n'est pas dans l'arbre ?! *)\r
 309        then call outgtext("Donn\82e pas ds l'arbre.")\r
 310        else courant:=page;\r
 311             a:=0;       (* on recherche par dichotomie la place de l'element *)\r
 312             b:=courant.nbdata+1;\r
 313             do\r
 314              milieu:=(a+b) div 2;\r
 315              if Superieur(page.data(milieu),elmt)\r
 316              then b:=milieu\r
 317              else a:=milieu\r
 318              fi;\r
 319              if Egalite(page.data(milieu),elmt)\r
 320              then exit\r
 321              fi\r
 322             od;                                             (* on a sa place *)\r
 323             if courant.fils(milieu) <> none\r
 324             then courant:=courant.fils(milieu)\r
 325             fi;\r
 326             while courant.fils(courant.nbdata+1) <> none\r
 327             do\r
 328              courant:=courant.fils(courant.nbdata+1)\r
 329             od;\r
 330             if page.fils(1) <> none\r
 331             then page.data(milieu):=courant.data(courant.nbdata)\r
 332             else for i:=milieu to courant.nbdata-1\r
 333                  do\r
 334                   page.data(i):=page.data(i+1)\r
 335                  od\r
 336             fi;\r
 337             courant.nbdata:=courant.nbdata-1;\r
 338             if courant.nbdata < N\r
 339             then if courant=root\r
 340                  then exit\r
 341                  fi;\r
 342                  do\r
 343                   pere:=courant.pere;\r
 344                   i:=1;\r
 345                   do\r
 346                    if pere.fils(i)=courant\r
 347                    then exit\r
 348                    fi;\r
 349                    i:=i+1\r
 350                   od;\r
 351                   pred:=i-1;\r
 352                   if pred <> 0\r
 353                   then avant:=pere.fils(pred)\r
 354                   else avant:=courant;\r
 355                        pred:=1;\r
 356                        courant:=pere.fils(2)\r
 357                   fi;\r
 358                   if avant.nbdata <= N\r
 359                   then if courant.nbdata > N\r
 360                        then array aux_data dim (1:3*N);\r
 361                             array aux_fils dim (1:3*N+1);\r
 362                             for i:=1 to avant.nbdata\r
 363                             do\r
 364                              aux_data(i):=avant.data(i);\r
 365                              aux_fils(i):=avant.fils(i)\r
 366                             od;\r
 367                             aux_fils(i):=avant.fils(i);\r
 368                             aux_data(i):=pere.data(pred);\r
 369                             for i:=avant.nbdata+2 to avant.nbdata+1+courant.nbdata\r
 370                             do\r
 371                              aux_data(i):=courant.data(i-avant.nbdata-1);\r
 372                              aux_fils(i):=courant.fils(i-avant.nbdata-1)\r
 373                             od;\r
 374                             aux_fils(i):=courant.fils(i-avant.nbdata-1);\r
 375                             aux:=avant.nbdata+1+courant.nbdata;\r
 376                             milieu:=aux div 2 +1;\r
 377                             for i:=1 to milieu-1\r
 378                             do\r
 379                              avant.data(i):=aux_data(i);\r
 380                              avant.fils(i):=aux_fils(i)\r
 381                             od;\r
 382                             avant.fils(i):=aux_fils(i);\r
 383                             avant.nbdata:=milieu-1;\r
 384                             pere.data(pred):=aux_data(milieu);\r
 385                             for i:=milieu+1 to aux\r
 386                             do\r
 387                              courant.data(i-milieu):=aux_data(i);\r
 388                              courant.fils(i-milieu):=aux_fils(i)\r
 389                             od;\r
 390                             courant.fils(i-milieu):=aux_fils(i);\r
 391                             courant.nbdata:=aux-avant.nbdata-1\r
 392                        else for i:=avant.nbdata+2 to avant.nbdata+1+courant.nbdata\r
 393                             do\r
 394                              avant.data(i):=courant.data(i-avant.nbdata-1);\r
 395                              avant.fils(i):=courant.fils(i-avant.nbdata-1);\r
 396                              if courant.fils(i-avant.nbdata-1) <> none\r
 397                              then courant.fils(i-avant.nbdata-1).pere:=avant\r
 398                              fi\r
 399                             od;\r
 400                             avant.fils(i):=courant.fils(i-avant.nbdata-1);\r
 401                             if courant.fils(i-avant.nbdata-1) <> none\r
 402                             then courant.fils(i-avant.nbdata-1).pere:=avant\r
 403                             fi;\r
 404                             avant.data(avant.nbdata+1):=pere.data(pred);\r
 405                             avant.nbdata:=avant.nbdata+1+courant.nbdata;\r
 406                             for i:=pred+1 to pere.nbdata\r
 407                             do\r
 408                              pere.data(i-1):=pere.data(i);\r
 409                              pere.fils(i):=pere.fils(i+1)\r
 410                             od;\r
 411                             pere.fils(pere.nbdata+1):=none;\r
 412                             pere.nbdata:=pere.nbdata-1;\r
 413                             if pere.nbdata=0\r
 414                             then root:=avant;\r
 415                                  root.pere:=none\r
 416                             fi\r
 417                        fi\r
 418                   else array aux_data dim (1:3*N);\r
 419                        array aux_fils dim (1:3*N+1);\r
 420                        for i:=1 to avant.nbdata\r
 421                        do\r
 422                         aux_data(i):=avant.data(i);\r
 423                         aux_fils(i):=avant.fils(i)\r
 424                        od;\r
 425                        aux_fils(i):=avant.fils(i);\r
 426                        aux_data(i):=pere.data(pred);\r
 427                        for i:=avant.nbdata+2 to avant.nbdata+1+courant.nbdata\r
 428                        do\r
 429                         aux_data(i):=courant.data(i-avant.nbdata-1);\r
 430                         aux_fils(i):=courant.fils(i-avant.nbdata-1)\r
 431                        od;\r
 432                        aux_fils(i):=courant.fils(i-avant.nbdata-1);\r
 433                        aux:=avant.nbdata+1+courant.nbdata;\r
 434                        milieu:=aux div 2 +1;\r
 435                        for i:=1 to milieu-1\r
 436                        do\r
 437                         avant.data(i):=aux_data(i);\r
 438                         avant.fils(i):=aux_fils(i)\r
 439                        od;\r
 440                        avant.fils(i):=aux_fils(i);\r
 441                        avant.nbdata:=milieu-1;\r
 442                        pere.data(pred):=aux_data(milieu);\r
 443                        for i:=milieu+1 to aux\r
 444                        do\r
 445                         courant.data(i-milieu):=aux_data(i);\r
 446                         courant.fils(i-milieu):=aux_fils(i)\r
 447                        od;\r
 448                        courant.fils(i-milieu):=aux_fils(i);\r
 449                        courant.nbdata:=aux-avant.nbdata-1\r
 450                   fi;\r
 451                   if avant <> root\r
 452                   then avant:=pere;\r
 453                        if avant <> root\r
 454                        then if avant.nbdata < N\r
 455                             then pere:=pere.pere;\r
 456                                  i:=1;\r
 457                                  do\r
 458                                   if pere.fils(i)=avant\r
 459                                   then exit\r
 460                                   fi;\r
 461                                   i:=i+1\r
 462                                  od;\r
 463                                  courant:=pere.fils(i+1);\r
 464                                  if courant=none\r
 465                                  then courant:=avant;\r
 466                                       avant:=pere.fils(i-1)\r
 467                                  fi\r
 468                             else exit\r
 469                             fi\r
 470                        else exit\r
 471                        fi\r
 472                   else exit\r
 473                   fi\r
 474                  od\r
 475             fi;\r
 476             call outgtext("El\82ment supprim\82.")\r
 477        fi\r
 478   fi\r
 479  End Supprimer;\r
 480 \r
 481 Begin\r
 482  root:=new STPage(N);\r
 483 End Barbre;\r
 484 \r
 485 (****************************************************************************)\r
 486 (*   dessine une ligne entre les points (x1,y1) et (x2,y2) de la couleur c  *)\r
 487 (****************************************************************************)\r
 488 unit line : procedure(x1,y1,x2,y2,c:integer);\r
 489 begin\r
 490  pref iiuwgraph block\r
 491  begin\r
 492   call color(c);\r
 493   call move(x1,y1);\r
 494   call draw(x2,y2);\r
 495   call color(colore)\r
 496  end\r
 497 end line;\r
 498 \r
 499 (****************************************************************************)\r
 500 (*   dessine une boite entre les points (x1,y1) et (x2,y2) de la couleur c  *)\r
 501 (****************************************************************************)\r
 502 unit rectanglef : procedure(x1,y1,x2,y2,c:integer);\r
 503 var i : integer;\r
 504 begin\r
 505  pref iiuwgraph block\r
 506  begin\r
 507   for i:=y1 to y2\r
 508   do\r
 509     call line(x1,i,x2,i,c)\r
 510   od;\r
 511   call color(colore)\r
 512  end\r
 513 end rectanglef;\r
 514 \r
 515 (****************************************************************************)\r
 516 (* dessine un rectangle entre les points (x1,y1) et (x2,y2) de la couleur c *)\r
 517 (****************************************************************************)\r
 518 unit rectangle : procedure(x1,y1,x2,y2,c:integer);\r
 519 begin\r
 520  pref iiuwgraph block\r
 521  begin\r
 522   call line(x1,y1,x2,y1,c);\r
 523   call line(x2,y1,x2,y2,c);\r
 524   call line(x2,y2,x1,y2,c);\r
 525   call line(x1,y2,x1,y1,c);\r
 526   call color(colore)\r
 527  end\r
 528 end rectangle;\r
 529 \r
 530 (****************************************************************************)\r
 531 (*      dessine un rectangle en pointilles entre (x1,y1) et (x2,y2)         *)\r
 532 (****************************************************************************)\r
 533 unit rectpoint : procedure(x1,y1,x2,y2,c:integer);\r
 534 var i : integer;\r
 535 begin\r
 536  pref iiuwgraph block\r
 537  begin\r
 538   for i:=x1 step 4 to x2-2\r
 539   do\r
 540    call line(i,y1,i+2,y1,c);\r
 541    call line(i,y2,i+2,y2,c)\r
 542   od;\r
 543   for i:=y1 step 4 to y2-2\r
 544   do\r
 545    call line(x1,i,x1,i+2,c);\r
 546    call line(x2,i,x2,i+2,c)\r
 547   od\r
 548  end\r
 549 end rectpoint;\r
 550 \r
 551 \r
 552 \r
 553 \r
 554 (****************************************************************************)\r
 555 (*       affiche le bandeau de commande en premiere ligne de l'ecran        *)\r
 556 (****************************************************************************)\r
 557 unit affiche : procedure;\r
 558 var i : integer;\r
 559 begin\r
 560  pref iiuwgraph block\r
 561  begin\r
 562   call rectanglef(0,0,640,9,colorf);\r
 563   call color(colore);\r
 564   call move(1,1);\r
 565   for i:=1 to nbitem\r
 566   do\r
 567     call move(10+espace*(i-1),1);\r
 568     call outstring(item(i))\r
 569   od;\r
 570   call rectangle(1,15,196,340,colorf);\r
 571   call rectangle(200,15,639,320,colorf);\r
 572   call rectangle(200,325,639,340,colorf);\r
 573   call move(202,330);\r
 574   call outstring(" BArbre d'ordre 3          Li1 : PATAUD F. - PEYRAT F.")\r
 575  end\r
 576 end affiche;\r
 577 \r
 578 (****************************************************************************)\r
 579 (*      gere le menu, retourne le code action soit clavier soit souris      *)\r
 580 (****************************************************************************)\r
 581 unit mousegest : function : integer;\r
 582 var l,r,c : boolean;\r
 583 var x,y   : integer;\r
 584 var rep   : integer;\r
 585 begin\r
 586  pref iiuwgraph block\r
 587  begin\r
 588   pref mouse block\r
 589   begin\r
 590     do\r
 591      call getpress(0,x,y,nbbot,l,r,c);\r
 592      if l\r
 593      then if (y<=10 and y>=1)\r
 594           then result:=(x-10)/espace+1; exit\r
 595           fi\r
 596      fi;\r
 597      rep:=inkey;\r
 598      if (rep>=-65  and rep<=-59)\r
 599      then result:=-rep-58;\r
 600           exit\r
 601      fi\r
 602     od\r
 603   end\r
 604  end\r
 605 end mousegest;\r
 606 \r
 607 (****************************************************************************)\r
 608 (*            initialise le menu et effectue l'action demand\82e              *)\r
 609 (****************************************************************************)\r
 610 unit maine : procedure;\r
 611 var i      : integer;\r
 612 var action : integer;\r
 613 begin\r
 614  pref mouse block\r
 615  begin\r
 616   colorf:=9;\r
 617   colore:=10;\r
 618   espace:=90;\r
 619   nbitem:=7;\r
 620   array item dim (1:nbitem);\r
 621   item(1):=" Inserer ";\r
 622   item(2):=" Effacer ";\r
 623   item(3):=" Affiche ";\r
 624   item(4):=" Membre? ";\r
 625   item(5):=" Minimum ";\r
 626   item(6):=" Maximum ";\r
 627   item(7):=" Quitter ";\r
 628   call affiche;\r
 629   call showcursor;\r
 630   colore:=2;\r
 631   do\r
 632    action:=mousegest;\r
 633    case action\r
 634     when 1: call menu_ins;\r
 635     when 2: call menu_del;\r
 636     when 3: call menu_aff(arbr.root);\r
 637     when 4: call menu_mem;\r
 638     when 5: call menu_min;\r
 639     when 6: call menu_max;\r
 640     when 7: if menu_qui then exit fi\r
 641    esac\r
 642   od\r
 643  end\r
 644 end maine;\r
 645 \r
 646 (****************************************************************************)\r
 647 (* procedure d'affichage dans l'ecran de commandes, fait un scroll si besoin*)\r
 648 (****************************************************************************)\r
 649 unit outgtext : procedure(id : string);\r
 650 var i : integer;\r
 651 begin\r
 652  pref iiuwgraph block\r
 653  begin\r
 654   pref mouse block\r
 655   begin\r
 656    call hidecursor;\r
 657    call color(colore);\r
 658    call move(10,posy);\r
 659    call outstring(id);\r
 660    posy:=posy+10;\r
 661    if (posy>=320)    (* on est en fin de page, on fait un scroll d'une ligne *)\r
 662    then call rectanglef(2,16,195,337,0);\r
 663         posy:=20\r
 664     fi;\r
 665     call showcursor\r
 666   end\r
 667  end\r
 668 end outgtext;\r
 669 \r
 670 (****************************************************************************)\r
 671 (*   lecture d'un entier en mode graphique, esc revient au debut de saisie  *)\r
 672 (****************************************************************************)\r
 673 unit gscanf : function : integer;\r
 674 var valeur : integer;\r
 675 var sauvx,sauvy : integer;\r
 676 var flag : integer;\r
 677 begin\r
 678  pref iiuwgraph block\r
 679  begin\r
 680   valeur:=0;\r
 681   sauvx:=inxpos;\r
 682   sauvy:=inypos;\r
 683   do\r
 684    do\r
 685     flag:=inkey;\r
 686     if (flag>=48 and flag<=57) orif (flag=13) orif (flag=27) then exit fi\r
 687    od;\r
 688    if (flag>=48 and flag<=57)\r
 689    then valeur:=valeur*10+flag-48;\r
 690         call move(inxpos,inypos);\r
 691         call hascii(flag)\r
 692    fi;\r
 693    if (flag=13) then exit fi;\r
 694    if (flag=27)                                   (* on a demand\82 annulation *)\r
 695    then valeur:=0;\r
 696         call rectanglef(sauvx-1,sauvy-3,inxpos,sauvy+7,0);\r
 697         call color(colore);\r
 698         call move(sauvx,sauvy)\r
 699    fi\r
 700   od\r
 701  end;\r
 702  result:=valeur\r
 703 end gscanf;\r
 704 \r
 705 (****************************************************************************)\r
 706 (*          affiche un entier en mode graphique, maximum 6 chiffres         *)\r
 707 (****************************************************************************)\r
 708 unit writint : procedure( valeur : integer);\r
 709 var flag,i : integer;\r
 710 var tbl    : arrayof integer;\r
 711 begin\r
 712  pref iiuwgraph block\r
 713  begin\r
 714   array tbl dim (1:6);\r
 715   flag:=1;                                  (* on 'empile' en ordre reverse *)\r
 716   while valeur<>0\r
 717   do\r
 718    tbl(flag):=valeur mod 10;\r
 719    valeur:=valeur div 10;\r
 720    flag:=flag+1\r
 721   od;\r
 722   for i:=flag-1 downto 1                    (* on affiche dans le bon ordre *)\r
 723   do\r
 724    call hascii(48+tbl(i))\r
 725   od\r
 726  end\r
 727 end writint;\r
 728 \r
 729 \r
 730 (****************************************************************************)\r
 731 (*                affiche ds l'ecran de droite la page courante             *)\r
 732 (****************************************************************************)\r
 733 unit affiche_page : procedure (page : STPage);\r
 734 var i :integer;\r
 735 begin\r
 736  pref iiuwgraph block\r
 737  begin\r
 738   if page<>arbr.root\r
 739   then call line(420,82,420,97,colorf);\r
 740        call cirb(420,77,5,0,0,colorf,0,1,1);\r
 741   fi;\r
 742   for i:=1 to 6\r
 743   do\r
 744    call rectpoint(339+(i-1)*27,97,339+i*27,117,colorf);\r
 745    if i<=page.nbdata\r
 746    then call move(339+(i-1)*27+3,105);\r
 747         call writint(page.data(i).data)\r
 748    fi\r
 749   od\r
 750  end\r
 751 end affiche_page;\r
 752 \r
 753 (****************************************************************************)\r
 754 (*          affiche ds l'ecran de droite la page fille de gauche            *)\r
 755 (****************************************************************************)\r
 756 unit affiche_gche : procedure (page : STPage);\r
 757 var i    : integer;\r
 758 var savi : integer;\r
 759 begin\r
 760  pref iiuwgraph block\r
 761  begin\r
 762   call line(312,220,312,240,colorf);\r
 763   for i:=1 to 6\r
 764   do\r
 765    call rectangle(204+i*27,240,204+(i+1)*27,260,colorf);\r
 766    if i<=page.nbdata\r
 767    then call move(204+i*27+3,248);\r
 768         call writint(page.data(i).data);\r
 769         savi:=i;\r
 770         if page.fils(i) <> none\r
 771         then if i=4\r
 772              then call line(204+i*27,260,204+i*27,275,colorf);\r
 773              else if i<4\r
 774                   then call line(204+i*27,260,204+i*27-5,275,colorf);\r
 775                   else call line(204+i*27,260,204+i*27+5,275,colorf);\r
 776                   fi\r
 777              fi\r
 778         fi\r
 779    fi\r
 780   od;\r
 781   if page.fils(i) <> none\r
 782   then if savi<>3             (* comme on part gche->dte on a soit | soit \ *)\r
 783        then call line(204+(savi+1)*27,260,204+(savi+1)*27+5,275,colorf);\r
 784        else call line(204+(savi+1)*27,260,204+(savi+1)*27,275,colorf);\r
 785        fi\r
 786   fi\r
 787  end\r
 788 end affiche_gche;\r
 789 \r
 790 (****************************************************************************)\r
 791 (*              affiche ds ecran de droite la page fille droite             *)\r
 792 (****************************************************************************)\r
 793 unit affiche_drte : procedure (page :STPage);\r
 794 var i : integer;\r
 795 begin\r
 796  pref iiuwgraph block\r
 797  begin\r
 798   call line(527,220,527,240,colorf);\r
 799   for i:=1 to 6\r
 800   do\r
 801    call rectangle(635-(i+1)*27,240,635-i*27,260,colorf);\r
 802    if (6-i+1)<=page.nbdata\r
 803    then call move(635-(i+1)*27+3,248);\r
 804         call writint(page.data(6-i+1).data);\r
 805         if page.fils(6-i+1) <> none\r
 806         then if (6-i+1)=4\r
 807              then call line(635-i*27,260,635-i*27,275,colorf);\r
 808              else if (6-i+1)>4\r
 809                   then call line(635-i*27,260,635-i*27+5,275,colorf);\r
 810                   else call line(635-i*27,260,635-i*27-5,275,colorf);\r
 811                   fi\r
 812              fi\r
 813         fi\r
 814    fi\r
 815   od;\r
 816   if page.fils(1) <> none\r
 817   then call line(635-i*27,260,635-i*27-5,275,colorf);\r
 818   fi\r
 819  end\r
 820 end affiche_drte;\r
 821 \r
 822 \r
 823 \r
 824 (****************************************************************************)\r
 825 (*                    Lecture de la donn\82e de STData                        *)\r
 826 (****************************************************************************)\r
 827 unit lect_data : function : STData;\r
 828 var d : STData;\r
 829 begin\r
 830  d:=new STData;\r
 831  call outgtext("Entrez la donn\82e : ");\r
 832  d.data:=gscanf;\r
 833  result:=d\r
 834 end lect_data;\r
 835 \r
 836 (****************************************************************************)\r
 837 (*                                menu insertion                            *)\r
 838 (****************************************************************************)\r
 839 unit menu_ins : procedure;\r
 840 var d : STData;\r
 841 begin\r
 842  d:=lect_data;\r
 843  call arbr.insertion(d);\r
 844  call outgtext("")\r
 845 end menu_ins;\r
 846 \r
 847 \r
 848 (****************************************************************************)\r
 849 (*                                menu effacement                           *)\r
 850 (****************************************************************************)\r
 851 unit menu_del : procedure;\r
 852 var d : STData;\r
 853 begin\r
 854   d:=lect_data;\r
 855   call arbr.supprimer(d);\r
 856   call outgtext("")\r
 857 end menu_del;\r
 858 \r
 859 (****************************************************************************)\r
 860 (*               affiche l'aide clavier dans le mode affichage              *)\r
 861 (****************************************************************************)\r
 862 unit help : procedure;\r
 863 begin\r
 864  pref iiuwgraph block\r
 865  begin\r
 866   pref mouse block\r
 867   begin\r
 868    call hidecursor;\r
 869    call rectangle(260,25,625,65,colorf);\r
 870    call move(270,30);\r
 871    call outstring("G: gauche devient pere");\r
 872    call move(270,40);\r
 873    call outstring("D: droite devient pere");\r
 874    call move(270,50);\r
 875    call outstring("P: remonte d'un niveau");\r
 876    call line(450,28,450,62,colorf);\r
 877    call move(460,30);\r
 878    call outstring("1..6: changement  de");\r
 879    call move(460,40);\r
 880    call outstring("      cellule active");\r
 881    call move(460,50);\r
 882    call outstring("      dans  le pere.");\r
 883    call showcursor\r
 884   end\r
 885  end\r
 886 end help;\r
 887 \r
 888 (****************************************************************************)\r
 889 (*           menu de parcours de l'arbre dans la fenetre droite             *)\r
 890 (****************************************************************************)\r
 891 unit menu_aff : procedure(depart : STPage);\r
 892 var pos,spos: integer;\r
 893 var rep,x,y : integer;\r
 894 var l,r,c   : boolean;\r
 895 var page    : STPage;\r
 896 begin\r
 897  pref iiuwgraph block\r
 898  begin\r
 899   pref mouse block\r
 900   begin\r
 901    pos:=1;\r
 902    page:=depart;\r
 903    call rectangle(210,40,245,51,colorf);\r
 904    call move(212,42);\r
 905    call outstring("Exit");\r
 906    call outgtext("Mode affichage");\r
 907    call help;\r
 908    do\r
 909     call hidecursor;\r
 910     call rectanglef(201,66,638,319,0);\r
 911     call affiche_page(page);\r
 912     if page.fils(pos) <> none\r
 913     then  call affiche_gche(page.fils(pos))\r
 914     fi;\r
 915     if page.fils(pos+1) <> none\r
 916     then  call affiche_drte(page.fils(pos+1))\r
 917     fi;\r
 918     call rectangle(339+(pos-1)*27,97,339+pos*27,117,colorf);\r
 919     if page.fils(pos) <> none\r
 920     then call line(339+(pos-1)*27,117,339+(pos-1)*27-5,132,colorf)\r
 921     fi;\r
 922     if page.fils(pos+1) <> none\r
 923     then call line(339+pos*27,117,339+pos*27+5,132,colorf)\r
 924     fi;\r
 925     call showcursor;\r
 926     do\r
 927      call getpress(0,x,y,nbbot,l,r,c);\r
 928      if l\r
 929      then if (y<51 and y>40 and x>211 and x<245)    (* button exit *)\r
 930           then exit exit\r
 931           fi;\r
 932           if (x<501 and x>339 and y<117 and y>97)   (* ds pere chgt gch dte *)\r
 933           then spos:=((x-339) div 27)+1;\r
 934                if spos<=page.nbdata\r
 935                then pos:=spos\r
 936                fi;\r
 937                exit\r
 938           fi;\r
 939           if (x>231 and x<393 and y>240 and y<260) (* fils gche devient pere*)\r
 940           then page:=page.fils(pos);\r
 941                pos:=1;\r
 942                exit\r
 943           fi;\r
 944           if (x>446 and x<608 and y>240 and y<260) (* fils dte devient pere *)\r
 945           then page:=page.fils(pos+1);\r
 946                pos:=1;\r
 947                exit\r
 948           fi;\r
 949           if (page<>arbr.root) and (x>415 and x<425 and y>72 and y<82)\r
 950           then page:=page.pere;             (* on remonte d'un niveau *)\r
 951                pos:=1;\r
 952                exit\r
 953           fi\r
 954      fi;\r
 955      rep:=inkey;\r
 956      if rep=27\r
 957      then exit exit\r
 958      else if (rep>=49 and rep<=54)\r
 959           then spos:=rep-48;\r
 960                if spos<=page.nbdata\r
 961                then pos:=spos;\r
 962                fi;\r
 963                exit\r
 964           fi;\r
 965           if (rep=71 or rep=103)              (* g or G : fils gauche=pere *)\r
 966           then if page.fils(pos)<>none\r
 967                then page:=page.fils(pos);\r
 968                     pos:=1;\r
 969                     exit\r
 970                fi\r
 971           fi;\r
 972           if (rep=68 or rep=100)              (* d or D : fils droite=pere *)\r
 973           then if page.fils(pos+1)<>none\r
 974                then page:=page.fils(pos+1);\r
 975                     pos:=1;\r
 976                     exit\r
 977                fi\r
 978           fi;\r
 979           if (rep=80 or rep=112)            (* p or P : remonte d'un niveau *)\r
 980           then if page.pere<>none\r
 981                then page:=page.pere;\r
 982                     pos:=1;\r
 983                     exit\r
 984                fi\r
 985           fi\r
 986      fi\r
 987     od\r
 988    od;\r
 989    call hidecursor;\r
 990    call rectanglef(210,40,245,51,0);\r
 991    call showcursor;\r
 992    call outgtext("Mode standard");\r
 993    call outgtext("")\r
 994   end\r
 995  end\r
 996 end menu_aff;\r
 997 \r
 998 (****************************************************************************)\r
 999 (*                                menu membre                               *)\r
1000 (****************************************************************************)\r
1001 unit menu_mem : procedure;\r
1002 var d    : STData;\r
1003 var page : STPage;\r
1004 begin\r
1005  d:=lect_data;\r
1006  if arbr.Membre(d,page)\r
1007  then call outgtext("La donn\82e est ds arbre");\r
1008       call menu_aff(page)\r
1009  else call outgtext("Donn\82e absente ds arbre");\r
1010       call outgtext("")\r
1011  fi;\r
1012 end menu_mem;\r
1013 \r
1014 (****************************************************************************)\r
1015 (*                                  menu minimum                            *)\r
1016 (****************************************************************************)\r
1017 unit menu_min : procedure;\r
1018 var d : STData;\r
1019 begin\r
1020  if arbr.Minimum(d)\r
1021  then call writint(d.data)\r
1022  fi;\r
1023  call outgtext("")\r
1024 end menu_min;\r
1025 \r
1026 (****************************************************************************)\r
1027 (*                                   menu maximum                           *)\r
1028 (****************************************************************************)\r
1029 unit menu_max : procedure;\r
1030 var d : STData;\r
1031 begin\r
1032  if arbr.Maximum(d)\r
1033  then call writint(d.data)\r
1034  fi;\r
1035  call outgtext("")\r
1036 end menu_max;\r
1037 \r
1038 (****************************************************************************)\r
1039 (*                                 menu quitte                              *)\r
1040 (****************************************************************************)\r
1041 unit menu_qui : function : boolean;\r
1042 var rep : boolean;\r
1043 var a : integer;\r
1044 begin\r
1045  pref iiuwgraph block\r
1046  begin\r
1047   call outgtext("Voulez-vous quitter");\r
1048   call outgtext(" (o/n) ?");\r
1049   call move(inxpos+8,inypos);\r
1050   do\r
1051    a:=inkey;\r
1052    if (a=111 or a=79)\r
1053    then result:=true;\r
1054         call outstring("o");\r
1055         exit\r
1056    fi;\r
1057    if (a=110 or a=78)\r
1058    then result:=false;\r
1059         call outstring("n");\r
1060         exit\r
1061    fi\r
1062   od;\r
1063   call outgtext("")\r
1064  end\r
1065 end menu_qui;\r
1066 \r
1067 \r
1068 \r
1069 (*****************************************************************************)\r
1070 (*****************************************************************************)\r
1071 (*                                                                           *)\r
1072 (*                   P R O G R A M M E   P R I N C I P A L                   *)\r
1073 (*                                                                           *)\r
1074 (*****************************************************************************)\r
1075 (*****************************************************************************)\r
1076 var colorf,colore : integer;\r
1077 var nbitem : integer;\r
1078 var espace : integer;\r
1079 var item   : arrayof string;\r
1080 var nbbot  : integer;\r
1081 var flag   : boolean;\r
1082 var posy   : integer;\r
1083 var arbr   : Barbre;\r
1084 \r
1085 Begin\r
1086  pref iiuwgraph block\r
1087  begin\r
1088   pref mouse block\r
1089   begin\r
1090    arbr:=new Barbre(3);\r
1091    call gron(1);\r
1092    flag:=init(nbbot);\r
1093    call hpage(0,1,1);\r
1094    posy:=20;\r
1095    call maine;\r
1096    call hidecursor;\r
1097    call groff\r
1098   end\r
1099  end\r
1100 End BArbres.\r