Skip to content


Subversion checkout URL

You can clone with
Download ZIP
Fetching contributors…
Cannot retrieve contributors at this time
140 lines (101 sloc) 4.49 KB
FibonacciHeap.hs, Binomial Heap in Haskell
Copyright (C) 2010, Liu Xinyu (
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see <>.
-- Fibonacci heap is a kind of lazy Binomial heap.
module FibonacciHeap where
import Test.QuickCheck
import qualified Data.List as L -- for verification purpose only.
-- 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
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 delay 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 melding all trees in same rank
-- O(lg N) time
consolidate :: (Ord a) => [BiTree a] -> [BiTree a]
consolidate = foldl meld [] where
meld [] t = [t]
meld (t':ts) t | rank t == rank t' = meld ts (link t t')
| rank t < rank t' = t:t':ts
| otherwise = t' : meld ts t
-- 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')
(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
-- This function performs badly because it actually create a linked-list
-- The ideal way is to insert and delete randomly, so that the amortized
-- performance dominate.
fromList :: (Ord a) => [a] -> FibHeap a
fromList = foldl insert E
-- This testing has the same problem with fromList, as it actually
-- first create a linked-list, then during deleteMin, it start merge
-- them to Binomial heap, the first consolidation takes very long time.
heapSort :: (Ord a) => [a] -> [a]
heapSort = hsort . fromList where
hsort E = []
hsort h = (findMin h):(hsort $ deleteMin h)
-- test
prop_sort :: [Int] -> Bool
prop_sort xs = heapSort xs == L.sort xs
Jump to Line
Something went wrong with that request. Please try again.