-- Companion source code to
--     Chris Okasaki
--     "The Role of Lazy Evaluation in Amortized Data Structures"
--     ICFP'96

-- amortized binomial queues

-- insert takes O(1) amortized time
-- findMin, deleteMin, merge take O(log n) amortized time

data Tree a = Node a [Tree a]     -- children in decreasing order of size

type BinQueue a = [(Int,Tree a)]  -- trees in increasing order of size

emptyBQ :: BinQueue a
emptyBQ = []

isEmptyBQ :: BinQueue a -> Bool
isEmptyBQ = null

insertBQ :: Ord a => a -> BinQueue a -> BinQueue a
insertBQ x q = addUnique (1, Node x []) q

mergeBQ :: Ord a => BinQueue a -> BinQueue a -> BinQueue a
mergeBQ [] q = q
mergeBQ q [] = q
mergeBQ ((n1,t1) : q1) ((n2,t2) : q2)
    | n1 < n2  = (n1,t1) : mergeBQ q1 ((n2,t2) : q2)
    | n1 > n2  = (n2,t2) : mergeBQ ((n1,t1) : q1) q2
    | n1 == n2 = addUnique (n1+n2, link t1 t2) (mergeBQ q1 q2)

findMinBQ :: Ord a => BinQueue a -> a
findMinBQ = minimum . map (root . snd)  -- return the minimum root

deleteMinBQ :: Ord a => BinQueue a -> BinQueue a
deleteMinBQ q = mergeBQ c' q'
    where (Node x c, q') = getMin q
          c' = zip sizes (reverse c)  -- convert children into a valid BinQueue
          sizes = 1 : map (2 *) sizes -- [1,2,4,8,...]


-- auxiliary functions

root :: Tree a -> a
root (Node x c) = x

-- add a new tree and link until all sizes are unique
addUnique :: Ord a => (Int,Tree a) -> BinQueue a -> BinQueue a
addUnique (n,t) [] = [(n,t)]
addUnique (n,t) ((n',t') : q)
    | n < n'  = (n,t) : (n',t') : q
    | n == n' = addUnique (n+n', link t t') q

-- make the tree with the larger root a child of the tree with the smaller root
link :: Ord a => Tree a -> Tree a -> Tree a
link (Node x c) (Node y d) | x <= y = Node x (Node y d : c)
                           | y < x  = Node y (Node x c : d)

-- find and remove the tree with the minimum root
getMin :: Ord a => BinQueue a -> (Tree a, BinQueue a)
getMin [(n,t)] = (t,[])
getMin ((n,t) : q) = let (t',q') = getMin q
                     in if root t <= root t' then (t,q) else (t', (n,t) : q')