La lettre de Caml, numéro 5

Les sources des programmes Caml

files binomiales ; pagodes ; algorithme naïf de dessin d'arbres

Retour à la page générale de La lettre de Caml.

Files binomiales :

type arbre_binomial = Noeud of int * arbre_binomial list ;;

let rec est_binomial = function
	| Noeud(_,[]) -> true
	| Noeud(a,(Noeud(b,r) as fils) :: q)
		-> b <= a && est_binomial fils && est_binomial (Noeud(a,q))
			&& list_length r = list_length q ;;

type squelette_binomial = Jointure of squelette_binomial list ;;

let rec squelette_binomial n =
	if n = 0 then Jointure([])
	else match squelette_binomial (n-1) with
			| Jointure(fils) -> Jointure(squelette_binomial (n-1) :: fils) ;;

let odd n = n mod 2 = 1
and even n = n mod 2 = 0 ;;

type arbre_de_la_forêt = Rien | A of arbre_binomial 
and forêt_d'arbres == arbre_de_la_forêt list ;;
type squelette_de_la_forêt = R | S of squelette_binomial
and forêt_de_squelettes == squelette_de_la_forêt list ;;

let rec forêt_de_squelettes n =
	let rec forêt_rec n k =
		if n = 0 then [ ]
		else (if odd n then S(squelette_binomial k) else R)
		     :: (forêt_rec (n / 2) (k + 1))
	in
	forêt_rec n 0 ;;

let fusion_squelettes_binomiaux a b r = match a,b,r with
	| R,R,_ -> r,R | R,_,R -> b,R | _,R,R -> a,R
	| R,S(b),S(r) -> R,(match b with Jointure(fils) -> S(Jointure(r :: fils)))
	| S(a),R,S(r) -> R,(match a with Jointure(fils) -> S(Jointure(r :: fils)))
	| S(a),S(b),_
		-> r,(match a with Jointure(fils) -> S(Jointure(b :: fils))) ;;

