diff options
Diffstat (limited to 'Data')
-rw-r--r-- | Data/Heap/Binary.hs | 76 | ||||
-rw-r--r-- | Data/Heap/Binomial.hs | 106 | ||||
-rw-r--r-- | Data/Heap/Skew.hs | 63 | ||||
-rw-r--r-- | Data/Tree/Splay.hs | 97 |
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 |