(* Homework number 6
* by Marek Kubica *)
(* type definitions for heaps:
* a binomial tree
* a list of binomial trees *)
type 'a bTree = { order : int; root : 'a; children : 'a bTree list }
type 'a bHeap = 'a bTree list
(* orders bTrees by root value: smaller first, larger second *)
let order_by_root a b = match a, b with
| (a, b) when a.root < b.root -> (a, b)
| (a, b) -> (b, a)
(* helper function, determines which bTree has a smaller root *)
let min_root a b = let smaller, _ = (order_by_root a b) in smaller
(* merges two trees into one by moving the one with smaller root
* to the top and adding the other to the children *)
let mergeTrees a b = match (order_by_root a b) with
| (smaller, larger) when smaller.order = larger.order ->
{order=smaller.order+1; root=smaller.root; children=larger::smaller.children}
| _ -> raise (Invalid_argument "Orders don't match")
(* inserts a tree into a binomial heap
* this is the heart of the whole homework: makes sure that there
* are never multiple trees with the same order in one level *)
let rec insertTree tree heap = match heap with
| [] -> [tree]
| x::xs when tree.order < x.order -> tree::heap
| x::xs when tree.order = x.order -> insertTree (mergeTrees tree x) xs
| x::xs -> x::(insertTree tree xs)
(* insertion is easy: just wrap into a tree and insert the tree int the heap *)
let insert element heap = insertTree {order=0; root=element; children=[]} heap
(* merges two heaps together *)
let rec merge a b = match a, b with
| ([], b) -> b
| (a, []) -> a
| (x::xs, y::ys) when x.order = y.order -> insertTree (mergeTrees x y) (merge xs ys)
| (x::xs, y::ys) -> insertTree y (insertTree x (merge xs ys))
(* an exception that will be raised when an empty stack gets passed *)
exception HeapEmpty
(* cuts out the minimal tree.
* goes through the list, checking the root. if the current element
* is smaller than the previously smallest element, insert the previous
* element back into the list and take the current element as new
* smallest element *)
let rec separate_min_tree heap = match heap with
| [] -> raise HeapEmpty
| [x] -> (x, [])
| x::xs -> match separate_min_tree xs with
| (y, ys) when x.root < y.root -> (x, insertTree y ys)
| (y, ys) -> (y, x::ys)
(* get the value of the element that is the smallest *)
let find_min heap = match heap with
| [] -> raise HeapEmpty
| x::xs -> (List.fold_left min_root x xs).root
(* deletes and returns the smallest element from a heap *)
let delete_min heap =
let mintree, restheap = (separate_min_tree heap) in
merge mintree.children restheap