4 files changed, 342 insertions, 0 deletions
diff --git a/Data/Heap/Binary.hs b/Data/Heap/Binary.hs
new file mode 100644
index 0000000..c9bd084
--- /dev/null
+++ b/Data/Heap/Binary.hs
@@ -0,0 +1,76 @@
+--
+-- Copyright (c) 2009 Brendan Hickey - http://bhickey.net
+-- Simplified BSD License (see http://www.opensource.org/licenses/bsd-license.php)
+--
+
+-- | 'Data.Heap.Binary' provides a binary min-heap. Balance is maintained through descendant counting.
+module Data.Heap.Binary 
+(BinaryHeap, head, tail, merge, singleton, empty, null, fromList, toList, insert) 
+where
+
+import Prelude hiding (head, tail, null)
+
+data (Ord n) => BinaryHeap n =
+    Leaf
+  | Node n Int (BinaryHeap n) (BinaryHeap n) deriving (Eq, Ord)
+
+instance (Ord n, Show n) => Show (BinaryHeap n) where
+  show Leaf = "Leaf"
+  show (Node n _ h1 h2) = "Node " ++ (show n) ++ " (" ++ (show h1) ++ " " ++ (show h2) ++ ")"
+
+rank :: (Ord n) => BinaryHeap n -> Int
+rank Leaf = 0
+rank (Node _ d _ _) = d
+
+-- | /O(1)/. 'empty' produces an empty heap.
+empty :: (Ord a) => BinaryHeap a
+empty = Leaf 
+
+-- | /O(1)/. 'singleton' consumes an element and constructs a singleton heap.
+singleton :: (Ord a) => a -> BinaryHeap a
+singleton a = Node a 1 Leaf Leaf
+
+-- | 'merge' consumes two binary heaps and merges them.
+merge :: (Ord a) => BinaryHeap a -> BinaryHeap a -> BinaryHeap a
+merge Leaf n = n
+merge n Leaf = n
+merge h1@(Node n1 d1 h1l h1r) h2@(Node _ d2 _ _) = 
+  if head h1 == head h2 || h1 <= h2
+  then if rank h1l < rank h1r
+       then (Node n1 (d1 + d2) (merge h1l h2) h1r)
+       else (Node n1 (d1 + d2) h1l (merge h1r h2))
+  else merge h2 h1
+
+-- | /O(lg n)/.
+insert :: (Ord a) => BinaryHeap a -> a -> BinaryHeap a
+insert h a = merge h (singleton a)
+
+-- | /O(1)/.
+null :: (Ord a) => BinaryHeap a -> Bool
+null Leaf = True
+null _    = False
+
+-- | /O(n lg n)/.
+toList :: (Ord a) => BinaryHeap a -> [a]
+toList Leaf = []
+toList h@(Node _ _ _ _) = (head h):(toList $ tail h)
+
+-- | /O(n)/. 'fromList' constructs a binary heap from an unsorted list.
+fromList :: (Ord a) => [a] -> BinaryHeap a
+fromList [] = Leaf
+fromList l =  (\ ((hd:_):_) -> hd) $! dropWhile (\ x -> length x > 1) $ iterate (pairWise merge) $ map singleton l
+
+pairWise :: (a -> a -> a) -> [a] -> [a] 
+pairWise _ [] = []
+pairWise f (a:b:tl) = (f a b):(pairWise f tl)
+pairWise _ a = a
+
+-- | /O(1)/. 'head' returns the element root of the heap.
+head :: (Ord a) => BinaryHeap a -> a
+head Leaf = error "Data.Tree.Heap: empty list"
+head (Node n _ _ _) = n
+
+-- | /O(lg n)/. 'tail' discards the root of the heap and merges the subtrees.
+tail :: (Ord a) => BinaryHeap a -> BinaryHeap a
+tail Leaf = error "Data.Heap empty list"
+tail (Node _ _ h1 h2) = merge h1 h2
diff --git a/Data/Heap/Binomial.hs b/Data/Heap/Binomial.hs
new file mode 100644
index 0000000..f705789
--- /dev/null
+++ b/Data/Heap/Binomial.hs
@@ -0,0 +1,106 @@
+--
+-- Copyright (c) 2009 Brendan Hickey - http://bhickey.net
+-- Simplified BSD License (see http://www.opensource.org/licenses/bsd-license.php)
+--
+
+module Data.Heap.Binomial 
+(BinomialHeap, head, tail, merge, singleton, empty, null, fromList, toList, insert) 
+where
+
+import Prelude hiding (head, tail, null)
+import Data.List (delete)
+
+data (Ord a, Ord b, Eq a, Eq b) => HeapNode a b = HeapNode a Int [b]
+
+data (Ord a, Eq a) => BinomialHeap a = 
+    EmptyHeap
+  | Heap [HeapNode a (BinomialHeap a)] deriving (Eq, Ord)
+
+instance (Ord a, Ord b, Eq a, Eq b) => Ord (HeapNode a b) where
+  compare (HeapNode e1 _ _) (HeapNode e2 _ _) = compare e1 e2
+
+instance (Ord a, Ord b, Eq a, Eq b) => Eq (HeapNode a b) where
+  (HeapNode e1 _ _) == (HeapNode e2 _ _) = e1 == e2
+ 
+rank :: (Ord a, Ord b, Eq a, Eq b) => HeapNode a b -> Int
+rank (HeapNode _ n _) = n
+
+hRank :: (Ord a, Ord b, Eq a, Eq b) => [HeapNode a b] -> Int
+hRank [] = 0
+hRank (hd:_) = rank hd
+
+extract :: (Ord a, Ord b, Eq a, Eq b) => HeapNode a b -> a
+extract (HeapNode n _ _) = n
+
+empty :: (Ord a) => BinomialHeap a
+empty = EmptyHeap
+
+null :: (Ord a) => BinomialHeap a -> Bool
+null EmptyHeap = True
+null _         = False
+
+-- | /O(1)/.
+singleton :: (Ord a) => a -> BinomialHeap a
+singleton n = Heap [HeapNode n 1 []]
+
+-- | /O(lg n)/
+insert :: (Ord a) => BinomialHeap a -> a -> BinomialHeap a
+insert h n = merge (singleton n) h
+
+-- | /O(lg n)/.
+merge :: (Ord a) => BinomialHeap a -> BinomialHeap a -> BinomialHeap a
+merge EmptyHeap n = n
+merge n EmptyHeap = n
+merge (Heap h1) (Heap h2) = Heap $! (mergeNodes h1 h2)
+
+mergeNodes :: (Ord a, Eq a) => [HeapNode a (BinomialHeap a)] -> [HeapNode a (BinomialHeap a)] -> [HeapNode a (BinomialHeap a)]
+mergeNodes [] h  = h
+mergeNodes h  [] = h
+mergeNodes f@(h1:t1) s@(h2:t2) =
+ if rank h1 == rank h2
+ then let merged = (combine h1 h2) 
+          r = rank merged in
+      if r /= hRank t1
+      then if r /= hRank t2
+           then merged:(mergeNodes t1 t2)
+           else mergeNodes (merged:t1) t2
+      else if r /= hRank t2
+           then mergeNodes t1 (merged:t2)
+           else merged:(mergeNodes t1 t2)
+ else if rank h1 < rank h2
+      then h1:(mergeNodes t1 s)
+      else h2:(mergeNodes t2 f)
+
+combine :: (Ord a, Eq a) => HeapNode a (BinomialHeap a) -> HeapNode a (BinomialHeap a) -> HeapNode a (BinomialHeap a)
+combine h1@(HeapNode e1 n1 l1) h2 =
+  if h1 <= h2
+  then HeapNode e1 (n1 + 1) (l1 ++ [Heap [h2]])
+  else combine h2 h1
+
+-- | /O(lg n)/
+head :: (Ord a) => BinomialHeap a -> a
+head EmptyHeap = error "Data.Heap: empty list"
+head (Heap hn) = extract $! minimum hn
+
+-- | /O(lg n)/
+tail :: (Ord a) => BinomialHeap a -> BinomialHeap a
+tail EmptyHeap = error "Data.Heap: empty list"
+tail (Heap hn) = 
+  let n@(HeapNode _ _ hd) = (minimum hn) in
+    foldl merge (Heap (delete n hn)) hd
+
+-- | /O(n)/
+fromList :: (Ord a, Eq a) => [a] -> BinomialHeap a
+fromList [] = EmptyHeap
+fromList l =  (\ ((hd:_):_) -> hd) $ dropWhile (\ x -> length x > 1) $ iterate (pairWise merge) $! map singleton l
+
+pairWise :: (a -> a -> a) -> [a] -> [a] 
+pairWise _ [] = []
+pairWise f (a:b:tl) = (f a b):(pairWise f tl)
+pairWise _ a = a
+
+-- | /O(n lg n)/
+toList :: (Ord a) => BinomialHeap a -> [a]
+toList EmptyHeap  = []
+toList (Heap [])  = []
+toList h@(Heap _) = (head h):(toList $ if null h then h else tail h)
diff --git a/Data/Heap/Skew.hs b/Data/Heap/Skew.hs
new file mode 100644
index 0000000..b97f55f
--- /dev/null
+++ b/Data/Heap/Skew.hs
@@ -0,0 +1,63 @@
+--
+-- Copyright (c) 2009 Brendan Hickey - http://bhickey.net
+-- Simplified BSD License (see http://www.opensource.org/licenses/bsd-license.php)
+--
+
+module Data.Heap.Skew 
+(SkewHeap, head, tail, merge, singleton, empty, null, fromList, toList, insert) 
+where
+
+import Prelude hiding (head, tail, null)
+import qualified Data.List as L
+
+data (Ord a) => SkewHeap a =
+    SkewLeaf
+  | SkewHeap a (SkewHeap a) (SkewHeap a) deriving (Eq, Ord)
+
+empty :: (Ord a) => SkewHeap a
+empty = SkewLeaf
+
+null :: (Ord a) => SkewHeap a -> Bool
+null SkewLeaf = True
+null _ = False
+
+singleton :: (Ord a) => a -> SkewHeap a
+singleton n = SkewHeap n SkewLeaf SkewLeaf
+
+insert :: (Ord a) => SkewHeap a -> a -> SkewHeap a
+insert h a = merge h (singleton a)
+
+merge :: (Ord a) => SkewHeap a -> SkewHeap a -> SkewHeap a
+merge SkewLeaf n = n
+merge n SkewLeaf = n
+merge h1 h2 = foldl1 assemble $ L.sortBy (\ x y -> compare y x) $ (cutRight h1) ++ (cutRight h2)
+
+cutRight :: (Ord a) => SkewHeap a -> [SkewHeap a]
+cutRight SkewLeaf = []
+cutRight (SkewHeap a l r) = (SkewHeap a l SkewLeaf):(cutRight r)
+
+-- assumes h1 >= h2, merge relies on this
+assemble :: (Ord a) => SkewHeap a -> SkewHeap a -> SkewHeap a
+assemble h1 (SkewHeap a l SkewLeaf) = SkewHeap a h1 l
+assemble _ _ = error "invalid heap assembly"
+
+head :: (Ord a) => SkewHeap a -> a
+head SkewLeaf = error "head of empty heap"
+head (SkewHeap a _ _) = a
+
+tail :: (Ord a) => SkewHeap a -> SkewHeap a
+tail SkewLeaf = error "tail of empty heap"
+tail (SkewHeap _ l r) = merge l r
+
+toList :: (Ord a) => SkewHeap a -> [a]
+toList SkewLeaf = []
+toList (SkewHeap n l r) = n:(toList $ merge l r)
+
+fromList :: (Ord a) => [a] -> SkewHeap a
+fromList [] = SkewLeaf
+fromList l =  (\ ((hd:_):_) -> hd) $! dropWhile (\ x -> length x > 1) $ iterate (pairWise merge) $ map singleton l
+
+pairWise :: (a -> a -> a) -> [a] -> [a] 
+pairWise _ [] = []
+pairWise f (a:b:tl) = (f a b):(pairWise f tl)
+pairWise _ a = a
diff --git a/Data/Tree/Splay.hs b/Data/Tree/Splay.hs
new file mode 100644
index 0000000..496ffac
--- /dev/null
+++ b/Data/Tree/Splay.hs
@@ -0,0 +1,97 @@
+--
+-- Copyright (c) 2009 Brendan Hickey - http://bhickey.net
+-- Simplified BSD License (see http://www.opensource.org/licenses/bsd-license.php)
+--
+
+module Data.Tree.Splay 
+(SplayTree, head, tail, singleton, empty, null, fromList, fromAscList, toList, toAscList, insert, lookup) 
+where
+
+import Prelude hiding (head, tail, lookup, null)
+
+data (Ord k) => SplayTree k v = 
+    Leaf
+  | SplayTree k v (SplayTree k v) (SplayTree k v) deriving (Ord, Eq)
+
+-- | /O(1)/. 'singleton' constructs a splay tree containing one element.
+singleton :: (Ord k) => (k,v) -> SplayTree k v
+singleton (k,v) = SplayTree k v Leaf Leaf
+
+-- | /O(1)/. 'empty' constructs an empty splay tree.
+empty :: (Ord k) => SplayTree k v
+empty = Leaf
+
+-- | /O(1)/. 'null' returns true if a splay tree is empty.
+null :: (Ord k) => SplayTree k v -> Bool
+null Leaf = True
+null _ = False
+
+
+-- | /Amortized O(lg n)/. Given a splay tree and a key, 'lookup' attempts to find a node with the specified key and splays this node to the root. If the key is not found, the nearest node is brought to the root of the tree.
+lookup :: (Ord k) => SplayTree k v -> k -> SplayTree k v
+lookup Leaf _ = Leaf
+lookup n@(SplayTree k v l r) sk =
+  if sk == k
+  then n
+  else if k > sk
+       then case lookup l sk of
+              Leaf -> n
+              (SplayTree k1 v1 l1 r1) -> (SplayTree k1 v1 l1 (SplayTree k v r1 r))
+       else case lookup r sk of
+              Leaf -> n
+              (SplayTree k1 v1 l1 r1) -> (SplayTree k1 v1 (SplayTree k v l l1) r1)
+
+-- | /Amortized O(lg n)/. Given a splay tree and a key-value pair, 'insert' places the the pair into the tree in BST order.
+insert :: (Ord k) => SplayTree k v -> (k,v) -> SplayTree k v
+insert t (k,v) =
+  case lookup t k of
+    Leaf -> (SplayTree k v Leaf Leaf)
+    (SplayTree k1 v1 l r) ->
+        if k1 < k
+        then (SplayTree k v (SplayTree k1 v1 l Leaf) r)
+        else (SplayTree k v l (SplayTree k1 v1 Leaf r))
+
+
+-- | /O(1)/. 'head' returns the key-value pair of the root.
+head :: (Ord k) => SplayTree k v -> (k,v)
+head Leaf = error "head of empty tree"
+head (SplayTree k v _ _) = (k,v)
+
+-- | /Amortized O(lg n)/. 'tail' removes the root of the tree and merges its subtrees
+tail :: (Ord k) => SplayTree k v -> SplayTree k v
+tail Leaf = error "tail of empty tree"
+tail (SplayTree _ _ Leaf r) = r
+tail (SplayTree _ _ l Leaf) = l
+tail (SplayTree _ _ l r)    = 
+  case splayRight l of
+    (SplayTree k v l1 Leaf) -> (SplayTree k v l1 r)
+    _ -> error "splay tree corruption"
+
+splayRight :: (Ord k) => SplayTree k v -> SplayTree k v
+splayRight Leaf = Leaf
+splayRight h@(SplayTree _ _ _ Leaf) = h
+splayRight (SplayTree k1 v1 l1 (SplayTree k2 v2 l2 r2))  = splayRight $ (SplayTree k2 v2 (SplayTree k1 v1 l1 l2) r2)
+
+splayLeft :: (Ord k) => SplayTree k v -> SplayTree k v
+splayLeft Leaf = Leaf
+splayLeft h@(SplayTree _ _ Leaf _) = h
+splayLeft (SplayTree k1 v1 (SplayTree k2 v2 l2 r2) r1)  = splayLeft $ (SplayTree k2 v2 l2 (SplayTree k1 v1 r2 r1))
+
+-- | /O(n lg n)/. Constructs a splay tree from an unsorted list of key-value pairs.
+fromList :: (Ord k) => [(k,v)] -> SplayTree k v
+fromList [] = Leaf
+fromList l = foldl (\ acc x -> insert acc x) Leaf l
+
+-- | /O(n lg n)/. Constructs a splay tree from a list of key-value pairs sorted in ascending order.
+fromAscList :: (Ord k) => [(k,v)] -> SplayTree k v
+fromAscList = fromList
+
+-- | /O(n lg n)/. Converts a splay tree into a list of key-value pairs with no constraint on ordering.
+toList :: (Ord k) => SplayTree k v -> [(k,v)]
+toList = toAscList
+
+-- | /O(n lg n)/. 'toAscList' converts a splay tree to a list of key-value pairs sorted in ascending order.
+toAscList :: (Ord k) => SplayTree k v -> [(k,v)]
+toAscList h@(SplayTree _ _ Leaf _) = (head h):(toAscList $ tail h)
+toAscList Leaf = []
+toAscList h = toAscList $ splayLeft h