# La lettre de Caml, numéro 5

## Les sources des programmes Caml

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.