Added upstream from http://ftp.icm.edu.pl/pub/loglan/
[loglan.git] / examples / data_str / new.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'element a ete ajoute.")\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 ete ajoute.");\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):=courant.data(i-avant.nbdata-1);\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;\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,savx : integer;\r
651 var tmap1 : arrayof integer;\r
652 begin\r
653  pref iiuwgraph block\r
654  begin\r
655   call color(colore);\r
656   call move(10,posy);\r
657   call outstring(id);\r
658   posy:=posy+10;\r
659   if (posy>=320)     (* on est en fin de page, on fait un scroll d'une ligne *)\r
660   then savx:=inxpos;\r
661 (*       array tmap1 dim (1:300); *)\r
662 (*       for i:=1 step 10 to 281 *)\r
663 (*       do*)\r
664 (*        call move(1,36+i);*)\r
665 (*        tmap1:=getmap(196,46+i);*)\r
666 (*        call move(1,16+i);*)\r
667 (*        call putmap(tmap1);*)\r
668 (*       od;*)\r
669 (*       call rectanglef(2,317,195,337,0);*)\r
670 (*       posy:=310;              *)\r
671 (*       call move(savx,posy); *)\r
672       call rectanglef(2,16,195,337,0);\r
673       posy:=20;\r
674   fi;\r
675  end\r
676 end outgtext;\r
677 \r
678 (****************************************************************************)\r
679 (*   lecture d'un entier en mode graphique, esc revient au debut de saisie  *)\r
680 (****************************************************************************)\r
681 unit gscanf : function : integer;\r
682 var valeur : integer;\r
683 var sauvx,sauvy : integer;\r
684 var flag : integer;\r
685 begin\r
686  pref iiuwgraph block\r
687  begin\r
688   valeur:=0;\r
689   sauvx:=inxpos;\r
690   sauvy:=inypos;\r
691   do\r
692    do\r
693     flag:=inkey;\r
694     if (flag>=48 and flag<=57) orif (flag=13) orif (flag=27) then exit fi\r
695    od;\r
696    if (flag>=48 and flag<=57)\r
697    then valeur:=valeur*10+flag-48;\r
698         call move(inxpos,inypos);\r
699         call hascii(flag);\r
700    fi;\r
701    if (flag=13) then exit fi;\r
702    if (flag=27)                                   (* on a demand\82 annulation *)\r
703    then valeur:=0;\r
704         call rectanglef(sauvx-1,sauvy-3,inxpos,sauvy+7,0);\r
705         call color(colore);\r
706         call move(sauvx,sauvy);\r
707    fi;\r
708   od;\r
709  end;\r
710  result:=valeur;\r
711 end gscanf;\r
712 \r
713 (****************************************************************************)\r
714 (*          affiche un entier en mode graphique, maximum 6 chiffres         *)\r
715 (****************************************************************************)\r
716 unit writint : procedure( valeur : integer);\r
717 var flag,i : integer;\r
718 var tbl    : arrayof integer;\r
719 begin\r
720  pref iiuwgraph block\r
721  begin\r
722   array tbl dim (1:6);\r
723   flag:=1;                                  (* on 'empile' en ordre reverse *)\r
724   while valeur<>0\r
725   do\r
726    tbl(flag):=valeur mod 10;\r
727    valeur:=valeur div 10;\r
728    flag:=flag+1;\r
729   od;\r
730   for i:=flag-1 downto 1                    (* on affiche dans le bon ordre *)\r
731   do\r
732    call hascii(48+tbl(i));\r
733   od;\r
734  end\r
735 end writint;\r
736 \r
737 \r
738 (****************************************************************************)\r
739 (*                affiche ds l'ecran de droite la page courante             *)\r
740 (****************************************************************************)\r
741 unit affiche_page : procedure (page : STPage);\r
742 var i :integer;\r
743 begin\r
744  pref iiuwgraph block\r
745  begin\r
746   if page<>arbr.root\r
747   then call line(420,82,420,97,colorf);\r
748        call cirb(420,77,5,0,0,colorf,0,1,1);\r
749   fi;\r
750   for i:=1 to 6\r
751   do\r
752    call rectpoint(339+(i-1)*27,97,339+i*27,117,colorf);\r
753    if i<=page.nbdata\r
754    then call move(339+(i-1)*27+3,105);\r
755         call writint(page.data(i).data);\r
756    fi;\r
757   od;\r
758  end\r
759 end affiche_page;\r
760 \r
761 (****************************************************************************)\r
762 (*          affiche ds l'ecran de droite la page fille de gauche            *)\r
763 (****************************************************************************)\r
764 unit affiche_gche : procedure (page : STPage);\r
765 var i    : integer;\r
766 var savi : integer;\r
767 begin\r
768  pref iiuwgraph block\r
769  begin\r
770   call line(312,220,312,240,colorf);\r
771   for i:=1 to 6\r
772   do\r
773    call rectangle(204+i*27,240,204+(i+1)*27,260,colorf);\r
774    if i<=page.nbdata\r
775    then call move(204+i*27+3,248);\r
776         call writint(page.data(i).data);\r
777         savi:=i;\r
778         if page.fils(i) <> none\r
779         then if i=4\r
780              then call line(204+i*27,260,204+i*27,275,colorf);\r
781              else if i<4\r
782                   then call line(204+i*27,260,204+i*27-5,275,colorf);\r
783                   else call line(204+i*27,260,204+i*27+5,275,colorf);\r
784                   fi\r
785              fi\r
786         fi\r
787    fi;\r
788   od;\r
789   if page.fils(i) <> none\r
790   then if savi<>3 (* comme on part gche->dte on a soit | soit \ *)\r
791        then call line(204+(savi+1)*27,260,204+(savi+1)*27+5,275,colorf);\r
792        else call line(204+(savi+1)*27,260,204+(savi+1)*27,275,colorf);\r
793        fi;\r
794   fi;\r
795  end\r
796 end affiche_gche;\r
797 \r
798 (****************************************************************************)\r
799 (*              affiche ds ecran de droite la page fille droite             *)\r
800 (****************************************************************************)\r
801 unit affiche_drte : procedure (page :STPage);\r
802 var i : integer;\r
803 begin\r
804  pref iiuwgraph block\r
805  begin\r
806   call line(527,220,527,240,colorf);\r
807   for i:=1 to 6\r
808   do\r
809    call rectangle(635-(i+1)*27,240,635-i*27,260,colorf);\r
810    if (6-i+1)<=page.nbdata\r
811    then call move(635-(i+1)*27+3,248);\r
812         call writint(page.data(6-i+1).data);\r
813         if page.fils(6-i+1) <> none\r
814         then if (6-i+1)=4\r
815              then call line(635-i*27,260,635-i*27,275,colorf);\r
816              else if (6-i+1)>4\r
817                   then call line(635-i*27,260,635-i*27+5,275,colorf);\r
818                   else call line(635-i*27,260,635-i*27-5,275,colorf);\r
819                   fi\r
820              fi\r
821         fi\r
822    fi;\r
823   od;\r
824   if page.fils(1) <> none\r
825   then call line(635-i*27,260,635-i*27-5,275,colorf);\r
826   fi;\r
827  end\r
828 end affiche_drte;\r
829 \r
830 \r
831 \r
832 (****************************************************************************)\r
833 (*                    Lecture de la donn\82e de STData                        *)\r
834 (****************************************************************************)\r
835 unit lect_data : function : STData;\r
836 var d : STData;\r
837 begin\r
838  d:=new STData;\r
839  call outgtext("Entrez la donn\82e :");\r
840  d.data:=gscanf;\r
841  result:=d;\r
842 end lect_data;\r
843 \r
844 (****************************************************************************)\r
845 (*                                menu insertion                            *)\r
846 (****************************************************************************)\r
847 unit menu_ins : procedure;\r
848 var d : STData;\r
849 begin\r
850  d:=lect_data;\r
851  call arbr.insertion(d);\r
852  call outgtext("");\r
853 end menu_ins;\r
854 \r
855 \r
856 (****************************************************************************)\r
857 (*                                menu effacement                           *)\r
858 (****************************************************************************)\r
859 unit menu_del : procedure;\r
860 var d : STData;\r
861 begin\r
862   d:=lect_data;\r
863   call arbr.supprimer(d);\r
864   call outgtext("");\r
865 end menu_del;\r
866 \r
867 (****************************************************************************)\r
868 (*           menu de parcours de l'arbre dans la fenetre droite             *)\r
869 (****************************************************************************)\r
870 unit menu_aff : procedure;\r
871 var pos,spos: integer;\r
872 var rep,x,y : integer;\r
873 var l,r,c   : boolean;\r
874 var page    : STPage;\r
875 begin\r
876  pref iiuwgraph block\r
877  begin\r
878   pref mouse block\r
879   begin\r
880    pos:=1;\r
881    page:=arbr.root;\r
882    call rectangle(210,25,245,36,colorf);\r
883    call move(212,27);\r
884    call outstring("Exit");\r
885    do\r
886     call hidecursor;\r
887     call outgtext("MENU AFF");\r
888     call rectanglef(201,37,638,319,0);\r
889     call affiche_page(page);\r
890     if page.fils(pos) <> none\r
891     then  call affiche_gche(page.fils(pos));\r
892     fi;\r
893     if page.fils(pos+1) <> none\r
894     then  call affiche_drte(page.fils(pos+1));\r
895     fi;\r
896     call rectangle(339+(pos-1)*27,97,339+pos*27,117,colorf);\r
897     if page.fils(pos) <> none\r
898     then call line(339+(pos-1)*27,117,339+(pos-1)*27-5,132,colorf);\r
899     fi;\r
900     if page.fils(pos+1) <> none\r
901     then call line(339+pos*27,117,339+pos*27+5,132,colorf);\r
902     fi;\r
903     call showcursor;\r
904     do\r
905      call getpress(0,x,y,nbbot,l,r,c);\r
906      if l\r
907      then if (y<36 and y>25 and x>211 and x<245)    (* button exit *)\r
908           then exit exit\r
909           fi;\r
910           if (x<501 and x>339 and y<117 and y>97)   (* ds pere chgt gch dte *)\r
911           then spos:=((x-339) div 27)+1;\r
912                if spos<=page.nbdata\r
913                then pos:=spos\r
914                fi;\r
915                exit\r
916           fi;\r
917           if (x>231 and x<393 and y>240 and y<260) (* fils gche devient pere*)\r
918           then page:=page.fils(pos);\r
919                pos:=1;\r
920                exit;\r
921           fi;\r
922           if (x>446 and x<608 and y>240 and y<260) (* fils dte devient pere *)\r
923           then page:=page.fils(pos+1);\r
924                pos:=1;\r
925                exit;\r
926           fi;\r
927           if (page<>arbr.root) and (x>415 and x<425 and y>72 and y<82)\r
928           then page:=page.pere;             (* on remonte d'un niveau *)\r
929                pos:=1;\r
930                exit\r
931           fi;\r
932      fi;\r
933      rep:=inkey;\r
934      if rep=27\r
935      then exit exit\r
936      else if (rep>=49 and rep<=54)\r
937           then pos:=rep-48;\r
938                exit\r
939           fi;\r
940      fi;\r
941     od;\r
942    od;\r
943    call hidecursor;\r
944    call rectanglef(201,24,638,319,0);\r
945    call showcursor;\r
946   end\r
947  end\r
948 end menu_aff;\r
949 \r
950 (****************************************************************************)\r
951 (*                                menu membre                               *)\r
952 (****************************************************************************)\r
953 unit menu_mem : procedure;\r
954 var d    : STData;\r
955 var page : STPage;\r
956 begin\r
957  d:=lect_data;\r
958  if arbr.Membre(d,page)\r
959  then call outgtext("Donn\82e pr\82sente ds arbre");\r
960  else call outgtext("Donn\82e absente ds arbre");\r
961  fi;\r
962  call outgtext("");\r
963 end menu_mem;\r
964 \r
965 (****************************************************************************)\r
966 (*                                  menu minimum                            *)\r
967 (****************************************************************************)\r
968 unit menu_min : procedure;\r
969 var d : STData;\r
970 begin\r
971  if arbr.Minimum(d)\r
972  then call writint(d.data);\r
973  fi;\r
974  call outgtext("");\r
975 end menu_min;\r
976 \r
977 (****************************************************************************)\r
978 (*                                   menu maximum                           *)\r
979 (****************************************************************************)\r
980 unit menu_max : procedure;\r
981 var d : STData;\r
982 begin\r
983  if arbr.Maximum(d)\r
984  then call writint(d.data);\r
985  fi;\r
986  call outgtext("");\r
987 end menu_max;\r
988 \r
989 (****************************************************************************)\r
990 (*                                 menu quitte                              *)\r
991 (****************************************************************************)\r
992 unit menu_qui : function : boolean;\r
993 var rep : boolean;\r
994 var a : integer;\r
995 begin\r
996  pref iiuwgraph block\r
997  begin\r
998   call outgtext("Voulez-vous quitter");\r
999   call outgtext(" (o/n) ?");\r
1000   call move(inxpos+8,inypos);\r
1001   do\r
1002    a:=inkey;\r
1003    if (a=111 or a=79)\r
1004    then result:=true;\r
1005         call outgtext("o");\r
1006         exit\r
1007    fi;\r
1008    if (a=110 or a=78)\r
1009    then result:=false;\r
1010         call outgtext("n");\r
1011         exit\r
1012    fi;\r
1013   od;\r
1014   call outgtext("");\r
1015  end\r
1016 end menu_qui;\r
1017 \r
1018 \r
1019 \r
1020 (*****************************************************************************)\r
1021 (*****************************************************************************)\r
1022 (*                                                                           *)\r
1023 (*                   P R O G R A M M E   P R I N C I P A L                   *)\r
1024 (*                                                                           *)\r
1025 (*****************************************************************************)\r
1026 (*****************************************************************************)\r
1027 var colorf,colore : integer;\r
1028 var nbitem : integer;\r
1029 var espace : integer;\r
1030 var item   : arrayof string;\r
1031 var nbbot  : integer;\r
1032 var flag   : boolean;\r
1033 var posy   : integer;\r
1034 var arbr   : Barbre;\r
1035 \r
1036 Begin\r
1037  pref iiuwgraph block\r
1038  begin\r
1039   pref mouse block\r
1040   begin\r
1041    arbr:=new Barbre(3);\r
1042    call gron(1);\r
1043    flag:=init(nbbot);\r
1044    call hpage(0,1,1);\r
1045    posy:=20;\r
1046    call maine;\r
1047    call hidecursor;\r
1048    call groff;\r
1049   end\r
1050  end\r
1051 End BArbres.\r