Hi,
I checked the current Fibonacci Queue in Hackage DB:
http://hackage.haskell.org/packages/archive/pqueue-mtl/1.0.7/doc/html/src/Da...
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 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
