Chapitre 4

(* {\em Ajouter à un tas, voir page \pageref{prog:ajouter-tas}} *)
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;;

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;;
 
(* {\em Maximum d'un tas, voir page \pageref{prog:maximum-tas}} *)
let maximum t = t.tas.(0);;

(* Supprimer dans un tas,
   {\em voir page \pageref{prog:supprimer-tas}} *)
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;;

(* {\em HeapSort, voir page \pageref{prog:heapsort}} *)
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;;
 
let a = [| 2; 1; 2; 3; 0 |];;
heapsort a;;
#a;;
- : int vect = [|0; 1; 2; 2; 3|]

(* {\em Déclaration d'un arbre, voir page \pageref{prog:declaration-arb}} *)
(* Cas binaire *)
type 'a arbre = Vide | Noeud of 'a noeud
and 'a noeud =
{contenu: 'a; filsG: 'a arbre; filsD: 'a arbre};;

(* {\em Déclaration d'un arbre, voir page \pageref{prog:declaration2-arb}} *)
(* Cas n-aire, les fils sont
   implémentés par un vecteur d'arbres. *)
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};;

(* {\em 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));;

(* {\em Impression d'un arbre, voir page \pageref{prog:imprimer-arb}} *)
#open "printf";;

let rec imprimer a tab =
 match a with
 | Vide -> ()
 | Noeud {contenu = c; filsG = fg; filsD = fd} ->
    printf "%3d     " c; imprimer fd (tab + 8);
    if fg <> Vide then
     printf "\n%s" (make_string tab ` `);
    imprimer fg tab;;

let imprimer_arbre a =
  imprimer a 0; print_newline();;
    
#imprimer_arbre (main ());;    
 20      25      28     
         21     
  3      12      13     
          8     
          6     
  3     
- : unit = ()

(* {\em Taille d'un arbre, voir page \pageref{prog:taille-arbre}} *)
let rec taille = function
| Vide -> 0
| Noeud {filsG = fg; filsD = fd; _} ->
   1 + taille fg + taille fd;;

(* {\em Arbre de recherche, voir page \pageref{prog:recherche-arb-recherche}} *)
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;;

(* Purement fonctionnel *)
let rec ajouter v = function
| 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;;
   
(* Ajout par effet mémoire *)
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 = function
| Vide -> nouvel_arbre v Vide Vide
| Noeud
   ({contenu = c; filsG = fg; filsD = fd}
     as noeud) as a ->
   if v <= c
   then noeud.filsG <- ajouter v fg
   else noeud.filsD <- ajouter v fd;
   a;;

(* Exemple *)
let a1 = ajouter 1 Vide in
let a2 = ajouter 2 a1 in
let a3 = ajouter 0 a2 in
ajouter 3 a3;;

(* On ne modifie que lorsque nécessaire,
   c'est-à-dire pour remplacer
   un arbre vide par un arbre non vide. *)
let rec ajouter v a =
 match a with
 | Vide -> nouvel_arbre v Vide Vide
 | Noeud
    ({contenu = c;
      filsG = fg;
      filsD = fd} as noeud) when v <= c ->
    let fg' = ajouter v fg in
    if fg = Vide then noeud.filsG <- fg';
    a
 | Noeud
    ({contenu = c;
      filsG = fg;
      filsD = fd} as noeud) ->
    let fd' = ajouter v fd in
    if fd = Vide then noeud.filsD <- fd';
    a;;

(* {\em Ajout dans un AVL, voir page \pageref{prog:ajout-avl}} *)

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 };;

#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";;

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

let rotD = function
| 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;;

let rotG = function
| 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;;

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 (nouvel_arbre, incr) =
         ajouter v fg in
        noeud.balance <-
          noeud.balance - incr;
        if fg = Vide
        then noeud.filsG <- nouvel_arbre;
        incr
       end else begin
         let (nouvel_arbre, incr) =
          ajouter v fd in
         noeud.balance <-
          noeud.balance + incr;
         if fd = Vide
         then noeud.filsD <- nouvel_arbre;
         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);;