let rec fusion_arbres_binomiaux a b r = match a,b,r with
	| Rien,Rien,_ -> r,Rien
	| Rien,_,Rien -> b,Rien 
	| _,Rien,Rien -> a,Rien
	| Rien,_,_-> fusion_arbres_binomiaux b r a
	| _,Rien,_ -> fusion_arbres_binomiaux r a b
	| A(Noeud(a',fils_a) as arbre_a),A(Noeud(b',fils_b) as arbre_b),_
		->	if b' <= a'	then r,A(Noeud(a',arbre_b::fils_a))
						else r,A(Noeud(b',arbre_a::fils_b)) ;;

let fusion_forêts_squelettes f_a f_b =
	let rec fusion_rec f_a f_b r = match f_a,f_b,r with
		| [],[],R -> []
		| [],[],_ -> [ r ]
		| [],_,_ -> fusion_rec [ R ] f_b r
		| _,[],_ -> fusion_rec f_a [ R ] r
		| a::qa,b::qb,r ->	let s,r = fusion_squelettes_binomiaux a b r
							in
							s :: (fusion_rec qa qb r)
	in
	fusion_rec f_a f_b R ;;

let fusion_forêts_binomiales f_a f_b =
	let rec fusion_rec f_a f_b r = match f_a,f_b,r with
		| [],[],Rien -> []
		| [],[],_ -> [ r ]
		| [],_,_ -> fusion_rec [ Rien ] f_b r
		| _,[],_ -> fusion_rec f_a [ Rien ] r
		| a::qa,b::qb,r ->	let s,r = fusion_arbres_binomiaux a b r
							in
							s :: (fusion_rec qa qb r)
	in
	fusion_rec f_a f_b Rien ;;
	
let rec taille_arbre (Noeud(a,fils))	=
	it_list (fun x y -> x + (taille_arbre y)) 1 fils ;;
	
let rec taille_forêt = function
	| [] -> 0
	| Rien :: q -> taille_forêt q
	| A(a) :: q -> taille_forêt q + (taille_arbre a) ;;
	
let rec do_forêt f forêt =
	let rec do_arbre f = function
		| Noeud(a,fils) -> f(a) ; do_list (do_arbre f) fils
	in
	match forêt with 
		| [] -> ()
		| Rien :: q -> do_forêt f q
		| A(a) :: q -> do_arbre f a ; do_forêt f q ;;

type structure_de_forêt_binomiale =
	{ ajout :			int -> unit ;
	  extrait_maximum :	unit -> int ;
	  vide :			unit -> unit ;
	  itère :			(int -> unit) -> unit ;
	  taille :			unit -> int } ;;

let crée_forêt () =
	let f = ref [ Rien ]
	in
	let plus_petit = fun
		| Rien _ -> true
		| _ Rien -> false
		| (A(Noeud(a,_))) (A(Noeud(b,_))) -> a <= b
	in
	let rec max_liste = function
		| [] -> failwith "Liste vide"
		| [ t ] -> t,[ Rien ]
		| t::q ->	let m,q' = max_liste q
					in
					if plus_petit m t	then t,(Rien :: q)
										else m,(t :: q')
	in
	{	ajout = 
			(function x 
				-> f := fusion_forêts_binomiales [ A(Noeud(x,[])) ] !f ) ;
		vide = (function () -> f := [ Rien ]) ;
		taille = (function () -> taille_forêt !f) ;
		itère = (function phi -> do_forêt phi !f) ;
		extrait_maximum =
			(function ()
				->	try
						let a,f' = max_liste !f
						in
						match a with
							| Rien -> failwith "Vide"
							| A(Noeud(a,fils))
								-> 	let g' = map (function a -> A(a))
												 (rev fils)
									in
									f := fusion_forêts_binomiales f' g' ;
									a
					with _ -> failwith "Forêt vide")
	} ;;

let tri_par_file_binomiale l =
	let f = crée_forêt ()
	in
	do_list f.ajout l ;
	let résultat = ref []
	in
	try while true do 
			résultat := f.extrait_maximum () :: !résultat 
		done ; !résultat
	with _ -> !résultat ;;

Pagodes :

type arbre = Vide | Noeud of int * arbre * arbre ;;

let est_tournoi a = 
	let rec vérifie m = function
		| Vide -> true
		| Noeud(x,g,d) -> x <= m && vérifie x g && vérifie x d
	in
	match a with
		| Vide -> true
		| Noeud(x,g,d) -> vérifie x a ;;

let rec insertion a x = match a with
	| Vide -> Noeud(x,Vide,Vide)
	| Noeud(r,_,_) when x >= r -> Noeud(x,a,Vide)
	| Noeud(r,g,Vide) -> Noeud(r,g,Noeud(x,Vide,Vide))
	| Noeud(r,g,(Noeud(r',_,_) as d)) when r' >= x -> Noeud(r,g,insertion d x)
	| Noeud(r,g,d) -> Noeud(r,g,Noeud(x,d,Vide)) ;;

let rec parcours = function
	| Vide -> []
	| Noeud(r,g,d) -> (parcours g) @ [ r ] @ (parcours d) ;;
		
let extrait_maximum = function
	| Vide -> failwith "arbre vide"
	| Noeud(m,g,d) -> m,(it_list insertion g (parcours d)) ;;

let rec profil_droit = function
	| Vide -> -1
	| Noeud(_,_,d) -> profil_droit d + 1 ;;

let arbre_exemple = it_list insertion Vide [20;26;6;14;22;18;28;21;23;25;15;17] ;;

type pagode = Néant | P of nud_pagode
and nud_pagode = { valeur : int ; mutable bleu : pagode ; mutable rouge : pagode } ;;

let crée_pagode x =
	let rec p = P { valeur = x ; bleu = p ; rouge = p }
	in
	p ;;

let rouge	 (P p)	 = p.rouge
and bleu	 (P p)	 = p.bleu
and rouge_à	 (P p) x = p.rouge <- x
and bleu_à	 (P p) x = p.bleu  <- x
and valeur	 (P p)	 = p.valeur ;;

let rec pagode_d'arbre = function
	| Vide -> Néant
	| Noeud(n,g,d)
		->	let p = crée_pagode n
			in
			if g <> Vide then
			begin
				let pg = pagode_d'arbre g
				in
				rouge_à p (rouge pg) ;
				rouge_à pg p
			end ;
			if d <> Vide then
			begin
				let pd = pagode_d'arbre d
				in
				bleu_à p (bleu pd) ;
				bleu_à pd p
			end ;
			p ;;

let pagode_exemple = pagode_d'arbre arbre_exemple ;;

let rec arbre_de_pagode = function
	| Néant -> Vide
	| p ->	let fils_gauche p =
				let rec remonte q = if rouge q = p then q else remonte (rouge q)
				in
				remonte (rouge p)
			and fils_droit p =
				let rec remonte q = if bleu	 q = p then q else remonte (bleu q)
				in
				remonte (bleu p)
			in
			let g = let pg = fils_gauche p
					in
					if pg = p then Vide
					else 
					(	rouge_à pg (rouge p) ;
						let g = arbre_de_pagode pg
						in
						rouge_à pg p ;
						g	)
			and d = let pd = fils_droit p
					in
					if pd = p then Vide
					else
					(	bleu_à pd (bleu p) ;
						let d = arbre_de_pagode pd
						in
						bleu_à pd p ;
						d	)
			in
			Noeud(valeur p,g,d) ;;
	
let fusion a b = match a,b with
	| Néant,b -> b
	| a,Néant -> a
	| a,b
		->	let rec parcours triplet = match triplet with
				| (_,Néant,_) -> triplet
				| (Néant,_,_) -> triplet
				| (a',b',r)
					->	if (valeur a') < (valeur b') then
							let t = bleu  a'
							in	bleu_à	a' (bleu  r) ; bleu_à  r a' ;
								parcours (t,b',a') 
						else
							let t = rouge b'
							in	rouge_à b' (rouge r) ; rouge_à r b' ;
								parcours (a',t,b') 
			in
			let a' = bleu a and b' = rouge b
			in
			bleu_à a Néant ; rouge_à b Néant ;
			let a',b',r =
				if valeur a' < valeur b' then
					let r = bleu  a'
					in bleu_à  a' a' ; (r,b',a')
				else
					let r = rouge b'
					in rouge_à b' b' ; (a',r,b') 
			in
			match parcours (a',b',r) with
				| (a',Néant,r) -> ( bleu_à	a (bleu	 r) ;
									bleu_à	r a' ;
									a	)
				| (Néant,b',r) -> ( rouge_à b (rouge r) ;
									rouge_à r b' ;
									b ) ;;
 
let insertion p x = fusion p (crée_pagode x) ;;

let suppression_maximum p =
	let fils_gauche p =
		let rec remonte q = if rouge q = p then q else remonte (rouge q)
		in
		remonte (rouge p)
	and fils_droit p =
		let rec remonte q = if bleu	 q = p then q else remonte (bleu q)
		in
		remonte (bleu p)
	in
	let pg = fils_gauche p
	and pd = fils_droit p
	in
	if pg = p && pd = p then Néant
	else if pg = p then pd
	else if pd = p then pg
	else
	(	rouge_à pg (rouge p) ;
		bleu_à	pd (bleu  p) ;
		fusion pg pd ) ;;

Algorithme naïf de dessin d'arbres :

type 'a arbre = Noeud of 'a * 'a arbre list ;;

let exemple = Noeud(0,[ Noeud(1,[ Noeud(3,[]) ; Noeud(4,[ Noeud(7,[]) ;
                                                      Noeud(8,[ Noeud(11,[]) ; Noeud(12,[]) ]) ]) ])  ;
                       Noeud(2,[ Noeud(5,[]) ; Noeud(6,[ Noeud(9,[]) ;
                                                      Noeud(10,[ Noeud(13,[]) ; Noeud(14,[]) ]) ]) ])
                     ]) ;;

let rec mesure = function
    | Noeud(r,[]) -> Noeud((r,0),[])
    | Noeud(r,fils)
        ->  let fils' = map mesure fils
            in
            let largeur = it_list (fun x (Noeud((_,l),_)) -> max x l) 0 fils'
            in
            Noeud((r,largeur * (list_length fils) + (list_length fils) - 1),fils') ;;

let rec place x = function
    | Noeud((r,largeur),[ ] ) -> Noeud((r,x),[])
    | Noeud((r,largeur),[ b ]) -> Noeud((r,x),[ place x b ])
    | Noeud((r,largeur),fils)
        -> let n = list_length fils
           and l = float_of_int largeur
           in
           let dx = (l +. 1.0) /. (float_of_int n)
           in
           let x1 = x -. (float_of_int (n - 1)) *. dx /. 2.0
           in
           let rec aux x = function
               | [] -> []
               | a :: q -> (place x a) :: (aux (x +. dx) q)
           in
           Noeud((r,x),(aux x1 fils)) ;;

let x_ifie arbre = place 0.0 (mesure arbre) ;;

Retour à la page générale de La lettre de Caml.