BLOCK
    const
	rouge=0,
	blanc=1;

    (* D‚finition classe CaractŠre *)
    unit caractere:class(x:char);
    end caractere;

    (* Function attendant qu'un caractŠre soit tap‚ au clavier *)
    (* et le renvoie *)
    unit saisie_car:function:integer;
    var a:integer;
    begin
	pref IIUWGRAPH block
	begin
	a:=0;
	while a=0 do
	    a:=inkey;
	od;
	result:=a;
	end;
    end saisie_car;

    (* D‚finition de la classe arbre_bicolore *)
    (* Paramˆtres : le type elem des ‚l‚ments utilis‚s *)
    (*                 fonction inf renvoyant vrai si e1<e2 *)
    (*                 fonction sup renvoyant vrai si e1>e2 *)
    (*                 fonction eg  renvoyant vrai si e1=e2 *)
    (*                 proc‚dure aff affichant e *)
    unit arbre_bicolore:class(type elem;
			      function inf(e1,e2:elem):boolean;
			      function sup(e1,e2:elem):boolean;
			      function eg(e1,e2:elem):boolean;
			      procedure aff(e:elem));

	(* D‚finition d'une cellule ou noeud *)
	unit cellule:class;
	var e:elem;
	var p,left,right:cellule;
	var color:integer;
	end cellule;

	(* D‚claration de la racine *)
	Var T:cellule;

	(* Procedure affichant les information contenues dans *)
	(* s, x et s2 en faisant une pause *)
	unit info:procedure(s:string;x:elem;s2:string);
	var i:integer;
	begin
	    pref IIUWGRAPH block
	    begin
		call color(15);
		call move(10,200);
		call outstring("                                                                   ");
		call move(10,200);
		call outstring(s);
		call aff(x);
		call outstring(s2);
				call move(10,220);
		call outstring("<Enter>");
				i:=0;
			while (i<>13) do
		i:=inkey;
			od;
				call move(10,220);
		    call outstring("       ");
			end;
	end info;

	(* Fonction ajoutant un nouvel ‚l‚ment dans l'arbre … la fa‡on *)
	(* d'un bst, elle renvoie la cellule qui a ‚t‚ cr‚e et rajout‚e*)
	unit recursive_ajout:function(e:elem;inout r,p:cellule):cellule;
	var a:cellule;
	begin
	    if r=none then
		a:=new cellule;
		a.e:=e;
		a.p:=p;
		r:=a;
		result:=r;
	    else
		if inf(e,r.e) then
		    result:=recursive_ajout(e,r.left,r);
		else if sup(e,r.e) then
			result:=recursive_ajout(e,r.right,r);
		     fi
		fi;
	    fi;
	end recursive_ajout;

	(* Cette fonction apelle la proc‚dure r‚cursive "recursive_ajout"*)
	unit insere_bst:function(x:elem):cellule;
	var none_p:cellule;
	begin
	    none_p:=none;
	    result:=recursive_ajout(x,T,none_p);
	end insere_bst;

	(* Procedure effectuant une rotation … gauche sur la cellule c *)
	unit left_rotate:procedure(c:cellule);
	var y:cellule;
	begin
	    y:=c.right;
	    c.right:=y.left;
	    if y.left<>none then
		y.left.p:=c;
	    fi;
	    y.p:=c.p;
	    if c.p=none then
		T:=y;
	    else
		if c=c.p.left then
		    c.p.left:=y;
		else
		    c.p.right:=y;
		fi;
	    fi;
	    y.left:=c;
	    c.p:=y;
	end left_rotate;

	(* Procedure effectuant une rotation … droite sur la cellule c *)
	unit right_rotate:procedure(c:cellule);
	var y:cellule;
	begin
	    y:=c.left;
	    c.left:=y.right;
	    if y.right<>none then
		y.right.p:=c;
	    fi;
	    y.p:=c.p;
	    if c.p=none then
		T:=y;
	    else
		if c=c.p.right then
		    c.p.right:=y;
		else
		    c.p.left:=y;
		fi;
	    fi;
	    y.right:=c;
	    c.p:=y;
	end right_rotate;

	(* Proc‚dure ins‚rant un nouvel ‚l‚ment x dans l'arbre bicolore *)
	unit insert:procedure(x:elem);
	var y,c:cellule,ok:boolean;
	var i:integer;
	var E:cellule;
	begin
	    e:=new cellule;
	    pref IIUWGRAPH block
	    begin
	    (* insersion dans l'arbre et affichage *)
	    c:=insere_bst(x);
	    if c<>none then c.color:=rouge;fi;
	    call parcours;
	    if c<>none then
		call info("Ajout en rouge de l'‚l‚ment ",c.e," dans le BST-arbre ");
	    fi;

	    (* Retraitement de l'arbre si un nouvel ‚l‚ment a ‚t‚ cr‚‚ *)
	    if c<>none then
		if c=t then ok:=false
		else ok:=c.p.color=rouge;
		fi;

		(* on teste les ‚l‚ments de la feuille ajout‚e *)
		(* Jusqu'… la racine *)
		while (c<>T) and (ok)
		do
		    if (c.p=c.p.p.left) then
			y:=c.p.p.right;
			(* Echange des couleurs si un noeud a deux fils rouges *)
			if (y<>none) andif (y.color=rouge) then
			    c.p.color:=blanc;
			    y.color:=blanc;
			    c.p.p.color:=rouge;
			    c:=c.p.p;
			    call parcours;
			    if c<>none then
				call info("Echanges de couleurs entre ",c.e," et ses fils");
			    fi;
			else
			    (* Rotation si un noeud rouge a un fils rouge *)
			    if (c=c.p.right) then
				c:=c.p;
				E.e:=c.e;
				call info("Rotation gauche sur ",e.e,". ");
				call left_rotate(c);
				call cls;
				call parcours;
				call info("Rotation gauche sur ",e.e,"effectu‚e. ");
			    fi;
			    c.p.color:=blanc;
			    c.p.p.color:=rouge;
			    e.e:=c.p.p.e;
			    call info("Rotation droite sur ",e.e,".");
			    call right_rotate(c.p.p);
			    call cls;
			    call parcours;
			    call info("Rotation droite sur ",e.e," effectu‚e.");
			fi;
		    else
			y:=c.p.p.left;
			(* Echange des couleurs si un noeud a deux fils rouges *)
			if (y<>none) andif (y.color=rouge) then
			    c.p.color:=blanc;
			    y.color:=blanc;
			    c.p.p.color:=rouge;
			    c:=c.p.p;
			    if c<>none then
				call info("Echange de couleurs entre ",c.e," et ses fils ");
			    fi;
			    call parcours;
			else
			    (* Rotation si un noeud rouge a un fils rouge *)
			    if (c=c.p.left) then
				c:=c.p;
				e.e:=c.e;
				call info("Rotation droite sur ",e.e," .");
				call right_rotate(c);
				call cls;
				call parcours;
				call info("Rotation droite sur ",e.e," effectu‚e.");
			    fi;
			    c.p.color:=blanc;
			    c.p.p.color:=rouge;
			    e.e:=c.p.p.e;
			    call info("Rotation gauche sur ",e.e,".");
			    call left_rotate(c.p.p);
			    call cls;
			    call parcours;
			    call info("Rotation gauche sur ",e.e," effectu‚e.");
			fi;
		    fi;
		    if c=t then ok:=false;
		    else ok:=c.p.color=rouge;
		    fi;
		od;
	    fi;

	    (* La racine est toujours blanche *)
	    T.color:=blanc;
	    end;
	    kill(e);
	end insert;


	(* Proc‚dure r‚cursive de parcours et d'affichage *)
	(* de l'arbre … l'‚cran *)
	(* paramŠtres  r:cellule en cours de traitement *)
	(*             x2,y2 : coordonn‚es du pr‚c‚dent noeud *)
	(*             x,y   : coordonn‚es du nouveau noeud *)
	(*             dx : ‚cartement actuel des branches *)
	unit rec_par:procedure(r:cellule;x2,y2,x,y,dx:integer);
	var coul:integer;
	begin
	    pref IIUWGRAPH block
	    begin
	    if r.left<>none then
		call rec_par(r.left,x-5,y,x-dx,y+30,dx div 2);
	    fi;

	    (* affichage de la branche *)
	    call color(8);
	    call move(x2,y2);
	    call draw(x,y);
	    if r.color=rouge then coul:=4;
	    else coul:=15;
	    fi;

	    (* affichage du noeud *)
	    call style(0);
	    call cirb(x+3,y+3,10,0,0,coul,1,1,1);
	    call style(1);
	    call color(coul);
	    call move(x,y);
	    call aff(r.e);
	    if r.right <>none then
		call rec_par(r.right,x+11,y,x+dx,y+30,dx div 2);
	    fi;
	    end;
	end rec_par;

	(* Proc‚dure amor‡ant le parcours *)
	unit parcours:procedure;
	begin
	    if T<>none then call rec_par(T,320,10,320,10,160);fi;
	end parcours;

	(* Function recherchant dans l'arbre l'‚l‚ment x *)
	(* a partir du noeud noeud et renvoyant la cellule correspondante *)
	unit recherche:procedure(x:elem;noeud:cellule;output c:cellule);
	begin
	    if inf(x,noeud.e) andif (noeud.left<>none) then
		call recherche(x,noeud.left,c)
	    else
		if sup(x,noeud.e) andif (noeud.right<>none) then
		    call recherche(x,noeud.right,c)
		else
		    if eg(x,noeud.e) then c:=noeud;
		    fi;
		fi;
	    fi;
	end recherche;

	(* Proc‚dure mettant … jour l'arbre de fa‡on … ce que toutes les *)
	(* propri‚t‚s des arbres bicolores soient respect‚es aprŠs une *)
	(* suppression d'un ‚l‚ment *)
	unit delete_fixup:procedure (x:cellule);
	var e,w:cellule;
	var ok,test1,test2,cree:boolean;
	var i:integer;
	begin
	    pref IIUWGRAPH block
	    begin
	    e:=new cellule;
	    if x=none then ok:=false;
	    else ok:=x.color=blanc;
	    fi;

	    (* on part de la cellule supprim‚e jusqu'… la racine *)
	    (* on teste s'il n'y a pas deux noeuds rouges … la suite *)
	    (* sinon on fait des rotations ... *)
	    while (x<>T) and (ok)
	    do
		if (x=x.p.left) then
		    w:=x.p.right;
		    if w=none then
			cree:=true;
			w:=new cellule;
			w.color:=blanc;
						w.p:=x.p;
						x.p.right:=w;
		    else cree:=false;
		    fi;
	
		    if (w<>none) andif (w.color=rouge) then
			w.color:=blanc;
			x.p.color:=rouge;
			e.e:=x.p.e;
			call info("Rotation gauche sur ",e.e,".");
			call left_rotate(x.p);
			call cls;
			call parcours;
			call info("Rotation gauche sur ",e.e," effectu‚e.");
			w:=x.p.right;
		    fi;
		    if (w.left=none) orif (w.left.color=blanc)
			then test1:=true;
		    else test1:=false;
		    fi;
		    if (w.right=none) orif (w.right.color=blanc)
			then test2:=true;
		    else test2:=false;
		    fi;
		    if (test1) and (test2) then
			w.color:=rouge;
			x:=x.p;
		    else
			if (w.right=none) orif (w.right.color=blanc) then
			    w.left.color:=blanc;
			    w.color:=rouge;
			    e.e:=w.e;
			    call info("Rotation droite sur ",e.e,".");
			    call right_rotate(w);
			    call cls;
			    call parcours;
			    call info("Rotation droite sur ",e.e," effectu‚e.");
			    w:=x.p.right;
			fi;
			w.color:=x.p.color;
			x.p.color:=blanc;
			w.right.color:=blanc;
			e.e:=x.p.e;
			call info("Rotation gauche sur ",e.e,".");
			call left_rotate(x.p);
			call cls;
			call parcours;
			call info("Rotation gauche sur ",e.e," effectu‚e.");
			x:=T;
		    fi;
		    if cree then
			kill(w);
		    fi;
		else
		    w:=x.p.left;
		    if w=none then
			w:=new cellule;
			w.color:=blanc;
						w.p:=x.p;
						x.p.left:=w;
			cree:=true;
		    else cree:=false;
		    fi;
					call parcours;
		    if (w<>none) andif (w.color=rouge) then
			w.color:=blanc;
			x.p.color:=rouge;
			e.e:=x.p.e;
			call info("Rotation droite sur ",e.e,".");
			call right_rotate(x.p);
			call cls;
			call parcours;
			call info("Rotation droite sur ",e.e," effectu‚e.");
			w:=x.p.left;
		    fi;
		    if (w.right=none) orif (w.right.color=blanc) then
			test1:=true;
		    else test1:=false;
		    fi;
		    if (w.left=none) orif (w.left.color=blanc) then
			test2:=true;
		    else test2:=false;
		    fi;
		    if (test1) and (test2) then
			w.color:=rouge;
			x:=x.p;
		    else
			if (w.left=none) orif (w.left.color=blanc) then
			    w.right.color:=blanc;
			    w.color:=rouge;
			    e.e:=w.e;
			    call info("Rotation gauche sur ",e.e,".");
			    call left_rotate(w);
			    call cls;
			    call parcours;
			    call info("Rotation gauche sur ",e.e," effectu‚e.");
			    w:=x.p.left;
			fi;
			w.color:=x.p.color;
			x.p.color:=blanc;
			w.left.color:=blanc;
			e.e:=x.p.e;
			call info("Rotation droite sur ",e.e,".");
			call right_rotate(x.p);
			call cls;
			call parcours;
			call info("Rotation droite sur ",e.e," effectu‚e.");
			x:=T;
		    fi;
		    if (cree) then
			kill(w);
		    fi;
		fi;
		if x=none then ok:=false;
		else ok:=x.color=blanc;
		fi;
	    od;
	    if x<>none then
		(* racine blanche *)
		x.color:=blanc;
	    fi;
	    call parcours;
	    call move(10,200);
	    call color(15);
	    call outstring("Mise … jour de l'arbre effectu‚e. ");
	    for i:=1 to 4000 do;od;
	    kill(e);
	    end;
	end delete_fixup;

	(* Fonction renvoyant le succ‚sseur d'une cellule … supprimer *)
	(* c'est … dire, le plus grand ‚l‚ment du sous-arbre gauche,  *)
	(* ou le plus petit ‚l‚ment du sous-arbre droit *)
	unit tree_suc:function(c:cellule):cellule;
	var r:cellule;
	begin
	    if (c.left<>none) then
		r:=c.left;
		while r.right<>none
		do
		    r:=r.right;
		od;
	    else
		if (c.right<>none) then
		    r:=c.right;
		    while r.left<>none
		    do
			r:=r.left
		    od;
		fi;
	    fi;
	    result:=r;
	end tree_suc;

	(* Proc‚dure supprimant un ‚l‚ment dans l'arbre *)
	unit delete:procedure(e:elem);
	var c,x,y,k:cellule;
	var cree:integer;
	begin
	    k:=new cellule;
	    pref IIUWGRAPH block
	    begin
	    (* Recherche de l'‚l‚ment *)
	    if T<>none then call recherche(e,T,c);fi;
	    (* Recherche de l'‚l‚ment le rempla‡ant *)
	    if c<>none then
		if c.left=none or c.right=none then
		    y:=c;
		    kill(k);
		else
		    y:=tree_suc(c);
		    k.e:=y.e;
		fi;

		(* Remplacement *)
		call info("Suppression et remplacement de ",c.e,".");
		if y.left<>none then
		    x:=y.left;
		else
		    x:=y.right;
		    if x=none then
			x:=new cellule;
			y.right:=x;
						x.color:=blanc;
			cree:=1;
		    else
			cree:=0;
		    fi;
		fi;
		x.p:=y.p;

		if y.p=none then
		    T:=x;
		else
		    if y=y.p.left then
			y.p.left:=x;
		    else
			y.p.right:=x;
		    fi;
		fi;
		if y<>c then
		    c.e:=y.e;
		fi;
		call cls;
		call parcours;
		if k<>none then
		    call info("Suppression et remplacement par ",k.e," effectu‚e.");
		    kill(k);
		else
		    call info("Suppression de ",y.e," effectu‚e .");
		fi;
		(* mise … jour de l'arbre *)
		if y.color=blanc then
		    call delete_fixup(x);
		fi;
		if (cree=1) then
					if (x.p<>none) andif (x=x.p.left) then
						x.p.left:=none;
					else
						if (x.p<>none) andif (x=x.p.right) then
							x.p.right:=none;
						else
							if (x.p=none) then
								T:=none;
			    fi;
						fi;
					fi;
		fi;
	    fi;
	    end;
	end delete;

    end arbre_bicolore;

    (* Indique si x=y *)
    unit eg:function(x,y:caractere):boolean;
    begin
	result:=ord(x.x)=ord(y.x);
    end eg;

    (* Indique si x<y *)
    unit inf:function(x,y:caractere):boolean;
    begin
	result:=ord(x.x)<ord(y.x);
    end inf;

    (* Indique si x>y *)
    unit sup:function(x,y:caractere):boolean;
    begin
	result:=ord(x.x)>ord(y.x);
    end sup;

    (* affiche le caractŠre a *)
    unit aff:procedure(a:caractere);
    begin
	pref IIUWGRAPH block
	begin
	    if a<>none then
		    Call HASCII(ord(a.x));
			fi;
	end;
    end aff;

    (* d‚claration des variables *)
    var a_b:arbre_bicolore;
    var a:caractere;
    var e:char;
    var op:integer;
begin
    pref IIUWGRAPH block
    begin
    (* initialisation graphique *)
    call gron(5);

    (* Cr‚ation d'un arbre *)
    a_b:=new arbre_bicolore(caractere,inf,sup,eg,aff);

    (* menu principal *)
    op:=0;
    while (op<>ord('q')) do
	call color(15);
	call move(10,270);
	call outstring("Ajouter un noeud .... A");
	call move(10,280);
	call outstring("Supprimer un noeud .. S");
	call move(10,290);
	call outstring("Quitter ............. Q");
	call move(10,300);
	call outstring("                                                               ");

	(* Saisie de l'op‚ration *)
	op:=0;
	while (op<>ord('q')) and (op<>ord('s')) and (op<>ord('a')) do
	    op:=inkey;
	    if (op<=ord('Z')) then op:=op+ord('a')-ord('A');fi;
	od;

	(* Saisie et ajout d'un ‚l‚ment *)
	if (op=ord('a')) then
	    call color(15);
	    call move(10,300);
	    call outstring("Tapez l'‚l‚ment … ajouter (Escape pour finir) :");
	    e:=chr(saisie_car);
	    while e<>chr(27) do
		call move(400,300);
		a:=new caractere(e);
		call aff(a);
		call a_b.insert(a);
		call cls;
		call a_b.parcours;
		call color(15);
		call move(10,300);
		call outstring("Tapez l'‚l‚ment … ajouter (Escape pour finir) :");
		e:=chr(saisie_car);
	   od;
	else
	    (* Saisie et Suppression d'un ‚l‚ment *)
	    if (op=ord('s')) then
	    call color(15);
	    call move(10,300);
	    call outstring("Tapez l'‚l‚ment … supprimer (Escape pour finir) :");
	    e:=chr(saisie_car);
	    while e<>chr(27) do
		a:=new caractere(e);
		call a_b.delete(a);
		call cls;
		call a_b.parcours;
		call color(15);
		call move(10,300);
		call outstring("Tapez l'‚l‚ment … supprimer (Escape pour finir) :");
		e:=chr(saisie_car);
	    od;
	    fi;
	fi;
    od;
    call groff;
    end;
end;