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

type tree = N of tree list

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

let rec height = function
  | N l -> List.fold_left (fun h t -> max h (1 + height t)) 1 l

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

(** avec un parcours en largeur *)

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

let hbfs t = hbfsaux 1 [] [t]


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

let rec hstackaux m = function
  | []            -> m
  | (n, N l) :: s -> let s = let n = n+1 in
                             List.fold_left (fun s t -> (n, t) :: s) s l in
                     hstackaux (max m n) s

let hstack t = hstackaux 0 [1, t]

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

(* CPS transform *)

let rec hcpsaux f k = match f with
  | []       -> k 0
  | N l :: f -> hcpsaux l (fun hl -> let hl = 1 + hl in
                hcpsaux f (fun hr -> k (max hl hr)))

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

(* defunctionalization *)

type cont = Kid | Khead of tree list * cont | Ktail of int * cont

let rec height3 f k = match f with
  | []       -> continue3 k 0
  | N l :: f -> height3 l (Khead (f, k))

and continue3 k v = match k with
  | Kid           -> v
  | Khead (f , k) -> let v = v+1 in height3 f (Ktail (v, k))
  | Ktail (hl, k) -> continue3 k (max hl v)

let hdefun t = height3 [t] Kid

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

open Format
open Unix

(** Building trees *)

let leaf = N []

let rec linear n t = if n = 0 then t else linear (n-1) (N [t])
let linear n = assert (n > 0); linear (n-1) leaf

let rec perfect d =
  if d = 1 then leaf else let t = perfect (d-1) in N [t; t]

let rec random n =
  let rec forest n =
    if n = 0 then []
    else let k = 1 + Random.int n in random k :: forest (n-k) in
  N (forest (n-1))

(** testing height *)

let linears = Array.init 5001 (fun i -> linear (i+1))
let perfects = Array.init 21 (fun i -> perfect (i+1))
let trees = Array.init 100 (fun i -> random (500 * (i + 1)))
let () = eprintf "done@."

let test_height h =
  assert (h leaf = 1);
  Array.iteri (fun n t -> assert (h t = n + 1)) linears;
  Array.iteri (fun d t -> assert (h t = d + 1)) perfects;
  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 " hstack: @?"; print_utime test_height hstack
let () = printf "   hcps: @?"; print_utime test_height hcps
let () = printf " hdefun: @?"; print_utime test_height hdefun

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

This document was generated using caml2html