(** {1 Plusieurs façons de mesurer la hauteur d'un arbre} *)

type tree = E | N of tree * tree

(** solution récursive, qui peut faire déborder la pile *)

let rec height = function
  | E           -> 0
  | N (l, r) -> 1 + max (height l) (height r)

(** {2 Solutions ad-hoc} *)

(** avec un parcours en largeur *)

let rec hbfsaux m next = function
  | []               -> if next=[] then m else hbfsaux (m+1) [] next
  | E        :: curr -> hbfsaux m next         curr
  | N (l, r) :: curr -> hbfsaux m (l::r::next) curr

let hbfs t = hbfsaux 0 [] [t]

(** variante sans pousser de E dans les listes *)

let rec hbfs2aux m next = function
  | [] -> if next = [] then m+1 else hbfs2aux (m+1) []           next
  | N (E, E) :: curr              -> hbfs2aux m     next         curr
  | (N (E, t) | N (t, E)) :: curr -> hbfs2aux m     (t::next)    curr
  | N (l, r) :: curr              -> hbfs2aux m     (l::r::next) curr
  | E :: _ -> assert false

let hbfs2 = function E -> 0 | t -> hbfs2aux 0 [] [t]

(** avec une pile de paires (n, t) où n est la profondeur du sous-arbre t
    dans l'arbre original *)

let rec hstack1aux m = function
  | []                 -> m
  | (n, E) :: s        -> hstack1aux (max n m) s
  | (n, N (l, r)) :: s -> hstack1aux m ((n+1,l) :: (n+1,r) :: s)

let hstack1 t = hstack1aux 0 [0, t]

(** la même, avec une pile un peu plus compacte *)

type stack = Nil | Cons of int * tree * stack

let rec hstack2aux m = function
  | Nil                   -> m
  | Cons (n, E, s)        -> hstack2aux (max n m) s
  | Cons (n, N (l, r), s) -> hstack2aux m (Cons (n+1, l, Cons (n+1, r, s)))

let hstack2 t = hstack2aux 0 (Cons (0, t, Nil))

(** ... en expansant max *)

let rec hstack3aux m = function
  | Nil                   -> m
  | Cons (n, E, s)        -> hstack3aux (if n>m then n else m) s
  | Cons (n, N (l, r), s) -> hstack3aux m (Cons (n+1, l, Cons (n+1, r, s)))

let hstack3 t = hstack3aux 0 (Cons (0, t, Nil))

(** ... et enfin en évitant de pousser des arbres vides sur la pile *)

let rec hstack4aux m = function
  | Nil -> m
  | Cons (n, N (E, E), s) -> hstack4aux (if n>=m then n+1 else m) s
  | Cons (n, (N (E,t) | N(t,E)), s) -> hstack4aux m (Cons (n+1, t, s))
  | Cons (n, N (l, r), s) -> hstack4aux m (Cons (n+1, l, Cons (n+1, r, s)))
  | Cons (_, E, _) -> assert false

let hstack4 t = if t = E then 0 else hstack4aux 0 (Cons (0, t, Nil))

(** la même que hstack, avec une boucle while *)

let hstackwhile t =
  let stack = ref [0, t] in
  let h = ref 0 in
  while !stack <> [] do match !stack with
    | []                 -> assert false
    | (n, E) :: s        -> h := max !h n; stack := s
    | (n, N (l, r)) :: s -> stack := (n+1, l) :: (n+1, r) :: s
  done;
  !h

(** En espace log(N) (Martin Clochard) *)

let rec height_limited acc depth lim t = match t with
  | E -> Some (max acc depth, lim-1)
  | N (l, r) ->
      let rec process_small_child limc =
        if limc = 0 then None else
        match process_small_child (limc / 2) with
        | Some _ as s -> s
        | None -> (match height_limited 0 0 limc l with
                   | Some (h, dl) -> Some (h, limc-dl, r)
                   | None -> (match height_limited 0 0 limc r with
                              | Some (h, dl) -> Some (h, limc-dl, l)
                              | None -> None)) in
      let limc = lim / 2 in
      match process_small_child limc with
      | None -> None
      | Some (h, sz, rm) ->
         height_limited (max acc (depth+h+1)) (depth+1) (lim-sz) rm

let martin t =
  let rec loop lim = match height_limited 0 0 lim t with
    | None -> loop (lim * 2)
    | Some (h,_) -> h in
  loop 1

(** {2 Solutions génériques} *)

(** transformation CPS *)

let rec hcpsaux t k = match t with
  | E        -> k 0
  | N (l, r) -> hcpsaux l (fun hl ->
                hcpsaux r (fun hr -> k (1 + max hl hr)))

let hcps t = hcpsaux t (fun h -> h)

(** défonctionalisation *)

type cont = Kid | Kleft of tree * cont | Kright of int * cont

let rec hdefunaux t k = match t with
  | E        -> hdefuncont k 0
  | N (l, r) -> hdefunaux l (Kleft (r, k))

and hdefuncont k v = match k with
  | Kid            -> v
  | Kleft (r, k)   -> hdefunaux r (Kright (v, k))
  | Kright (hl, k) -> hdefuncont k (1 + max hl v)

let hdefun t = hdefunaux t Kid

(** la même, comme une seule fonction récursive *)

type what = Arg of tree | Res of int

let rec hdefun2aux w k = match w, k with
  | Arg E, _              -> hdefun2aux (Res 0) k
  | Arg (N (l, r)), _     -> hdefun2aux (Arg l) (Kleft (r, k))
  | Res v, Kid            -> v
  | Res v, Kleft (r, k)   -> hdefun2aux (Arg r) (Kright (v, k))
  | Res v, Kright (hl, k) -> hdefun2aux (Res (1 + max hl v)) k

let hdefun2 t = hdefun2aux (Arg t) Kid

(** et finalement comme une boucle while *)

let is_id = function Kid -> true | _ -> false
let is_result = function Res _ -> true | _ -> false
let result = function Res v -> v | _ -> assert false

let hdefun3 t =
  let a = ref (Arg t) in
  let k = ref Kid in
  while not (is_id !k && is_result !a) do
    match !a, !k with
    | Arg E,          _      -> a := Res 0
    | Arg (N (l, r)), _      -> a := Arg l; k := Kleft (r, !k)
    | Res v, Kid             -> assert false
    | Res v, Kleft (r, k0)   -> a := Arg r; k := Kright (v, k0)
    | Res v, Kright (hl, k0) -> a := Res (1 + max hl v); k := k0
  done;
  result !a

(** avec un zipper *)

type path =
| Top | Left of path * tree | Right of tree * path
type zipper = path * tree
let rec walk m d up = function
  | Top, E -> m
  | Top, _ when up -> m
  | Top, N (l, r) -> walk m (d+1) false (Left (Top, r), l)
  | Left (p, r), l when up -> walk m d false (Right (l, p), r)
  | Left (p, r), E as z -> walk m d true z
  | Left (p, r) as path, N (ll, lr) ->
    walk m (d+1) false (Left (path, lr), ll)
  | Right (l, p), r when up -> walk (max m d) (d-1) true (p, N (l, r))
  | Right (l, p), E         -> walk (max m d) (d-1) true (p, N (l, E))
  | Right (l, p) as path, N (rl, rr) ->
    walk m (d+1) false (Left (path, rr), rl)
let hzipper t = walk 0 0 false (Top, t)

(******************************************************************************)
(** Tests *)

open Format
open Unix

(** différentes sortes d'arbres binaires *)

let rec left n t = if n = 0 then t else left (n-1) (N (t, E))
let left n = left n E

let rec right n t = if n = 0 then t else right (n-1) (N (E, t))
let right n = right n E

let rec perfect d = if d = 0 then E else let t = perfect (d-1) in N (t, t)

let rec random n =
  if n = 0 then E else let k = Random.int n in N (random k, random (n-1-k))

(** on précalcule des arbres *)

let lefts = Array.init 10001 left
let rights = Array.init 10001 right
let perfects = Array.init 21 perfect
let trees = Array.init 100 (fun i -> random (2000 * i))
let () = eprintf "done@."

(** on teste une fonction de hauteur h *)

let test_height h =
  for n = 0 to 10000 do
    assert (h lefts.(n) = n);
    assert (h rights.(n) = n);
  done;
  for d = 0 to 20 do
    assert (h perfects.(d) = d)
  done;
  Array.iter (fun t -> ignore (h t)) trees

let utime f x =
  let u = (times()).tms_utime in
  f x;
  (times()).tms_utime -. u

let utime5 f x =
  let t = Array.init 5 (fun _ -> utime f x) in
  Array.sort compare t;
  (t.(1) +. t.(2) +. t.(3)) /. 3.

let print_utime f x =
  let ut = utime5 f x in
  printf "user time: %2.2f@." ut

(*
let () = printf " height: @?"; print_utime test_height height

let () = printf "   hbfs: @?"; print_utime test_height hbfs
let () = printf "  hbfs2: @?"; print_utime test_height hbfs2

let () = printf "hstack1: @?"; print_utime test_height hstack1
let () = printf "hstack2: @?"; print_utime test_height hstack2
let () = printf "hstack3: @?"; print_utime test_height hstack3
let () = printf "hstack4: @?"; print_utime test_height hstack4
let () = printf "hstackw: @?"; print_utime test_height hstackw

let () = printf " martin: @?"; print_utime test_height martin
*)

let () = printf "   hcps: @?"; print_utime test_height hcps
(* let () = printf "  hcps2: @?"; print_utime test_height hcps2 *)
let () = printf " hdefun: @?"; print_utime test_height hdefun
let () = printf "hdefun2: @?"; print_utime test_height hdefun2
(*
let () = printf "hdefun3: @?"; print_utime test_height hdefun3
let () = printf "hzipper: @?"; print_utime test_height hzipper
 *)

(*
Local Variables:
compile-command: "ocamlopt unix.cmxa code.ml -o code && ./code"
End:
*)

This document was generated using caml2html