Hierarchy Tree

gistfile1.ml

(* hierarchy tree, with root larger than any child and insertion order maintained. *)
type 'a htree = X | R of ('a * int) * 'a htree * 'a htree

let rec htree_insert (_,p as v) = function
  | X -> R (v,X,X)
  | R ((_,q as w),l,r) when q > p -> R(w,l,htree_insert v r)
  | R _ as w -> R(v,w,X)

let rec consume_hts def l r = match l,r,def with
  | X,X,_ -> []
  | (X as l1 as r1),R(v2,l2,r2), v1
  | R(v1,l1,r1),(X as l2 as r2), v2
  | R(v1,l1,r1),R(v2,l2,r2),_ -> 
    consume_hts def l1 l2 @ ((v1,v2) :: consume_hts def r1 r2)

(* TODO: investigate alternate pairings *)
let gen_pairings def l r =
  let lht = List.fold_left (flip htree_insert) X l in
  let rht = List.fold_left (flip htree_insert) X r in
  consume_hts def lht rht