Programmes en Caml parie deux 2

(* Ajouter à un tas, avec une structure enregistrement *)
type 'a tas =
{ mutable cardinal: int;
tas: 'a vect };;

let ajouter v t =
t.cardinal <- t.cardinal + 1;
let a = t.tas in
let nTas = t.cardinal in
let i = ref (nTas - 1) in
if !i >= vect_length a
then failwith "tas plein" else
while !i > 0 && a.((!i - 1) / 2) <= v do
a.(!i) <- a.((!i - 1) / 2);
i := (!i - 1) / 2
done;
a.(!i) <- v;;
(* Ajouter à un tas, voir page X *)
let nTas = ref 0;;

let ajouter v a =
incr nTas;
let i = ref (!nTas - 1) in
while !i > 0 && a.((!i - 1) / 2) <= v do
a.(!i) <- a.((!i - 1) / 2);
i := (!i - 1) / 2
done;
a.(!i) <- v;;

(* Maximum d'un tas, voir page X *)
let maximum t = t.tas.(0);;

(* Supprimer dans un tas,
voir page X *)
let supprimer t =
t.cardinal <- t.cardinal - 1;
let a = t.tas in
let nTas = t.cardinal in
a.(0) <- a.(nTas);
let i = ref 0
and v = a.(0)
and j = ref 0 in
begin
try
while 2 * !i + 1 < nTas do
j := 2 * !i + 1;
if !j + 1 < nTas && a.(!j + 1) > a.(!j)
then j := !j + 1;
if v >= a.(!j) then raise Exit;
a.(!i) <- a.(!j);
i := !j
done
with Exit -> ()
end;
a.(!i) <- v;;
(* HeapSort, voir page X *)
let heapsort a =
let n = vect_length a - 1 in
let t = {cardinal = 0; tas = a} in
for i = 0 to n do ajouter a.(i) t done;
for i = n downto 0 do
let v = maximum t in
supprimer t;
a.(i) <- v
done;;
(* Déclaration d'un arbre binaire, voir page X *)
type 'a arbre = Vide | Noeud of 'a noeud
and 'a noeud =
{contenu: 'a; filsG: 'a arbre; filsD: 'a arbre};;

(* Déclaration d'un arbre n-aire, voir page X *)

type 'a arbre = Vide | Noeud of 'a noeud
and 'a noeud = {contenu: 'a; fils: 'a arbre vect};;

(* Cas n-aire, les fils sont
implémentés par une liste d'arbres. *)

type 'a arbre = Vide | Noeud of 'a noeud
and 'a noeud = {contenu: 'a; fils: 'a arbre list};;
(* Ajouter dans un arbre *)
let nouvel_arbre v a b =
Noeud {contenu = v; filsG = a; filsD = b};;

let main () =
let a5 =
nouvel_arbre 12
(nouvel_arbre 8 (nouvel_arbre 6 Vide Vide) Vide)
(nouvel_arbre 13 Vide Vide) in
nouvel_arbre 20
(nouvel_arbre 3 (nouvel_arbre 3 Vide Vide) a5)
(nouvel_arbre 25
(nouvel_arbre 21 Vide Vide)
(nouvel_arbre 28 Vide Vide));;
(* Impression d'un arbre, voir page X *)
#open "printf";;

let imprimer_arbre a =
let rec imprimer1 a tab =
match a with
Vide -> ()
| Noeud {contenu = c; filsG = fg; filsD = fd} ->
printf "%3d " c; imprimer1 fd (tab + ;
if fg <> Vide then
printf "\n%s" (make_string tab ` `);
imprimer1 fg tab;;
in
imprimer1 a 0; print_newline();;
(* Taille d'un arbre, voir page X *)
let rec taille = function
Vide -> 0
| Noeud {filsG = fg; filsD = fd; _} ->
1 + taille fg + taille fd;;
(* Arbre de recherche,
voir page X *)
let rec recherche v a =
match a with
Vide -> Vide
| Noeud
{contenu = c; filsG = fg; filsD = fd} ->
if c = v then a else
if c < v then recherche v fg
else recherche v fd;;
(* Ajouter, purement fonctionnel,
voir page X *)
let rec ajouter v a =
match a with
Vide -> nouvel_arbre v Vide Vide
| Noeud
{contenu = c; filsG = fg; filsD = fd} ->
if v <= c
then nouvel_arbre c (ajouter v fg) fd
else nouvel_arbre c (ajouter v fd) fg;;
(* Ajouter avec effet de bord,
voir page \pageref{prog:recherche-arb-ajouter-fonctionnel}} *)
type 'a arbre = Vide | Noeud of 'a noeud
and 'a noeud =
{mutable contenu: 'a;
mutable filsG: 'a arbre;
mutable filsD: 'a arbre};;

let nouvel_arbre v a b =
Noeud {contenu = v; filsG = a; filsD = b};;

let rec ajouter v a =
match a with
Vide -> nouvel_arbre v Vide Vide
| Noeud
({contenu = c; filsG = fg; filsD = fd}
as n) ->
if v <= c
then n.filsG <- ajouter v fg
else n.filsD <- ajouter v fd;
a;;
(* Ajouter, purement fonctionnel avec un autre type d'arbres *)
type 'a arbre = Vide | Noeud of 'a arbre * 'a * 'a arbre;;

let nouvel_arbre v a b =
Noeud (a, v, b);;

let rec ajouter v a =
match a with
Vide -> nouvel_arbre v Vide Vide
| Noeud (fg, c, fd) ->
if v <= c
then nouvel_arbre c (ajouter v fg) fd
else nouvel_arbre c (ajouter v fd) fg;;
(* Arbres AVL, voir page X *)

type 'a avl = Vide | Noeud of 'a noeud

and 'a noeud =
{ mutable balance: int;
mutable contenu: 'a;
mutable filsG: 'a avl;
mutable filsD: 'a avl };;

let nouvel_arbre bal v a b =
Noeud
{balance = bal; contenu = v;
filsG = a; filsD = b};;
#open "format";;

let rec print_avl = function
Vide -> ()
| Noeud
{balance = bal; contenu = v;
filsG = a; filsD = b} ->
open_box 1; print_string "(";
print_int bal; print_string ": ";
print_int v; print_space();
print_avl a; print_space(); print_avl b;
print_cut(); print_string ")";
close_box();;
install_printer "print_avl";;
(* Rotation dans un AVL, voir page X *)
let rotD a =
match a with
Vide -> failwith "rotD"
| Noeud
({balance = bB; contenu = v;
filsG = A; filsD = c} as nB) as B ->
match A with
Vide -> failwith "rotD"
| Noeud
({balance = bA; contenu = v;
filsG = a; filsD = b} as nA) ->
nA.filsD <- B;
nB.filsG <- b;
let bBnew = bB + 1 - min 0 bA in
let bAnew = bA + 1 + max 0 bBnew in
nA.balance <- bAnew;
nB.balance <- bBnew;
A;;
(* Rotation dans un AVL, voir page X *)
let rotG a =
match a with
Vide -> failwith "rotG"
| Noeud
({balance = bA; contenu = v;
filsG = c; filsD = B} as nA) as A ->
match B with
| Vide -> failwith "rotG"
| Noeud
({balance = bB; contenu = v;
filsG = a; filsD = b} as nB) ->
nA.filsD <- a;
nB.filsG <- A;
let bAnew = bA - 1 - max 0 bB in
let bBnew = bB - 1 + min 0 bAnew in
nA.balance <- bAnew;
nB.balance <- bBnew;
B;;
(* Ajout dans un AVL, voir page X *)

let rec ajouter v a =
match a with
Vide -> (nouvel_arbre 0 v Vide Vide, 1)
| Noeud
({balance = bal; contenu = c;
filsG = fg; filsD = fd} as noeud) ->
let diff =
if v <= c then begin
let (a, incr) = ajouter v fg
in
noeud.balance <- noeud.balance - incr;
noeud.filsG <- a;
incr
end else begin
let (a, incr) = ajouter v fd
in
noeud.balance <- noeud.balance + incr;
noeud.filsD <- a;
incr
end in
if diff <> 0 && noeud.balance <> 0 then
if noeud.balance < -1 then begin
match fg with
Vide -> failwith "Vide"
| Noeud {balance = b; _} ->
if b < 0 then (rotD a, 0)
else begin
noeud.filsG <- rotG fg; (rotD a, 0)
end
end else
if noeud.balance > 1 then begin
match fd with
Vide -> failwith "Vide"
| Noeud {balance = b; _} ->
if b > 0 then (rotG a, 0)
else begin
noeud.filsD <- rotD fd; (rotG a, 0)
end
end
else (a, 1)
else (a, 0);;