[Haskell-cafe] Fibonacci Heap without using Monad

[larry.liuxinyu]

Hi,

I checked the current Fibonacci Queue in Hackage DB:
http://hackage.haskell.org/packages/archive/pqueue-mtl/1.0.7/doc/html/src/Data-Queue-FibQueue.html#FQueue

And a history email for Okasaki in 1995:
http://darcs.haskell.org/nofib/gc/fibheaps/orig

The hardest part is how to consolidate all unordered binomial trees in
deleteMin.
In imperative implementation, there is a elegant algorithm introduced
in Chapter 20 of CLRS[1].

How to achieve it in Functional way is the key point of solve this
problem.

If we have a list of trees with rank [2, 1, 1, 4, 8, 1, 1, 2, 4], we
need first meld the trees with same rank, and recursively doing that
until there are no two trees with same rank. Here is a simple function
can do this:

consolidate:: (Num a)=>[a] -> [a]
consolidate xs = foldl meld [] xs where
    meld :: (Num a)=>[a] -> a -> [a]
    meld [] x = [x]
    meld (x':xs) x = if x == x' then meld xs (x+x')
                     else x:x':xs

Generalize the `+` to link and `==` to compare rank yields the
solution.

Below are my literate source code with some description. For the
details of Binomial heap, please refer to Okasaki's ``Purely
Functional data structures''[2].

-- Definition

-- Since Fibonacci Heap can be achieved by applying lazy strategy
-- to Binomial heap. We use the same definition of tree as the
-- Binomial heap. That each tree contains:
--   a rank (size of the tree)
--   the root value (the element)
--   and the children (all sub trees)

data BiTree a = Node { rank :: Int
                     , root :: a
                     , children :: [BiTree a]} deriving (Eq, Show)


-- Different with Binomial heap, Fibonacci heap is consist of
-- unordered binomial trees. Thus in order to access the
-- minimum value in O(1) time, we keep the record of the tree
-- which holds the minimum value out off the other children trees.
-- We also record the size of the heap, which is the sum of all ranks
-- of children and minimum tree.

data FibHeap a = E | FH { size :: Int
                        , minTree :: BiTree a
                        , trees :: [BiTree a]} deriving (Eq, Show)

-- Auxiliary functions

-- Singleton creates a leaf node and put it as the only tree in the
heap

singleton :: a -> FibHeap a
singleton x = FH 1 (Node 1 x []) []

-- Link 2 trees with SAME rank R to a new tree of rank R+1, we re-use
the code
--   for Binomial heaps

link :: (Ord a) => BiTree a -> BiTree a -> BiTree a
link t1@(Node r x c1) t2@(Node _ y c2)
    | x<y = Node (r+1) x (t2:c1)
    | otherwise = Node (r+1) y (t1:c2)

-- Insertion, runs in O(1) time.

insert :: (Ord a) => FibHeap a -> a -> FibHeap a
insert h x = merge h (singleton x)

-- Merge, runs in O(1) time.

-- Different from Binomial heap, we don't consolidate the sub trees
-- with the same rank, we delayed it later when performing delete-
Minimum.

merge:: (Ord a) => FibHeap a -> FibHeap a -> FibHeap a
merge h E = h
merge E h = h
merge h1@(FH sz1 minTr1 ts1) h2@(FH sz2 minTr2 ts2)
    | root minTr1 < root minTr2 = FH (sz1+sz2) minTr1 (minTr2:ts2+
+ts1)
    | otherwise = FH (sz1+sz2) minTr2 (minTr1:ts1++ts2)

-- Find Minimum element in O(1) time

findMin :: (Ord a) => FibHeap a -> a
findMin = root . minTree

-- deleting, Amortized O(lg N) time

-- Auxiliary function

-- Consolidate unordered Binomial trees by meld all trees in same rank
--  O(lg N) time

consolidate :: (Ord a) => [BiTree a] -> [BiTree a]
consolidate ts = foldl meld [] ts where
    meld [] t = [t]
    meld (t':ts) t = if rank t' == rank t then meld ts (link t t')
                     else t:t':ts

-- Find the tree which contains the minimum element.
-- Returns the minimum element tree and the left trees as a pair
--   O(lg N) time

extractMin :: (Ord a) => [BiTree a] -> (BiTree a, [BiTree a])
extractMin [t] = (t, [])
extractMin (t:ts) = if root t < root t' then (t, ts)
                        else (t', t:ts')
    where
      (t', ts') = extractMin ts

-- delete function

deleteMin :: (Ord a) => FibHeap a -> FibHeap a
deleteMin (FH _ (Node _ x []) []) = E
deleteMin h@(FH sz minTr ts) = FH (sz-1) minTr' ts' where
    (minTr', ts') = extractMin $ consolidate (children minTr ++ ts)

-- Helper functions

fromList :: (Ord a) => [a] -> FibHeap a
fromList xs = foldl insert E xs

-- general heap sort function, can be re-used for any heap

heapSort :: (Ord a) => [a] -> [a]
heapSort = hsort . fromList where
    hsort E = []
    hsort h = (findMin h):(hsort $ deleteMin h)

-- test

testFromList = fromList [16, 14, 10, 8, 7, 9, 3, 2, 4, 1]

testHeapSort = heapSort [16, 14, 10, 8, 7, 9, 3, 2, 4, 1]

Below are the test results in GHC.

*FibonacciHeap> testFromList
FH {size = 10, minTree = Node {rank = 1, root = 1, children = []},
trees = [Node {rank = 1, root = 2, children = []},Node {rank = 1, root
= 4, children = []},Node {rank = 1, root = 3, children = []},Node
{rank = 1, root = 7, children = []},Node {rank = 1, root = 9, children
= []},Node {rank = 1, root = 8, children = []},Node {rank = 1, root =
10, children = []},Node {rank = 1, root = 14, children = []},Node
{rank = 1, root = 16, children = []}]}

*FibonacciHeap> testHeapSort
[1,2,3,4,7,8,9,10,14,16]

--
[1] Thomas H. Cormen, Charles E. Leiserson, Ronald L. Rivest and
Clifford Stein  ``Introduction to Algorithms, Second Edition'. The MIT
Press © 2001 (1180 pages) ISBN:
[2] Chris Okasaki. ``Purely Functional Data Structures''. Cambridge
university press, (July 1, 1999), ISBN-13: 978-0521663502