program myBarbres;

	unit presentation : procedure;
	begin
		pref IIUWgraph block
		begin
			call gron(1);
			call hpage(1,1,1);
			call border(5);
			call move(270,50);
			call color(5);
			call outstring("LES ARBRES 2-3");
			call move(80,100);
			call color(3);
			call outstring("MENU :");
			call move(100,125);
			call color(3);
			call outstring("1 -> inserer un element");
			call move(100,150);
			call outstring("2 -> supprimer un element");
			call move(100,175);
			call outstring("3 -> existence d'un element");
			call move(100,200);
			call outstring("4 -> minimum de l'arbre");
			call move(100,225);
			call outstring("5 -> maximum de l'arbre");
			call move(100,250);
			call outstring("6 -> vide");
			call move(100,275);
			call outstring("7 -> afficher l'arbre");
			call move(100,300);
			call outstring("8 -> fin");
			call move(100,325);
			call outstring("choix =");
		end;
	end presentation;

	unit inchar: iiuwgraph function:integer;
	var i:integer;
	begin
		do
			i:=inkey;
			if i=/=0 then exit fi;
		od;
		result:=i;
	end inchar;

	unit reponse : IIUWgraph procedure(output r : char);
	begin
		call move(250,325);
		call outstring("Tapez o/n pour continuer");
		r := chr(inchar);
		call hascii(0);
		call hascii(ord(r));
	end reponse;   


	unit WriteInteger : IIUWgraph procedure( Number : integer );
	var i, j : integer;
	begin
	  if Number < 10 then
		 call HASCII( 0 );
		 call HASCII( Number + 48 );
		 call Hascii( 0 );
	  else
		 i := Number div 10;
		 j := Number - i * 10;
		 call HASCII( 0 );
		 call Hascii( i + 48 );
		 call Hascii( 0 );
		 call Hascii( j + 48 );
	  fi;
	end WriteInteger;


	(* representation d'un noeud *)
	unit noeud : class;
	var pere       : noeud,
		 nb         : integer,
		 IG, IM     : integer,
		 FG, FM, FD : noeud;
		 (* 
			 pere est le pere
			 nb est le nombre de fils
			 IG est l'information de gauche
			 IM est l'information de droite
			 FG est le fils de gauche
			 FM est le fils du milieu
			 FD est le fils de droite
		 *)
	begin
		(* initialisation des variables *)
		pere := none;
		nb := 0;
		IG := -1;
		IM := -1;
		FG := none;
		FM := none;
		FD := none;
	end noeud;



	unit barbre : class;
	var racine : noeud;

		unit afficher : procedure(inout courant : noeud);
		begin
			if courant.IM = -1
			then
				(* courant pointe sur une feuille *)
				writeln(courant.IG:1);
			else
				(* courant pointe sur un noeud *)
				writeln(courant.IG:1, ":", courant.IM:1);
			fi;
			
			if courant.FG =/= none
			then
				(* courant a 1, 2 ou 3 fils *)   
				if courant.FG.FG =/= none
				then
					(* courant a 2 ou 3 petits fils *)
					(* appel de la procedure afficher avec le fils gauche de courant *)
					call afficher(courant.FG);
					if courant.FM =/= none
					then
						(* courant a 2 ou 3 fils *)
						(* appel de la procedure afficher avec le fils milieu de courant *)
						call afficher(courant.FM);
						if courant.FD =/= none
						then
							(* courant a 3 fils *)
							(* appel de la procedure afficher avec le fils droit de courant *)
							call afficher(courant.FD);
						fi;
					fi;
				else
					(* courant n'a pas de petits fils 
						i.e. les fils de courant sont des feuilles *)
					(* affichage de la feuille de gauche *)
					write(courant.FG.IG:1);
					if courant.FM =/= none
					then
						(* courant a 2 ou 3 fils *)
						(* affichage de la feuille du milieu *)
						write(" ", courant.FM.IG:1);
						if courant.FD =/= none
						then
							(* courant a 3 fils *)
							(* affichage de la feuille de droite *)
							writeln(" ", courant.FD.IG:1);
						else
							writeln;
						fi;
					else
						writeln;
					fi;
				fi;
			fi;
		end;

		unit reorganiser : procedure(inout courant,bidon : noeud);
		begin
					if courant.FG =/= none
					then
						(* courant a 1, 2 ou 3 fils *)
						if courant.FG.FG =/= none
						then
							(* courant a 2 ou 3 petits fils *)
							(* appel de la procedure reorganiser avec le fils gauche *)
							call reorganiser(courant.FG, bidon);
							(* appel de la procedure reorganiser avec le fils milieu *)
							call reorganiser(courant.FM, bidon);
							if courant.FD =/= none
							then
								(* courant a 3 fils *)
								(* appel de la procedure reorganiser avec le fils droit *)
								call reorganiser(courant.FD, bidon);
							fi;

							(* recherche du plus grand element dans le sous arbre 
							gauche de courant pour recuperer le IG de courant *)
							bidon := courant.FG;
							do
								case bidon.nb
									when 0 : courant.IG := bidon.IG;
												exit;
									when 1 : bidon := bidon.FG;

									when 2 : bidon := bidon.FM;

									when 3 : bidon := bidon.FD;
								esac;
							od;
							
							(* recherche du plus grand element dans le sous arbre 
							du milieu de courant pour recuperer le IM de courant *)
							bidon := courant.FM;
							do
								case bidon.nb
									when 0 : courant.IM := bidon.IG;
												exit;
									when 1 : bidon := bidon.FG;

									when 2 : bidon := bidon.FM;

									when 3 : bidon := bidon.FD;
								esac;
							od;
						else
							(* courant n'a pas de petis fils *)
							(* recuperation de IG pour courant *)
							courant.IG := courant.FG.IG;
							if courant.nb =/= 1
							then
								(* recuperation de IM pour courant *)
								(* courant a 2 ou 3 fils *)
								courant.IM := courant.FM.IG;
							fi;
						fi;
					fi;
				end reorganiser;

		unit vide : function : boolean;
		begin
			result := (racine.nb = 0);
		end vide;

		unit minimum : function : integer;
		var courant : noeud;
		begin
			courant := racine;
			do
				if courant.FG = none
				then
					(* result contient le plus petit element de l'arbre *)
					result := courant.IG;
					exit;
				else
					(* descendre a gauche *)
					courant := courant.FG;
				fi;
			od;
		end minimum;

		unit maximum : function : integer;
		var courant : noeud;
		begin
			courant := racine;
			do
				(* suivant le nombre de fils de courant *)
				case courant.nb
					when 0 : (* result contient le plus grand element de l'arbre *)
								result := courant.IG;
								exit;
					when 1 : (* le plus grand element se trouve 
								dans le sous arbre de gauche *)
								courant := courant.FG;

					when 2 : (* le plus grand element se trouve
								dans le sous arbre du milieu *)
								courant := courant.FM;

					when 3 : (* le plus grand element se trouve
								dans le sous arbre de droite *)
								courant := courant.FD;
				esac;
			od;
		end maximum;
	 
		unit present : function(v : integer; inout courant : noeud) : boolean;
		begin
			do
				(* suivant le nombre de fils de courant *)
				case courant.nb
					when 0 : (* 0 fils donc c'est une feuille *)
								if courant.IG = v
								then result := true;
								else result := false;
								fi;
								exit;
					when 1 : (* 1 fils donc le pere est la racine *)
								courant := courant.FG;
								if courant.IG = v
								then result := true;
								else result := false;
								fi;
								exit;
					when 2 : (* 2 fils *)
								if courant.IG > v
								then
									(* v se trouve a gauche, si il existe *) 
									courant := courant.FG;
								else
									if courant.IG = v
									then
										if courant.nb =/= 0
										then
											courant := courant.FG;
										fi;
									else
										(* v ne se trouve pas a gauche, si il existe *)
										if courant.IM > v
										then
											(* v se trouve au milieu, si il existe *)
											courant := courant.FM;
										else
											if courant.IM = v
											then
												if courant.nb =/= 0
												then
													courant := courant.FM;
												fi;
											else
												courant := courant.FM;
											fi;
										fi;
									fi;
								fi;
					when 3 : (* 3 fils *)
								if courant.IG > v
								then
									(* v se trouve a gauche, si il existe *)
									courant := courant.FG;
								else
									if courant.IG = v
									then
										if courant.nb =/= 0
										then
											courant := courant.FG;
										fi;
									else                            
										(* v ne se trouve pas a gauche, si il existe *)
										if courant.IM > v
										then
											(* v se trouve au milieu, si il existe *)
											courant := courant.FM;
										else
											if courant.IM = v
											then
												if courant.nb =/= 0
												then
													courant := courant.FM;
												fi;
											else
												(* v ne se trouve pas a gauche, si il existe *)
												if courant.IM < v
												then 
													(* v se trouve a droite, si il existe *)
													courant := courant.FD;
												fi;
											fi;
										fi;
									fi;
								fi;
				esac;
			od;
		end present;





		unit supprimer : IIUWgraph function(v: integer) : barbre;
		var courant, p : noeud,
			 b : barbre;
		begin
			b := new barbre;
			courant := racine;
			if present(v, courant)
			then
				(* l'element est present dans l'arbre donc on peut le supprimer *)
				p := courant.pere;
				if p.pere = none
				then
					(* p pointe sur la racine *)
					case p.nb
						when 1 : (* p a 1 fils *)
									courant := p;
									courant.FG := none;
									courant.nb := 0;
									courant.IG := -1;

						when 2 : (* p a 2 fils *)
									if p.FG.IG = courant.IG
									then
										p.FG := p.FM;
										p.IG := p.FG.IG;
									fi;
									p.FM := none;
									p.nb := p.nb - 1;
									p.IM := -1;
						when 3 : (* p a 3 fils *)
									if p.IG = courant.IG
									then
										p.FG := p.FM;
										p.FM := p.FD;
										p.IG := p.FG.IG;
										p.IM := p.FM.IG;
									else
										if p.FM.IG = courant.IG
										then
											p.FM := p.FD;
											p.IM := p.FM.IG;
										fi;
									fi;
									p.FD := none;
									p.nb := p.nb - 1;
					esac;
				else
					(* p ne pointe pas sur le racine *)
					case p.nb
						when 2 : (* p a 2 fils *)
									pref IIUWgraph block
									begin
										call cls;
										call move(10,10);
										call outstring("-> Le cas ou l'on veut supprimer une feuille");
										call move(10,20);
										call outstring("dont le pere a 2 fils n'a pas ete gere.");
									end;
						
						when 3 : (* p a 3 fils *)
									if p.FG.IG = courant.IG
									then
										p.FG := p.FM;
										p.FM := p.FD;
										p.IG := p.FG.IG;
										p.IM := p.FM.IG;
									else
										if p.FM.IG = courant.IG
										then
											p.FM := p.FD;
											p.IM := p.FM.IG;
										fi;
									fi;
										
									p.FD := none;
									p.nb := p.nb - 1 ;
					esac;
				fi;
			else
				pref IIUWgraph block
				begin
					call move(10,20);
					call outstring("-> On ne peut pas supprimer cet element");
					call move(10,30);
					call outstring("car il n'est pas dans l'arbre");
				end;
			fi;
			b.racine := racine;
			result := b;
		end supprimer;

		unit inserer : function(v : integer) : barbre;

			unit refaire : procedure(inout p, f1, f2, j, r : noeud);
			begin
				(* suivant le nombre de fils de p *)
				case p.nb
					when 3 : (* p a 3 fils *)
								if p.FG = f1
								then
									p.FD := p.FM;
									p.FM := j;
								else
									p.FD := j;
								fi;

					when 4 : (* p a 4 fils *)
								(* et creer un nouveau noeud *)
								j := new noeud;
								if p.FG = f1
								then
									j.FG := p.FM;
									j.FM := p.FD;
									p.FM := f2;
								else
									if p.FM = f1
									then
										j.FG := f2;
										j.FM := p.FD;
									else
										j.FG := f1;
										j.FM := f2;
									fi;
								fi;
												
								j.FG.pere := j;
								j.FM.pere := j;
								j.nb := 2;
								p.FD := none;
								p.nb := 2;
												
								if p.pere =/= none
								then
									(* le pere de p n'est pas la racine *)
									(* il faut repeter la procedure refaire *)
									j.pere := p.pere;
									p.pere.nb := p.pere.nb + 1;
									call refaire(p.pere, p, j, j, r);
								else
									(* le pere de p est la racine *)
									(* donc il faut creer une nouvelle racine *)
									r := new noeud;
									r.nb := 2;
									r.FG := p;
									r.FM := j;
									p.pere := r;
									j.pere := r;
									racine := r;
								fi;
				esac;
			end refaire;


		var bidon, courant, i, f1, f2, j, p, r : noeud,
			 b : barbre,
			 pos : integer;
		begin
			b := new barbre;

			bidon := new noeud;
			courant := new noeud;
			r := new noeud;
			i:= new noeud;
			f1 := new noeud;
			f2 := new noeud;
			j := new noeud;
			p:= new noeud;

			if vide
			then
				(* l'arbre est vide *)
				(* creer la feuille qui contiendra l'element a inserer *)
				courant := new noeud;
				courant.pere := racine;
				courant.IG := v;
				racine.IG := v;
				racine.nb := 1;
				racine.FG := courant;

				b.racine := racine;
				result := b;

			else
				(* l'arbre n'est pas vide *)
				courant := racine;
				if present(v,courant)
				then
					pref IIUWgraph block
					begin
						call move(10,20);
						call outstring("-> L'element ne peut etre inserer");
						call move(10,30);
						call outstring("puisqu'il appartient deja a l'arbre.");
					end;                              
				else
					(* l'element n'existe pas dans l'arbre *)
					
					pos := 0;

					i := new noeud;
					p := new noeud;
					i := courant;
					i.pere := courant.pere;
					p := courant.pere;

					(* creer le noeud qui contiendra l'element a inserer *)
					courant := new noeud;
					courant.IG := v;
					courant.pere := p;
					p.nb := p.nb + 1;

					(* determination de la position ou inserer l'element *)
					if i.IG = p.FG.IG
					then
						pos := 1;
					else
						if p.FM =/= none
						then
							if i.IG = p.FM.IG
							then
								pos := 2;
							else
								if p.FD =/= none
								then
									if i.IG = p.FD.IG
									then
										pos := 3;
									fi;
								fi;
							fi;
						fi;
					fi;

					(* suivant le nombre de fils de p *)
					case p.nb
						when 2 : (* p a 2 fils *)
									if courant.IG > i.IG
									then pos := pos + 1;
									fi;
									
									(* suivant la position de l'element *)
									case pos
										when 1 : p.FM := p.FG;
													p.FG := courant;
										when 2 : p.FM := courant;
									esac;
						when 3 : (* p a 3 fils *)
									if courant.IG > i.IG
									then pos := pos + 1;
									fi;
									
									(* suivant la position de l'element *)
									case pos
										when 1 : p.FD := p.FM;
													p.FM := p.FG;
													p.FG := courant;
										when 2 : p.FD := p.FM;
													p.FM := courant;
										when 3 : p.FD := courant;
									esac;
						when 4 : (* p a 4 fils *)
									if courant.IG > i.IG
									then pos := pos + 1;
									fi;

									f1 := new noeud;
									f2 := new noeud;
									
									(* suivant la position de l'element *)
									case pos
										when 1 : f1 := p.FM;
													f2 := P.FD;
													p.FD := none;
													p.FM := p.FG;
													p.FG := courant;
													(**)
										when 2 : f1 := p.FM;
													f2 := p.FD;
													p.FD := none;
													p.FM := courant;
													(**)
										when 3 : f1 := courant;
													f2 := p.FD;
													p.FD := none;
													(**)
										when 4 : f1 := p.FD;
													f2 := courant;
													p.FD := none;
													(**)
									esac;

									j := new noeud;

									j.FG := f1;
									j.FM := f2;
									j.FG.pere := j;
									j.FM.pere := j;
									j.nb := 2;
									p.nb := 2;

									if p.pere =/= none
									then
										(* p a un pere *)
										(* il faut repeter la procedure refaire *)
										j.pere := p.pere;
										p.pere.nb := p.pere.nb + 1;
										call refaire(p.pere, p, j, j, r);
									else
										(* p est la racine *)
										(* donc il faut creer une nouvelle racine *)
										r := new noeud;
										r.nb := 2;
										r.FG := p;
										r.FM := j;
										p.pere := r;
										j.pere := r;
										racine := r;
									fi;
					esac;
				fi;

				courant := racine;
				b.racine := courant;
				result := b;
			fi;
		end inserer;

	begin
		racine := new noeud;
	end barbre;


var ba : barbre,
	 touche, e : integer,
	 bidon, courant, a, b : noeud,
	 rep : char,
	 choix : integer;

begin
	ba := new barbre;
	courant := new noeud;
	courant := ba.racine;
	
	pref IIUWgraph block
	begin
		do
			call presentation;
			read(choix);
			call WriteInteger(choix);
			(* selon le choix *)
			case choix
				when 1 : (* inserer un element *)
							rep := 'o';
							do                     
								if rep = 'o'
								then
									call cls;
									call hpage(0,1,1);
									call move(10,10);
									call outstring("-> Entrez l'element a inserer = ");
									read(e);
									call WriteInteger(e);
									courant := ba.racine;
									ba := ba.inserer(e);
									courant := ba.racine;
									call ba.reorganiser(courant, bidon);
									call reponse(rep);
								else if rep ='n'
										then
											exit;
										else
											call reponse(rep);
										fi;
								fi;
							od;


				when 2 : (* supprimer un element *)
							rep := 'o';
							do                     
								if rep = 'o'
								then
									call cls;
									call hpage(0,1,1);
									if ba.vide
									then
										call move(10,10);
										call outstring("-> Il est impossible de supprimer un element");
										call move(10,20);
										call outstring("dans un arbre vide");
									else
										call move(10,10);
										call outstring("-> Entrez l'element a supprimer = ");
										read(e);
										call WriteInteger(e);
										courant := ba.racine;
										ba := ba.supprimer(e);
										courant := ba.racine;
										call ba.reorganiser(courant,bidon);
										call reponse(rep);
									fi;
								else if rep ='n'
										then
											exit;
										else
											call reponse(rep);
										fi;
								fi;
							od;

				when 3 : (* determiner si l'element est present dans l'arbre *)
							rep := 'o';
							do                     
								if rep = 'o'
								then
									call cls;
									call hpage(0,1,1);
									if ba.vide
									then
										call move(10,10);
										call outstring("-> Il est impossible de rechercher un element");
										call move(10,20);
										call outstring("dans un arbre vide");
									else
										call move(10,10);
										call outstring("Entrez l'element = ");
										read(e);
										call WriteInteger(e);
										courant := ba.racine;
										if ba.present(e,courant)
										then
											call move(10,20);
											call outstring("-> L'element est present");
										else
											call move(10,20);
											call outstring("-> L'element est absent");
										fi;
									fi;
									call reponse(rep);
								else if rep ='n'
										then
											exit;
										else
											call reponse(rep);
										fi;
								fi;
							od;


				when 4 : (* determiner l'element minimum *)
							call cls;
							call hpage(0,1,1);
							if ba.vide
							then
								call move(10,10);
								call outstring("-> Il est impossible de rechercher le minimum");
								call move(10,20);
								call outstring("dans un arbre vide");
							else
								e := ba.minimum;
								call move(10,10);
								call outstring("-> Le minimum est ");
								call WriteInteger(e);
							fi;
							call move(250,325);
							call outstring("Tapez une touche pour continuer");
							touche := inchar;

				when 5 : (* determiner l'element maximum *)
							call cls;
							call hpage(0,1,1);
							if ba.vide
							then
								call move(10,10);
								call outstring("-> Il est impossible de rechercher le maximum");
								call move(10,20);
								call outstring("dans un arbre vide");
							else
								e := ba.maximum;
								call move(10,10);
								call outstring("-> Le maximum est ");
								call WriteInteger(e);
							fi;
							call move(250,325);
							call outstring("Tapez une touche pour continuer");
							touche := inchar;

				when 6 : (* determiner si l'arbre est vide *)
							call cls;
							call hpage(0,1,1);
							call move(10,10);
							if ba.vide then call outstring("-> L'arbre est vide");
										  else call outstring("-> L'arbre n'est pas vide");
							fi;
							call move(250,325);
							call outstring("Tapez une touche pour continuer");
							touche := inchar;

				when 7 : (* affichage de l'arbre *)
							call cls;
							if ba.vide
							then
								call hpage(0,1,1);
								call move(10,10);
								call outstring("L'arbre est vide.");
							else
								courant := ba.racine;
								call ba.afficher(courant);
							fi;
							call move(250,325);
							call outstring("Tapez une touche pour continuer");
							touche := inchar;

				when 8 : (* fin du programme *)
							call groff;
							exit;
			esac;
		 od;
	end;
end mybarbre.