(* structure de tas *)

type heap = Null | Fork of int * heap * heap

let empty = Null

let rec merge h1 h2 = match h1, h2 with
  | Null, a | a, Null ->
      a
  | Fork (xa, a, b), (Fork (xb, _, _) as c) when xa <= xb ->
      Fork (xa, b, merge a c)
  | Fork (xa, _, _) as c, Fork (xb, a, b) ->
      Fork (xb, b, merge a c)

let add x h = merge (Fork (x, Null, Null)) h

exception Empty_heap

let extract_min = function
  | Null -> raise Empty_heap
  | Fork (x, a, b) -> x, merge a b

(* application : heapsort *)

let rec heap_of_list = function
  | [] -> empty
  | x :: r -> add x (heap_of_list r)

let rec list_of_heap h =
  if h = Null then
    []
  else
    let x, h = extract_min h in x :: list_of_heap h

let heapsort l = list_of_heap (heap_of_list l)


(* tests *)

let rec print_heap fmt = function
  | Null -> Format.fprintf fmt "Null"
  | Fork (x, a, b) ->
      Format.fprintf fmt "Fork (@[%d,@ %a,@ %a@])"
        x print_heap a print_heap b

let rec is_heap_rec min = function
  | Null -> true
  | Fork (x, l, r) -> min <= x && is_heap_rec x l && is_heap_rec x r

let is_heap = is_heap_rec min_int

let check_heap h =
  let ok = is_heap h in
  Format.printf "%a: %s@."
    print_heap h (if ok then "OK" else "FAILED");
  if not ok then exit 1

let () =
  let h1 = add 2 (add 1 (add 3 Null)) in
  check_heap h1;
  let h2 = add 4 (add 0 (add 1 Null)) in
  check_heap h2;
  let h = merge h1 h2 in
  check_heap h;
  let m, h = extract_min h in
  assert (m = 0);
  check_heap h


let rec print fmt = function
 | [] -> ()
 | [x] -> Format.fprintf fmt "%d" x
 | x :: l -> Format.fprintf fmt "%d, %a" x print l

let rec is_sorted = function
 | [] | [_] -> true
 | x :: (y :: _ as l) -> x <= y && is_sorted l

let check l =
 let r = heapsort l in
 let ok = is_sorted r in
 Format.printf "[%a] => [%a]: %s@."
   print l print r (if ok then "OK" else "FAILED");
 if not ok then exit 1

let () =
 check [1; 2; 3];
 check [3; 2; 1];
 check [];
 check [1];
 check [2; 1; 1]

This document was generated using caml2html