(**************************************************************************)
(*                                                                        *)
(*  Ocamlviz --- real-time profiling tools for Objective Caml             *)
(*  Copyright (C) by INRIA - CNRS - Universite Paris Sud                  *)
(*  Authors: Julien Robert                                                *)
(*           Guillaume Von Tokarski                                       *)
(*           Sylvain Conchon                                              *)
(*           Jean-Christophe Filliatre                                    *)
(*           Fabrice Le Fessant                                           *)
(*  GNU Library General Public License version 2                          *)
(*  See file LICENSE for details                                          *)
(*                                                                        *)
(**************************************************************************)


open Ocamlviz 

(* heapsort on lists *)

(* leftist heaps *)

type 'a t = E | T of int * 'a * 'a t * 'a t

exception Empty

let rank = function E -> 0 | T (r,_,_,_) -> r

let make x a b = 
  let ra = rank a and rb = rank b in
  if ra >= rb then T (rb + 1, x, a, b) else T (ra + 1, x, b, a)

let empty = E

let is_empty = function E -> true | T _ -> false

let rec merge h1 h2 = match h1,h2 with
  | E, h | h, E -> 
      h
  | T (_,x,a1,b1), T (_,y,a2,b2) ->
      if x >= y then make x a1 (merge b1 h2) else make y a2 (merge h1 b2)
	
let add x h = merge (T (1, x, E, E)) h
  
let t' = Ocamlviz.Time.create "extract"

let extract_max = function
  | E -> raise Empty
  | T (_,x,a,b) -> x, merge a b

let extract_max e =
  Ocamlviz.Time.start t';
  let e_m = extract_max e in
  Ocamlviz.Time.stop t';
  e_m

let rec variant_of_heap = function
  | E ->
      Protocol.Node ("E", [])
  | T (_,x,l,r) ->
      Protocol.Node
	(string_of_int x, [variant_of_heap l; variant_of_heap r])

let observe_heap h =
  let r = ref None in
  fun () -> match !r with
    | None -> let v = variant_of_heap h in r := Some v; v
    | Some v -> v


let t = Time.create "heapsort"

(* heapsort *)

let heapsort l =
  let rec build h = function
    | [] -> 
	Tree.observe "h" (observe_heap h); sort [] h
    | x :: l -> build (add x h) l
  and sort acc h =
    if is_empty h then
      acc
    else
      let x,h = extract_max h in
      sort (x :: acc) h
  in
  Time.start t;
  let li = build empty l in
  Time.stop t;
  li

(* test function *)

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

let random_list n = 
  let rec make acc = function
    | 0 -> acc
    | n -> make (Random.int n :: acc) (n-1)
  in
  make [] n

let () =
  init ();
  wait_for_connected_clients 1;
  let l = random_list 100 in
  assert (sorted (heapsort l));
  wait_for_killed_clients ()
  



(*
Local Variables: 
compile-command: "unset LANG; make -C .. test-heapsortl"
End: 
*)
