6 (* D
\82finition classe Caract
\8are *)
\r
7 unit caractere:class(x:char);
\r
10 (* Function attendant qu'un caract
\8are soit tap
\82 au clavier *)
\r
12 unit saisie_car:function:integer;
\r
15 pref IIUWGRAPH block
\r
25 (* D
\82finition de la classe arbre_bicolore *)
\r
26 (* Param
\88tres : le type elem des
\82l
\82ments utilis
\82s *)
\r
27 (* fonction inf renvoyant vrai si e1<e2 *)
\r
28 (* fonction sup renvoyant vrai si e1>e2 *)
\r
29 (* fonction eg renvoyant vrai si e1=e2 *)
\r
30 (* proc
\82dure aff affichant e *)
\r
31 unit arbre_bicolore:class(type elem;
\r
32 function inf(e1,e2:elem):boolean;
\r
33 function sup(e1,e2:elem):boolean;
\r
34 function eg(e1,e2:elem):boolean;
\r
35 procedure aff(e:elem));
\r
37 (* D
\82finition d'une cellule ou noeud *)
\r
40 var p,left,right:cellule;
\r
44 (* D
\82claration de la racine *)
\r
47 (* Procedure affichant les information contenues dans *)
\r
48 (* s, x et s2 en faisant une pause *)
\r
49 unit info:procedure(s:string;x:elem;s2:string);
\r
52 pref IIUWGRAPH block
\r
56 call outstring(" ");
\r
62 call outstring("<Enter>");
\r
68 call outstring(" ");
\r
72 (* Fonction ajoutant un nouvel
\82l
\82ment dans l'arbre
\85 la fa
\87on *)
\r
73 (* d'un bst, elle renvoie la cellule qui a
\82t
\82 cr
\82e et rajout
\82e*)
\r
74 unit recursive_ajout:function(e:elem;inout r,p:cellule):cellule;
\r
85 result:=recursive_ajout(e,r.left,r);
\r
86 else if sup(e,r.e) then
\r
87 result:=recursive_ajout(e,r.right,r);
\r
91 end recursive_ajout;
\r
93 (* Cette fonction apelle la proc
\82dure r
\82cursive "recursive_ajout"*)
\r
94 unit insere_bst:function(x:elem):cellule;
\r
98 result:=recursive_ajout(x,T,none_p);
\r
101 (* Procedure effectuant une rotation
\85 gauche sur la cellule c *)
\r
102 unit left_rotate:procedure(c:cellule);
\r
107 if y.left<>none then
\r
124 (* Procedure effectuant une rotation
\85 droite sur la cellule c *)
\r
125 unit right_rotate:procedure(c:cellule);
\r
130 if y.right<>none then
\r
137 if c=c.p.right then
\r
147 (* Proc
\82dure ins
\82rant un nouvel
\82l
\82ment x dans l'arbre bicolore *)
\r
148 unit insert:procedure(x:elem);
\r
149 var y,c:cellule,ok:boolean;
\r
154 pref IIUWGRAPH block
\r
156 (* insersion dans l'arbre et affichage *)
\r
158 if c<>none then c.color:=rouge;fi;
\r
161 call info("Ajout en rouge de l'
\82l
\82ment ",c.e," dans le BST-arbre ");
\r
164 (* Retraitement de l'arbre si un nouvel
\82l
\82ment a
\82t
\82 cr
\82\82 *)
\r
166 if c=t then ok:=false
\r
167 else ok:=c.p.color=rouge;
\r
170 (* on teste les
\82l
\82ments de la feuille ajout
\82e *)
\r
171 (* Jusqu'
\85 la racine *)
\r
172 while (c<>T) and (ok)
\r
174 if (c.p=c.p.p.left) then
\r
176 (* Echange des couleurs si un noeud a deux fils rouges *)
\r
177 if (y<>none) andif (y.color=rouge) then
\r
180 c.p.p.color:=rouge;
\r
184 call info("Echanges de couleurs entre ",c.e," et ses fils");
\r
187 (* Rotation si un noeud rouge a un fils rouge *)
\r
188 if (c=c.p.right) then
\r
191 call info("Rotation gauche sur ",e.e,". ");
\r
192 call left_rotate(c);
\r
195 call info("Rotation gauche sur ",e.e,"effectu
\82e. ");
\r
198 c.p.p.color:=rouge;
\r
200 call info("Rotation droite sur ",e.e,".");
\r
201 call right_rotate(c.p.p);
\r
204 call info("Rotation droite sur ",e.e," effectu
\82e.");
\r
208 (* Echange des couleurs si un noeud a deux fils rouges *)
\r
209 if (y<>none) andif (y.color=rouge) then
\r
212 c.p.p.color:=rouge;
\r
215 call info("Echange de couleurs entre ",c.e," et ses fils ");
\r
219 (* Rotation si un noeud rouge a un fils rouge *)
\r
220 if (c=c.p.left) then
\r
223 call info("Rotation droite sur ",e.e," .");
\r
224 call right_rotate(c);
\r
227 call info("Rotation droite sur ",e.e," effectu
\82e.");
\r
230 c.p.p.color:=rouge;
\r
232 call info("Rotation gauche sur ",e.e,".");
\r
233 call left_rotate(c.p.p);
\r
236 call info("Rotation gauche sur ",e.e," effectu
\82e.");
\r
239 if c=t then ok:=false;
\r
240 else ok:=c.p.color=rouge;
\r
245 (* La racine est toujours blanche *)
\r
252 (* Proc
\82dure r
\82cursive de parcours et d'affichage *)
\r
253 (* de l'arbre
\85 l'
\82cran *)
\r
254 (* param
\8atres r:cellule en cours de traitement *)
\r
255 (* x2,y2 : coordonn
\82es du pr
\82c
\82dent noeud *)
\r
256 (* x,y : coordonn
\82es du nouveau noeud *)
\r
257 (* dx :
\82cartement actuel des branches *)
\r
258 unit rec_par:procedure(r:cellule;x2,y2,x,y,dx:integer);
\r
261 pref IIUWGRAPH block
\r
263 if r.left<>none then
\r
264 call rec_par(r.left,x-5,y,x-dx,y+30,dx div 2);
\r
267 (* affichage de la branche *)
\r
271 if r.color=rouge then coul:=4;
\r
275 (* affichage du noeud *)
\r
277 call cirb(x+3,y+3,10,0,0,coul,1,1,1);
\r
282 if r.right <>none then
\r
283 call rec_par(r.right,x+11,y,x+dx,y+30,dx div 2);
\r
288 (* Proc
\82dure amor
\87ant le parcours *)
\r
289 unit parcours:procedure;
\r
291 if T<>none then call rec_par(T,320,10,320,10,160);fi;
\r
294 (* Function recherchant dans l'arbre l'
\82l
\82ment x *)
\r
295 (* a partir du noeud noeud et renvoyant la cellule correspondante *)
\r
296 unit recherche:procedure(x:elem;noeud:cellule;output c:cellule);
\r
298 if inf(x,noeud.e) andif (noeud.left<>none) then
\r
299 call recherche(x,noeud.left,c)
\r
301 if sup(x,noeud.e) andif (noeud.right<>none) then
\r
302 call recherche(x,noeud.right,c)
\r
304 if eg(x,noeud.e) then c:=noeud;
\r
310 (* Proc
\82dure mettant
\85 jour l'arbre de fa
\87on
\85 ce que toutes les *)
\r
311 (* propri
\82t
\82s des arbres bicolores soient respect
\82es apr
\8as une *)
\r
312 (* suppression d'un
\82l
\82ment *)
\r
313 unit delete_fixup:procedure (x:cellule);
\r
315 var ok,test1,test2,cree:boolean;
\r
318 pref IIUWGRAPH block
\r
321 if x=none then ok:=false;
\r
322 else ok:=x.color=blanc;
\r
325 (* on part de la cellule supprim
\82e jusqu'
\85 la racine *)
\r
326 (* on teste s'il n'y a pas deux noeuds rouges
\85 la suite *)
\r
327 (* sinon on fait des rotations ... *)
\r
328 while (x<>T) and (ok)
\r
330 if (x=x.p.left) then
\r
341 if (w<>none) andif (w.color=rouge) then
\r
345 call info("Rotation gauche sur ",e.e,".");
\r
346 call left_rotate(x.p);
\r
349 call info("Rotation gauche sur ",e.e," effectu
\82e.");
\r
352 if (w.left=none) orif (w.left.color=blanc)
\r
356 if (w.right=none) orif (w.right.color=blanc)
\r
360 if (test1) and (test2) then
\r
364 if (w.right=none) orif (w.right.color=blanc) then
\r
365 w.left.color:=blanc;
\r
368 call info("Rotation droite sur ",e.e,".");
\r
369 call right_rotate(w);
\r
372 call info("Rotation droite sur ",e.e," effectu
\82e.");
\r
375 w.color:=x.p.color;
\r
377 w.right.color:=blanc;
\r
379 call info("Rotation gauche sur ",e.e,".");
\r
380 call left_rotate(x.p);
\r
383 call info("Rotation gauche sur ",e.e," effectu
\82e.");
\r
400 if (w<>none) andif (w.color=rouge) then
\r
404 call info("Rotation droite sur ",e.e,".");
\r
405 call right_rotate(x.p);
\r
408 call info("Rotation droite sur ",e.e," effectu
\82e.");
\r
411 if (w.right=none) orif (w.right.color=blanc) then
\r
415 if (w.left=none) orif (w.left.color=blanc) then
\r
419 if (test1) and (test2) then
\r
423 if (w.left=none) orif (w.left.color=blanc) then
\r
424 w.right.color:=blanc;
\r
427 call info("Rotation gauche sur ",e.e,".");
\r
428 call left_rotate(w);
\r
431 call info("Rotation gauche sur ",e.e," effectu
\82e.");
\r
434 w.color:=x.p.color;
\r
436 w.left.color:=blanc;
\r
438 call info("Rotation droite sur ",e.e,".");
\r
439 call right_rotate(x.p);
\r
442 call info("Rotation droite sur ",e.e," effectu
\82e.");
\r
449 if x=none then ok:=false;
\r
450 else ok:=x.color=blanc;
\r
454 (* racine blanche *)
\r
460 call outstring("Mise
\85 jour de l'arbre effectu
\82e. ");
\r
461 for i:=1 to 4000 do;od;
\r
466 (* Fonction renvoyant le succ
\82sseur d'une cellule
\85 supprimer *)
\r
467 (* c'est
\85 dire, le plus grand
\82l
\82ment du sous-arbre gauche, *)
\r
468 (* ou le plus petit
\82l
\82ment du sous-arbre droit *)
\r
469 unit tree_suc:function(c:cellule):cellule;
\r
472 if (c.left<>none) then
\r
474 while r.right<>none
\r
479 if (c.right<>none) then
\r
490 (* Proc
\82dure supprimant un
\82l
\82ment dans l'arbre *)
\r
491 unit delete:procedure(e:elem);
\r
492 var c,x,y,k:cellule;
\r
496 pref IIUWGRAPH block
\r
498 (* Recherche de l'
\82l
\82ment *)
\r
499 if T<>none then call recherche(e,T,c);fi;
\r
500 (* Recherche de l'
\82l
\82ment le rempla
\87ant *)
\r
502 if c.left=none or c.right=none then
\r
511 call info("Suppression et remplacement de ",c.e,".");
\r
512 if y.left<>none then
\r
542 call info("Suppression et remplacement par ",k.e," effectu
\82e.");
\r
545 call info("Suppression de ",y.e," effectu
\82e .");
\r
547 (* mise
\85 jour de l'arbre *)
\r
548 if y.color=blanc then
\r
549 call delete_fixup(x);
\r
552 if (x.p<>none) andif (x=x.p.left) then
\r
555 if (x.p<>none) andif (x=x.p.right) then
\r
568 end arbre_bicolore;
\r
570 (* Indique si x=y *)
\r
571 unit eg:function(x,y:caractere):boolean;
\r
573 result:=ord(x.x)=ord(y.x);
\r
576 (* Indique si x<y *)
\r
577 unit inf:function(x,y:caractere):boolean;
\r
579 result:=ord(x.x)<ord(y.x);
\r
582 (* Indique si x>y *)
\r
583 unit sup:function(x,y:caractere):boolean;
\r
585 result:=ord(x.x)>ord(y.x);
\r
588 (* affiche le caract
\8are a *)
\r
589 unit aff:procedure(a:caractere);
\r
591 pref IIUWGRAPH block
\r
594 Call HASCII(ord(a.x));
\r
599 (* d
\82claration des variables *)
\r
600 var a_b:arbre_bicolore;
\r
605 pref IIUWGRAPH block
\r
607 (* initialisation graphique *)
\r
610 (* Cr
\82ation d'un arbre *)
\r
611 a_b:=new arbre_bicolore(caractere,inf,sup,eg,aff);
\r
613 (* menu principal *)
\r
615 while (op<>ord('q')) do
\r
618 call outstring("Ajouter un noeud .... A");
\r
620 call outstring("Supprimer un noeud .. S");
\r
622 call outstring("Quitter ............. Q");
\r
624 call outstring(" ");
\r
626 (* Saisie de l'op
\82ration *)
\r
628 while (op<>ord('q')) and (op<>ord('s')) and (op<>ord('a')) do
\r
630 if (op<=ord('Z')) then op:=op+ord('a')-ord('A');fi;
\r
633 (* Saisie et ajout d'un
\82l
\82ment *)
\r
634 if (op=ord('a')) then
\r
637 call outstring("Tapez l'
\82l
\82ment
\85 ajouter (Escape pour finir) :");
\r
638 e:=chr(saisie_car);
\r
639 while e<>chr(27) do
\r
640 call move(400,300);
\r
641 a:=new caractere(e);
\r
643 call a_b.insert(a);
\r
648 call outstring("Tapez l'
\82l
\82ment
\85 ajouter (Escape pour finir) :");
\r
649 e:=chr(saisie_car);
\r
652 (* Saisie et Suppression d'un
\82l
\82ment *)
\r
653 if (op=ord('s')) then
\r
656 call outstring("Tapez l'
\82l
\82ment
\85 supprimer (Escape pour finir) :");
\r
657 e:=chr(saisie_car);
\r
658 while e<>chr(27) do
\r
659 a:=new caractere(e);
\r
660 call a_b.delete(a);
\r
665 call outstring("Tapez l'
\82l
\82ment
\85 supprimer (Escape pour finir) :");
\r
666 e:=chr(saisie_car);
\r