(* Un'insieme totalmente ordinato *)
module type ORDERED =
sig
  type t
  val eq  : t * t -> bool
  val lt  : t * t -> bool
  val leq : t * t -> bool
end;;

module IntOrdered:(ORDERED with type t = int) =
struct
  type t = int
  let eq (i1,i2) = (i1 = i2)
  let lt (i1,i2) = (i1 < i2)
  let leq (i1,i2) = (i1 <= i2)
end;;

(* Uno heap *)

module type HEAP =
sig
  type t
  type heap
  val empty     : heap
  val isEmpty   : heap -> bool
  val insert    : t -> heap -> heap
  val merge     : heap -> heap -> heap
  val findMin   : heap -> t
  val deleteMin : heap -> heap
end;;

exception Empty;;

(* gli heap sinistrorsi *)

module LeftistHeap(Elt:ORDERED) : (HEAP with type t = Elt.t) =
struct
  type t = Elt.t
  type heap = E | T of int * t * heap * heap

  (* funzioni private *)
  let rank h = match h with
    E -> 0
  | T(r,_,_,_) -> r

  let makeT x a b =
    if (rank a) >= (rank b) then T(rank b + 1,x,a,b)
    else T(rank a + 1,x,b,a)

  let empty  = E

  let isEmpty h = match h with
    E -> true
  | _ -> false

  let rec merge h1 h2 = match (h1,h2) with
    (h,E) -> h
  | (E,h) -> h
  | (T(_,x,a1,b1),T(_,y,a2,b2)) ->
      if Elt.leq(x,y) then makeT x a1 (merge b1 h2)
      else makeT y a2 (merge h1 b2)

  let insert x h = merge (T(1,x,E,E)) h

  let findMin h = match h with
    E -> raise Empty
  | T(_,x,_,_) -> x

  let deleteMin h = match h with
    E -> raise Empty
  | T(_,_,a,b) -> merge a b

end

module IntLeftistHeap = LeftistHeap(IntOrdered)

(* Uno heap binomiale *)

module BinomialHeap(Elt:ORDERED) : (HEAP with type t = Elt.t) =
struct
  type t = Elt.t

  type tree =  Node of int * t * tree list

  type heap = tree list

  let empty = []

  let isEmpty ts = match ts with
    [] -> true
  | _ -> false

  (* funzioni private *)

  let rank t = match t with
    Node(r,_,_) -> r

  let root t = match t with
    Node(_,x,_) -> x

  (* questa funzione la applichiamo solo ad alberi di rango uguale *)
  let link t1 t2 = match (t1,t2) with
    (Node(r,x1,c1),Node(_,x2,c2)) ->
      if (Elt.leq(x1,x2)) then Node(r + 1,x1,t1 :: c1)
      else Node(r + 1,x2,t1 :: c2)

  (* questo e' come aggiungere 1 a un numero binario *)
  let rec insTree t h = match h with
    [] -> [t]
    (* per come usiamo questa funzione, si ha sempre (rank t) <= (rank t') *)
  | t'::ts' -> if ((rank t) < (rank t')) then t :: h
               else insTree (link t t') ts'

  (* restituisce una coppia fatta dall'albero "t" dalla radice minima
     e da quel che resta della lista di alberi uno volta levato "t" *)
  let rec removeMinTree ts = match ts with
    [] -> raise Empty
  | [t] -> (t,[])
  | t :: ts' ->
      let (t',ts'') = removeMinTree ts'
      in if Elt.leq(root t,root t') then (t,ts')
         else (t',t :: ts'')

  (* inverte una lista *)
  let rec reverse_aux lst acc = match lst with
    [] -> acc
  | hd :: tl -> reverse_aux tl (hd :: acc)

  let reverse lst = reverse_aux lst []

  (* funzioni di interfaccia *)

  let insert x ts = insTree (Node(0,x,[])) ts

  (* questo e' come la somma di due numeri binari *)
  let rec merge ts1 ts2 = match (ts1,ts2) with
    (ts1,[]) -> ts1
  | ([],ts2) -> ts2
  | (t1 :: ts1',t2 :: ts2') ->
      if ((rank t1) < (rank t2)) then t1 :: merge ts1' ts2
      else if ((rank t2) < (rank t1)) then t2 :: merge ts1 ts2'
      (* qui e' come se mettessimo uno zero nella somma di due
         numeri binari. Quindi la prossima volta il riporto non andra'
         oltre questo punto, il che giustifica il costo O(log n) *)
      else insTree (link t1 t2) (merge ts1' ts2')

  let findMin ts = let (t,_) = removeMinTree ts in root t

  let deleteMin ts =
    let (Node(_,_,ts1),ts2) = removeMinTree ts
    in merge (reverse ts1) ts2

end

module IntBinomialHeap = BinomialHeap(IntOrdered)