├── .gitignore ├── BankersQueue.hs ├── BatchedQueue.hs ├── BinomialHeap.hs ├── FingerTree.hs ├── LICENSE ├── LeftistHeap.hs ├── README.md ├── Setup.hs └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | /.stack-work 2 | -------------------------------------------------------------------------------- /BankersQueue.hs: -------------------------------------------------------------------------------- 1 | module BankersQueue where 2 | 3 | data Queue a = Queue 4 | { lenWrite :: !Int 5 | , write :: [a] 6 | , lenRead :: !Int 7 | , read :: [a] } 8 | 9 | check :: Queue a -> Queue a 10 | check queue@(Queue {..}) 11 | | lenWrite > lenRead = Queue 0 [] (lenRead + lenWrite) (read ++ reverse write)) 12 | | otherwise = queue 13 | 14 | empty :: Queue a 15 | empty = Queue 0 [] 0 [] 16 | 17 | insert :: a -> Queue a -> Queue a 18 | insert a (Queue {..}) = check (Queue (lenWrite + 1) (a : write) lenRead read) 19 | 20 | 21 | view :: Queue a -> (a, Queue a) 22 | view (Queue {..}) = case read of 23 | [] -> error "Empty queue" 24 | a : read' -> (a, check (Queue lenWrite write (lenRead - 1) read')) 25 | -------------------------------------------------------------------------------- /BatchedQueue.hs: -------------------------------------------------------------------------------- 1 | module BatchedQueue where 2 | 3 | data Queue a = Queue [a] [a] 4 | 5 | check :: Queue a -> Queue a 6 | check (Queue write []) = Queue [] (reverse write) 7 | check queue = queue 8 | 9 | empty :: Queue a 10 | empty = Queue [] [] 11 | 12 | insert :: a -> Queue a -> Queue a 13 | insert a (Queue write read) = check (Queue (a : write) read) 14 | 15 | view :: Queue a -> (a, Queue a) 16 | view (Queue write (a : read')) = (a, check (Queue write read')) 17 | -------------------------------------------------------------------------------- /BinomialHeap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | module BinomialHeap where 3 | 4 | import Prelude hiding (head, tail, (++)) 5 | 6 | -- | Invariants: 7 | -- 8 | -- * The 'forest' of a 'Tree' of 'rank' r contains exactly r trees of 'rank' r-1, …, 0 9 | -- * A 'Tree' of 'rank' n contains exactly 2^n elements 10 | -- * Elements are in heap order ('root' is the smallest element) 11 | data Tree a = Node 12 | { rank :: !Int 13 | , root :: a 14 | , forest :: ![Tree a] } 15 | 16 | -- | Always link trees of equal rank! 17 | link :: Ord a => Tree a -> Tree a -> Tree a 18 | link left right 19 | | rank left /= rank right = error "Only link trees of equal rank" 20 | | root left <= root right = Node rank' (root left) (right : forest left) 21 | | otherwise = Node rank' (root right) (left : forest right) 22 | where rank' = rank left + 1 23 | 24 | 25 | 26 | -- | Invariants: 27 | -- * The trees are stored by increasing rank 28 | newtype Heap a = Heap [Tree a] 29 | 30 | 31 | insert :: Ord a => a -> Heap a -> Heap a 32 | insert a (Heap trees) = Heap (insertTree (Node 0 a []) trees) 33 | 34 | insertTree :: Ord a => Tree a -> [Tree a] -> [Tree a] 35 | insertTree s [] = [s] 36 | insertTree s (t : ts) 37 | | rank s < rank t -- found a free spot 38 | = s : t : ts 39 | | otherwise -- must be equal rank (because of sorting) => carry 40 | = insertTree (link s t) ts 41 | 42 | 43 | merge :: Ord a => Heap a -> Heap a -> Heap a 44 | merge (Heap left) (Heap right) = Heap (mergeTrees left right) 45 | 46 | mergeTrees :: Ord a => [Tree a] -> [Tree a] -> [Tree a] 47 | mergeTrees left [] = left 48 | mergeTrees [] right = right 49 | mergeTrees (l:ls) (r:rs) 50 | | rank l > rank r = l : mergeTrees ls (r:rs) 51 | | rank l < rank r = r : mergeTrees (l:ls) rs 52 | | otherwise = link l r : mergeTrees ls rs 53 | 54 | 55 | viewMin :: Ord a => Heap a -> Maybe (a, Heap a) 56 | viewMin (Heap []) = Nothing 57 | viewMin (Heap trees) = Just (root minTree, Heap rest) 58 | 59 | where (minTree, trees') = findMinTree trees 60 | rest = mergeTrees trees' (reverse (forest minTree)) 61 | 62 | findMinTree :: Ord a => [Tree a] -> (Tree a, [Tree a]) 63 | findMinTree [t] = (t, []) 64 | findMinTree (t : ts) 65 | | root t < root t' = (t, ts) 66 | | otherwise = (t', t:ts') 67 | where (t', ts') = findMinTree ts 68 | -------------------------------------------------------------------------------- /FingerTree.hs: -------------------------------------------------------------------------------- 1 | module FingerTree where 2 | 3 | import Prelude hiding (lookup) 4 | 5 | data FingerTree a 6 | = Empty 7 | | Single a 8 | | Deep !Int !(Digit a) (FingerTree (Node a)) !(Digit a) 9 | 10 | data Digit a = One a | Two a a | Three a a a | Four a a a a 11 | 12 | data Node a = Node2 a a | Node3 a a a 13 | 14 | class Sized a where 15 | size :: a -> Int 16 | 17 | instance Sized a => Sized (FingerTree a) where 18 | size Empty = 0 19 | size (Single a) = size a 20 | size (Deep s _ _ _) = s 21 | 22 | instance Sized a => Sized (Digit a) where 23 | size (One a) = size a 24 | size (Two a b) = size a + size b 25 | size (Three a b c) = size a + size b + size c 26 | size (Four a b c d) = size a + size b + size c + size d 27 | 28 | instance Sized a => Sized (Node a) where 29 | size (Node2 a b) = size a + size b 30 | size (Node3 a b c) = size a + size b + size c 31 | 32 | instance Sized a => Sized (Maybe a) where 33 | size Nothing = 0 34 | size (Just a) = size a 35 | 36 | deep :: Sized a => Digit a -> FingerTree (Node a) -> Digit a -> FingerTree a 37 | deep l t r = Deep (size l + size t + size r) l t r 38 | 39 | {-| 40 | >>> toList (cons (E 1) (cons (E 2) (cons (E 3) Empty))) :: [Int] 41 | [1,2,3] 42 | 43 | >>> toList (cons (E 5) (fromList [4,3,2,1])) :: [Int] 44 | [5,4,3,2,1] 45 | -} 46 | cons :: Sized a => a -> FingerTree a -> FingerTree a 47 | cons a Empty = Single a 48 | cons a (Single b) = deep (One a) Empty (One b) 49 | cons a (Deep s l t r) = case l of 50 | One b -> Deep s' (Two a b) t r 51 | Two b c -> Deep s' (Three a b c) t r 52 | Three b c d -> Deep s' (Four a b c d) t r 53 | Four b c d e -> t `seq` -- Push a node down the spine 54 | -- Amortization: The spine has already been paid for, 55 | -- so we can force it to prevent memory leaks 56 | Deep s' (Two a b) (Node3 c d e `cons` t) r 57 | where s' = s + size a 58 | 59 | {-| 60 | >>> toList (snoc (fromList [1..19]) (E 20)) :: [Int] 61 | [1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20] 62 | -} 63 | snoc :: Sized a => FingerTree a -> a -> FingerTree a 64 | snoc Empty z = Single z 65 | snoc (Single y) z = deep (One y) Empty (One z) 66 | snoc (Deep s l t r) z = case r of 67 | One y -> Deep s' l t (Two y z) 68 | Two x y -> Deep s' l t (Three x y z) 69 | Three w x y -> Deep s' l t (Four w x y z) 70 | Four v w x y -> t `seq` 71 | Deep s' l (t `snoc` Node3 v w x) (Two x z) 72 | where s' = s + size z 73 | 74 | {-| 75 | >>> fmap (const ()) (viewL (fromList [])) 76 | Nothing 77 | 78 | >>> let Just (E a, t) = viewL (fromList [1]) in (a, toList t) 79 | (1,[]) 80 | 81 | >>> let Just (E a, t) = viewL (fromList [1,2,3]) in (a, toList t) 82 | (1,[2,3]) 83 | 84 | >>> let Just (E a, t) = viewL (fromList [1..100]) in (a, toList t) 85 | (1,[2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100]) 86 | -} 87 | viewL :: Sized a => FingerTree a -> Maybe (a, FingerTree a) 88 | viewL Empty = Nothing 89 | viewL (Single a) = Just (a, Empty) 90 | viewL (Deep s l t r) = Just $ case l of 91 | Four a b c d -> (a, Deep (s - size a) (Three b c d) t r) 92 | Three a b c -> (a, Deep (s - size a) (Two b c) t r) 93 | Two a b -> (a, Deep (s - size a) (One b) t r) 94 | One a -> case viewL t of -- Pull a node up from the spine 95 | Just (Node3 b c d, t') -> (a, Deep (s - size a) (Three b c d) t' r) 96 | Just (Node2 b c, t') -> (a, Deep (s - size a) (Two b c) t' r) 97 | Nothing -> case r of -- If the spine is empty, balance with the right digit 98 | Four b c d e -> (a, Deep (s - size a) (Two b c) Empty (Two d e)) 99 | Three b c d -> (a, Deep (s - size a) (Two b c) Empty (One d)) 100 | Two b c -> (a, Deep (s - size a) (One b) Empty (One c)) 101 | One b -> (a, Single b) 102 | 103 | {-| 104 | >>> fmap (const ()) (viewR (fromList [])) 105 | Nothing 106 | 107 | >>> let Just (t, E a) = viewR (fromList [1]) in (toList t, a) 108 | ([],1) 109 | 110 | >>> let Just (t, E a) = viewR (fromList [1,2,3]) in (toList t, a) 111 | ([1,2],3) 112 | 113 | >>> let Just (t, E a) = viewR (fromList [1..100]) in (toList t, a) 114 | ([1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99],100) 115 | -} 116 | viewR :: Sized a => FingerTree a -> Maybe (FingerTree a, a) 117 | viewR Empty = Nothing 118 | viewR (Single a) = Just (Empty, a) 119 | viewR (Deep s l t r) = Just $ case r of 120 | Four w x y z -> (Deep (s - size z) l t (Three w x y), z) 121 | Three x y z -> (Deep (s - size z) l t (Two x y), z) 122 | Two y z -> (Deep (s - size z) l t (One y), z) 123 | One z -> case viewR t of 124 | Just (t', Node3 w x y) -> (Deep (s - size z) l t' (Three w x y), z) 125 | Just (t', Node2 x y) -> (Deep (s - size z) l t' (Two x y), z) 126 | Nothing -> case l of 127 | Four v w x y -> (Deep (s - size z) (Two v w) Empty (Two x y), z) 128 | Three w x y -> (Deep (s - size z) (Two w x) Empty (One y), z) 129 | Two x y -> (Deep (s - size z) (One x) Empty (One y), z) 130 | One y -> (Single y, z) 131 | 132 | 133 | {-| 134 | Left tree contains items < pos, right tree items >= pos 135 | 136 | >>> let (l, E a, r) = split 0 (fromList [1,2,3,4,5]) in (toList l, a, toList r) 137 | ([],1,[2,3,4,5]) 138 | 139 | >>> let (l, E a, r) = split 1 (fromList [1,2,3,4,5]) in (toList l, a, toList r) 140 | ([],1,[2,3,4,5]) 141 | 142 | >>> let (l, E a, r) = split 2 (fromList [1,2,3,4,5]) in (toList l, a, toList r) 143 | ([1],2,[3,4,5]) 144 | 145 | >>> let (l, E a, r) = split 3 (fromList [1,2,3,4,5]) in (toList l, a, toList r) 146 | ([1,2],3,[4,5]) 147 | 148 | >>> let (l, E a, r) = split 4 (fromList [1,2,3,4,5]) in (toList l, a, toList r) 149 | ([1,2,3],4,[5]) 150 | 151 | >>> let (l, E a, r) = split 5 (fromList [1,2,3,4,5]) in (toList l, a, toList r) 152 | ([1,2,3,4],5,[]) 153 | 154 | >>> let (l, E a, r) = split 6 (fromList [1,2,3,4,5]) in (toList l, a, toList r) 155 | ([1,2,3,4],5,[]) 156 | 157 | >>> let (l, E a, r) = split 42 (fromList [1..100]) in (toList l, a, toList r) 158 | ([1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41],42,[43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100]) 159 | -} 160 | split :: Sized a => Int -> FingerTree a -> (FingerTree a, a, FingerTree a) 161 | split _ Empty = error "Cannot split an empty tree" 162 | split pos (Single a) = (Empty, a, Empty) 163 | split pos tree@(Deep s l t r) 164 | | slt < pos = let (rl, a, rr) = splitDigit (pos - slt) r 165 | in (deepR l t rl, a, maybe Empty digitToTree rr) 166 | | sl < pos = let (tl, n, tr) = split (pos - sl) t 167 | (nl, a, nr) = splitNode (pos - sl - size tl) n 168 | in (deepR l tl nl, a, deepL nr tr r) 169 | | otherwise = let (ll, a, lr) = splitDigit pos l 170 | in (maybe Empty digitToTree ll, a, deepL lr t r) 171 | where sl = size l 172 | slt = sl + size t 173 | 174 | splitDigit :: Sized a => Int -> Digit a -> (Maybe (Digit a), a, Maybe (Digit a)) 175 | splitDigit _ (One a) = (Nothing, a, Nothing) 176 | splitDigit pos (Two a b) 177 | | size a < pos = (Just (One a), b, Nothing) 178 | | otherwise = (Nothing, a, Just (One b)) 179 | splitDigit pos (Three a b c) 180 | | sab < pos = (Just (Two a b), c, Nothing) 181 | | sa < pos = (Just (One a), b, Just (One c)) 182 | | otherwise = (Nothing, a, Just (Two b c)) 183 | where sa = size a 184 | sab = sa + size b 185 | splitDigit pos (Four a b c d) 186 | | sabc < pos = (Just (Three a b c), d, Nothing) 187 | | sab < pos = (Just (Two a b), c, Just (One d)) 188 | | sa < pos = (Just (One a), b, Just (Two c d)) 189 | | otherwise = (Nothing, a, Just (Three b c d)) 190 | where sa = size a 191 | sab = sa + size b 192 | sabc = sab + size c 193 | 194 | splitNode :: Sized a => Int -> Node a -> (Maybe (Digit a), a, Maybe (Digit a)) 195 | splitNode pos (Node2 a b) 196 | | size a < pos = (Just (One a), b, Nothing) 197 | | otherwise = (Nothing, a, Just (One b)) 198 | splitNode pos (Node3 a b c) 199 | | sab < pos = (Just (Two a b), c, Nothing) 200 | | sa < pos = (Just (One a), b, Just (One c)) 201 | | otherwise = (Nothing, a, Just (Two b c)) 202 | where sa = size a 203 | sab = sa + size b 204 | 205 | deepL :: Sized a => Maybe (Digit a) -> FingerTree (Node a) -> Digit a -> FingerTree a 206 | deepL (Just l) t r = deep l t r 207 | deepL Nothing t r = case viewL t of 208 | Just (Node3 a b c, t') -> deep (Three a b c) t' r 209 | Just (Node2 a b, t') -> deep (Two a b) t' r 210 | Nothing -> digitToTree r 211 | 212 | deepR :: Sized a => Digit a -> FingerTree (Node a) -> Maybe (Digit a) -> FingerTree a 213 | deepR l t (Just r) = deep l t r 214 | deepR l t Nothing = case viewR t of 215 | Just (t', Node3 x y z) -> deep l t' (Three x y z) 216 | Just (t', Node2 y z) -> deep l t' (Two y z) 217 | Nothing -> digitToTree l 218 | 219 | digitToTree :: Sized a => Digit a -> FingerTree a 220 | digitToTree (One a) = Single a 221 | digitToTree (Two a b) = deep (One a) Empty (One b) 222 | digitToTree (Three a b c) = deep (Two a b) Empty (One c) 223 | digitToTree (Four a b c d) = deep (Two a b) Empty (Two c d) 224 | 225 | 226 | {-| 227 | >>> toList (merge (fromList [1..10]) (fromList [11..20])) 228 | [1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20] 229 | 230 | >>> toList (merge (fromList [1..3]) (fromList [4..20])) 231 | [1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20] 232 | -} 233 | merge :: Sized a => FingerTree a -> FingerTree a -> FingerTree a 234 | merge Empty tree = tree 235 | merge tree Empty = tree 236 | merge (Single a) tree = cons a tree 237 | merge tree (Single z) = snoc tree z 238 | merge (Deep ls ll lt lr) (Deep rs rl rt rr) = Deep (ls + rs) ll (merge4 lt lr rl rt) rr 239 | 240 | merge4 :: Sized a => FingerTree (Node a) -> Digit a -> Digit a -> FingerTree (Node a) -> FingerTree (Node a) 241 | merge4 left (One a) (One b) right = merge left (cons (Node2 a b) right) 242 | merge4 left (One a) (Two b c) right = merge left (cons (Node3 a b c) right) 243 | merge4 left (One a) (Three b c d) right = merge (snoc left (Node2 a b)) (cons (Node2 c d) right) 244 | merge4 left (One a) (Four b c d e) right = merge (snoc left (Node3 a b c)) (cons (Node2 d e) right) 245 | merge4 left (Two a b) (One c) right = merge left (cons (Node3 a b c) right) 246 | merge4 left (Two a b) (Two c d) right = merge (snoc left (Node2 a b)) (cons (Node2 c d) right) 247 | merge4 left (Two a b) (Three c d e) right = merge (snoc left (Node3 a b c)) (cons (Node2 d e) right) 248 | merge4 left (Two a b) (Four c d e f) right = merge (snoc left (Node3 a b c)) (cons (Node3 d e f) right) 249 | merge4 left (Three a b c) (One d) right = merge (snoc left (Node2 a b)) (cons (Node2 c d) right) 250 | merge4 left (Three a b c) (Two d e) right = merge (snoc left (Node3 a b c)) (cons (Node2 d e) right) 251 | merge4 left (Three a b c) (Three d e f) right = merge (snoc left (Node3 a b c)) (cons (Node3 d e f) right) 252 | merge4 left (Three a b c) (Four d e f g) right = merge (snoc left (Node3 a b c)) (cons (Node2 d e) (cons (Node2 f g) right)) 253 | merge4 left (Four a b c d) (One e) right = merge (snoc left (Node3 a b c)) (cons (Node2 d e) right) 254 | merge4 left (Four a b c d) (Two e f) right = merge (snoc left (Node3 a b c)) (cons (Node3 d e f) right) 255 | merge4 left (Four a b c d) (Three e f g) right = merge (snoc left (Node3 a b c)) (cons (Node2 d e) (cons (Node2 f g) right)) 256 | merge4 left (Four a b c d) (Four e f g h) right = merge (snoc left (Node3 a b c)) (cons (Node2 d e) (cons (Node3 f g h) right)) 257 | 258 | {-| 259 | >>> fmap getElement (lookup 1 (fromList [1..10])) 260 | Just 1 261 | 262 | >>> fmap getElement (lookup 17 (fromList [1..100])) 263 | Just 17 264 | 265 | >>> fmap getElement (lookup 1 (fromList [1])) 266 | Just 1 267 | 268 | >>> fmap getElement (lookup 1 (fromList [])) 269 | Nothing 270 | -} 271 | lookup :: Sized a => Int -> FingerTree a -> Maybe a 272 | lookup _ Empty = Nothing 273 | lookup _ (Single a) = Just a 274 | lookup pos tree = let (_, a, _) = split pos tree in Just a 275 | 276 | 277 | data Element a = E { getElement :: a } 278 | instance Sized (Element a) where size _ = 1 279 | 280 | fromList :: [a] -> FingerTree (Element a) 281 | fromList = foldr cons Empty . map E 282 | 283 | toList :: FingerTree (Element a) -> [a] 284 | toList t | Just (E a, t') <- viewL t = a : toList t' 285 | | otherwise = [] 286 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Franz Thoma (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Franz Thoma nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /LeftistHeap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | module LeftistHeap where 3 | 4 | import Prelude hiding (head, (++)) 5 | 6 | data Heap a 7 | = Empty 8 | | Heap 9 | { _rank :: !Int 10 | , head :: a 11 | , left :: Heap a 12 | , right :: Heap a } 13 | 14 | rank :: Heap a -> Int 15 | rank = \case 16 | Empty -> 0 17 | Heap r _ _ _ -> r 18 | 19 | mkLeftist :: a -> Heap a -> Heap a -> Heap a 20 | mkLeftist a xs ys 21 | | rank xs < rank ys = Heap (rank xs + 1) a ys xs 22 | | otherwise = Heap (rank ys + 1) a xs ys 23 | 24 | (++) :: Ord a => Heap a -> Heap a -> Heap a 25 | Empty ++ xs = Empty 26 | xs ++ Empty = Empty 27 | xs ++ ys 28 | | head xs <= head ys = mkLeftist (head xs) (left xs) (right xs ++ ys) 29 | | otherwise = mkLeftist (head ys) (left ys) (xs ++ right ys) 30 | 31 | insert :: Ord a => a -> Heap a -> Heap a 32 | insert a Empty = mkLeftist a Empty Empty 33 | insert a xs 34 | | a <= head xs = mkLeftist a xs Empty 35 | | otherwise = mkLeftist (head xs) (insert a (left xs)) (right xs) 36 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Purely Functional Data Structures 2 | ================================================================================ 3 | 4 | ## Linked Lists 5 | 6 | ```haskell 7 | -- Builtin syntax, but would be defined like that 8 | data [a] -- [a] = »List of items of type `a`« 9 | = [] -- Pronounced »Nil«: empty list 10 | | a : List a -- Pronounced »Cons«: Prepends an element to a List 11 | ``` 12 | 13 | Syntactical sugar: 14 | 15 | [1,2,3] ≡ 1 : (2 : (3 : [])) 16 | 17 | [1..10] ≡ 1 : 2 : 3 : 4 : 5 : 6 : 7 : 8 : 9 : 10 : [] 18 | 19 | Pattern Matching (list deconstruction): 20 | 21 | ```haskell 22 | case list of 23 | [] -> ... 24 | x : xs -> ... 25 | ``` 26 | 27 | 28 | ### Memory Layout 29 | 30 | x : [] x : y : z : [] 31 | 32 | ┌───┐ ┌───┐ ┌───┐ ┌───┐ 33 | │ x ├───[] │ x ├─│ y ├─│ z ├───[] 34 | └───┘ └───┘ └───┘ └───┘ 35 | 36 | Each `Cons` cell contains an element, and a pointer to the next element. 37 | 38 | ... if the list is evaluated at all, because: 39 | 40 | 41 | ### Lazy Evaluation 42 | 43 | Haskell is lazy: 44 | * Expressions are only evaluated when the result is needed 45 | * ... and only as far as needed! 46 | * Results are *memoized*, i.e. only computed once. 47 | * To be precise: Evaluation is driven by Pattern Matching. 48 | 49 | This allows for infinite constructs like repeat: 50 | 51 | ```haskell 52 | replicate 0 x = [] 53 | replicate n x = x : replicate (n - 1) x 54 | ``` 55 | 56 | The function creates a so-called »Thunk«, a reference to a computation to be 57 | executed: 58 | 59 | ╭───────────────╮ 60 | │ replicate 2 x │ 61 | ╰───────────────╯ 62 | 63 | After matching on the first `Cons` cell, the memory is updated (memoization): 64 | 65 | ┌───┐ ╭───────────────╮ 66 | │ x ├─│ replicate 1 x │ 67 | └───┘ ╰───────────────╯ 68 | 69 | ... and the second `Cons` cell: 70 | 71 | ┌───┐ ┌───┐ ╭───────────────╮ 72 | │ x ├─│ x ├─│ replicate 0 x │ 73 | └───┘ └───┘ ╰───────────────╯ 74 | 75 | The next pattern-match finds the final `Nil` cell: 76 | 77 | ┌───┐ ┌───┐ 78 | │ x ├─│ x ├───[] 79 | └───┘ └───┘ 80 | 81 | 82 | ### Efficiency of Lists 83 | 84 | Lists are quite inefficient when compiled naively. 85 | 86 | But laziness allows **Stream Fusion**, which basically allows the compiler to 87 | rearrange and group list operations, so that often a list is never even written 88 | to memory, but produces and transform elements as they are consumed. 89 | 90 | ```haskell 91 | fac :: Int -> Int 92 | fac n = product [1..n] 93 | ``` 94 | 95 | Q: How many memory allocations does `fac 100` perform? 96 | 97 | A: None at all: The numbers are produced incrementally, as they are consumed by 98 | `product`. No memory allocation required. 99 | 100 | 101 | ## How Lazy can you be? 102 | 103 | Assume the Java equivalent of the `head` function: 104 | 105 | ```java 106 | // public static A head(List list) { … } 107 | 108 | head(asList(f(100), f(200), f(300))) 109 | ``` 110 | 111 | In what order are the calls evaluated? 112 | 113 | 1. Evaluate `f(100)`, `f(200)`, `f(300)` 114 | 2. Pass the result to `asList(•,•,•)`, evaluate 115 | 3. Pass the result to `head(•)`, evaluate 116 | 117 | 118 | ### Let's Procrastinate! 119 | 120 | ```haskell 121 | head :: [a] -> a 122 | head (a : as) = a 123 | 124 | head [f 100, f 200, f 300] 125 | ``` 126 | 127 | In what order are the calls evaluated? 128 | 129 | 1. Enter head function, pass `[f 100, f 200, f 300]` as thunk 130 | 2. Encounter pattern `(a : as)` 131 | 3. Evaluate thunk to Weak Head Normal Form (WHNF: `• : •`) 132 | 4. Return `f 100` as thunk 133 | 134 | We didn't even once call `f`! 135 | 136 | (Now think what would happen for `f n = f (n-1) + f(n-2)` ...) 137 | 138 | 139 | 140 | ## Amortization 141 | 142 | For algorithms with varying cost per step, worst-case bounds can be too 143 | pessimistic, and the average case may not be an upper bound. 144 | 145 | Goal: Find a better upper bound by balancing between different cost centers. 146 | 147 | 148 | ### Example for amortization: Array Lists 149 | 150 | An Array List of fixed size `n` has `O(1)` insert. 151 | 152 | 7 153 | ↓ 154 | ┌───┬───┬───┬───┬───┬───┬───┬───┐ 155 | │ 1 │ 2 │ 3 │ 4 │ 5 │ 6 │ │ │ 156 | └───┴───┴───┴───┴───┴───┴───┴───┘ 157 | 158 | But if the list is too small, the `n+1`st element takes `O(n)` to insert, 159 | because the entire list is copied to double the array size. 160 | 161 | ┌───┬───┬───┬───┬───┬───┬───┬───┐ 162 | │ 1 │ 2 │ 3 │ 4 │ 5 │ 6 │ 7 │ 8 │ 163 | └───┴───┴───┴───┴───┴───┴───┴───┘ 9 164 | ↓ ↓ ↓ ↓ ↓ ↓ ↓ ↓ ↓ 165 | ┌───┬───┬───┬───┬───┬───┬───┬───┬───┬───┬───┬───┬───┬───┬───┬───┐ 166 | │ 1 │ 2 │ 3 │ 4 │ 5 │ 6 │ 7 │ 8 │ │ │ │ │ │ │ │ │ 167 | └───┴───┴───┴───┴───┴───┴───┴───┴───┴───┴───┴───┴───┴───┴───┴───┘ 168 | 169 | * Worst-case time for insert: `O(n)` 170 | * Amortized time for insert: `O(1)`! 171 | 172 | 173 | ### The banker's and the Physicist's method 174 | 175 | #### Banker's method: 176 | 177 | * Place credits at each location in the data structure. 178 | * Cheap operations may add credits (making them slightly more expensive). 179 | * Expensive operations may consume credits (making them possibly cheaper). 180 | * Credits can only be consumed after they have been placed, not in advance. 181 | 182 | The goal is to find an accounting scheme where each expensive operation is 183 | already paid for in credits. 184 | 185 | #### Physicist's method: 186 | 187 | * Define a potential `Φ` based on a property of each location. 188 | * The total potential is an upper bound for the accumulated savings, it must 189 | never be negative. 190 | * The amortized cost of an operation is the actual cost plus the change in 191 | potential: 192 | * Expensive operations can be made cheaper by drawing from the potential, 193 | * cheap operations can add to the potential. 194 | 195 | The goal is to find a good definition for the potential, so that it will never 196 | become negative, and so that expensive operations may draw from it. 197 | 198 | Both methods are equivalent: 199 | * Proofs using the Physicist's method are easier to write, because we can ignore 200 | the locations of the credits. 201 | * Proofs using the Banker's method are easier to understand, because we known 202 | when and where the credits are placed and consumed. 203 | 204 | 205 | ### Array List insertion: Amortized Analysis 206 | 207 | ┌───┬───┬───┬───┬───┬───┬───┬───┐ 208 | │ 1*│ 2*│ 3 │ 4 │ 5*│ 6*│ │ │ 209 | └───┴───┴───┴───┴───┴───┴───┴───┘ 210 | ┌───┬───┬───┬───┬───┬───┬───┬───┐ 211 | │ 1*│ 2*│ 3*│ 4 │ 5*│ 6*│ 7*│ │ 212 | └───┴───┴───┴───┴───┴───┴───┴───┘ 213 | ┌───┬───┬───┬───┬───┬───┬───┬───┐ 214 | │ 1*│ 2*│ 3*│ 4*│ 5*│ 6*│ 7*│ 8*│ 215 | └───┴───┴───┴───┴───┴───┴───┴───┘ 9 216 | ┌───┬───┬───┬───┬───┬───┬───┬───┬───┬───┬───┬───┬───┬───┬───┬───┐ 217 | │ 1 │ 2 │ 3 │ 4 │ 5 │ 6 │ 7 │ 8 │ │ │ │ │ │ │ │ │ 218 | └───┴───┴───┴───┴───┴───┴───┴───┴───┴───┴───┴───┴───┴───┴───┴───┘ 219 | ┌───┬───┬───┬───┬───┬───┬───┬───┬───┬───┬───┬───┬───┬───┬───┬───┐ 220 | │ 1*│ 2 │ 3 │ 4 │ 5 │ 6 │ 7 │ 8 │ 9*│ │ │ │ │ │ │ │ 221 | └───┴───┴───┴───┴───┴───┴───┴───┴───┴───┴───┴───┴───┴───┴───┴───┘ 222 | 223 | Account three credits for inserting element `m` into a list of length `N`: 224 | * One paid directly for actually storing the element 225 | * One saved for copying it to the next larger array 226 | * One saved for copying element `m - 2^(N-1)` to the next larger array 227 | 228 | When reaching the size limit, we have exactly one credit per cell to be copied. 229 | In other words, the resizing operation has already been paid for! 230 | 231 | With a constant three credits per insert operation, we have constant-time 232 | insert. 233 | 234 | 235 | ### Haskell Example: Batched Queue 236 | 237 | ```haskell 238 | data Queue a = Queue [a] [a] 239 | 240 | check :: Queue a -> Queue a 241 | check (Queue write []) = Queue [] (reverse write) 242 | check queue = queue 243 | 244 | empty :: Queue a 245 | empty = Queue [] [] 246 | 247 | insert :: a -> Queue a -> Queue a 248 | insert a (Queue write read) = check (Queue (a : write) read) 249 | 250 | view :: Queue a -> (a, Queue a) 251 | view (Queue write (a : read')) = (a, check (Queue write read')) 252 | ``` 253 | 254 | Inserting an element always takes `O(1)`, but reversing the front end of the 255 | queue takes `O(n)`! 256 | => The worst-case complexity for `view` is `O(n)`. 257 | 258 | Can we do better? 259 | 260 | 261 | ### Amortization for Batched Queue 262 | 263 | Use the Banker's method: 264 | 265 | ┌───┐ 266 | insert 1: [] │ 1 ├───[] 267 | └───┘ 268 | ┌───┐ ┌───┐ 269 | insert 2: │ 2*├───[] │ 1 ├───[] 270 | └───┘ └───┘ 271 | ┌───┐ ┌───┐ ┌───┐ 272 | insert 3: │ 3*├─│ 2*├───[] │ 1 ├───[] 273 | └───┘ └───┘ └───┘ 274 | ┌───┐ ┌───┐ 275 | view: [] │ 2 ├─│ 3 ├───[] 276 | └───┘ └───┘ 277 | ┌───┐ ┌───┐ ┌───┐ 278 | insert 4: │ 4*├───[] │ 2 ├─│ 3 ├───[] 279 | └───┘ └───┘ └───┘ 280 | ┌───┐ ┌───┐ 281 | view: │ 4*├───[] │ 3 ├───[] 282 | └───┘ └───┘ 283 | 284 | * On `insert`, account one credit to each inserted item, to a total cost of 2. 285 | * `view` without reversing does not consume any credits, so the total cost is 1. 286 | * `view` with reversing costs `n+1` steps, consumes `n` credits, so the net 287 | total cost is 1. 288 | 289 | => Batched Queue has `O(1)` amortized `view` and `insert`. 290 | 291 | Does it really? 292 | 293 | 294 | ### Problem with Amortization: Persistence 295 | 296 | Immutable data structures are **persistent**, they can be reused. This breaks 297 | our accounting balance: 298 | 299 | ```haskell 300 | peek :: Queue a -> a 301 | peek q = case view q of (a, _) -> a 302 | 303 | enqueueHead queue = insert (peek queue) queue 304 | ``` 305 | 306 | In order to `view` the first element, `peek` potentially reverses the list, 307 | spending all the saved credits, but immediately throws away the updated queue. 308 | Then `enqueueHead` continues with the old queue and `insert`s the result. 309 | 310 | If anyone `view`s the result of `enqueueHead`, the queue will be reversed 311 | *again* - but the credits have already been spent! 312 | 313 | 314 | ### Laziness and Amortization 315 | 316 | Idea: Use lazy evaluation, in particular memoization, to guarantee credits are 317 | only spent once. 318 | 319 | Lazy amortization using the Banker's method is a *layaway plan*: 320 | 321 | * Each time a thunk is created, we assign it a number of credits proportional to 322 | the time it takes to evaluate it. 323 | * We commit to save credits on each subsequent operation to pay for the 324 | evaluation. 325 | * Goal is to prove that in each possible future, there are enough saved credits 326 | to pay for the thunk when it is evaluated. 327 | 328 | 329 | 330 | ## Banker's Queue 331 | 332 | ```haskell 333 | data Queue a = Queue 334 | { lenWrite :: !Int 335 | , write :: [a] 336 | , lenRead :: !Int 337 | , read :: [a] } 338 | 339 | check :: Queue a -> Queue a 340 | check queue@(Queue {..}) 341 | | lenWrite > lenRead = Queue 0 [] (lenRead + lenWrite) (read ++ reverse write)) 342 | | otherwise = queue 343 | 344 | empty :: Queue a 345 | empty = Queue 0 [] 0 [] 346 | 347 | insert :: a -> Queue a -> Queue a 348 | insert a (Queue {..}) = check (Queue (lenWrite + 1) (a : write) lenRead read) 349 | 350 | 351 | view :: Queue a -> (a, Queue a) 352 | view (Queue {..}) = case read of 353 | [] -> error "Empty queue" 354 | a : read' -> (a, check (Queue lenWrite write (lenRead - 1) read')) 355 | ``` 356 | 357 | 358 | ### Amortization for Banker's Queue 359 | 360 | ┌───┐ 361 | insert 1: [] │ 1 ├───[] 362 | └───┘ 363 | ┌───┐ ┌───┐ 364 | insert 2: │ 2 ├───[] │ 1 ├───[] 365 | └───┘ └───┘ 366 | ┌───┐ ╭───────────────────╮ 367 | insert 3: [] │ 1 ├─│ ** reverse [3, 2] │ 368 | └───┘ ╰───────────────────╯ 369 | ╭──────────────────╮ 370 | view: [] │ * reverse [3, 2] │ 371 | ╰──────────────────╯ 372 | ┌───┐ ╭──────────────────╮ 373 | insert 4: │ 4 ├───[] │ * reverse [3, 2] │ 374 | └───┘ ╰──────────────────╯ 375 | ┌───┐ ┌───┐ 376 | view: │ 4 ├───[] │ 3 ├───[] 377 | └───┘ └───┘ 378 | 379 | #### `insert`: 380 | 381 | * Trivial `insert` takes one credit 382 | * `insert` with `reverse` takes one credit, and creates a thunk with `lenWrite` 383 | credits 384 | 385 | => `insert` runs in `O(1)` 386 | 387 | #### `view`: 388 | 389 | * `view` costs one credit, and we save one credit to pay for the next thunk. 390 | * Condition for rotating the queue: `lenWrite > lenRead`. => When reaching the 391 | thunk of a `reverse` operation, we have saved at least `lenRead` credits to 392 | pay for the thunk. 393 | 394 | => `view` runs in amortized `O(1)` 395 | 396 | 397 | ### Constant Overhead 398 | 399 | The Banker's Queue is slightly slower than the Batched Queue because of the 400 | additional book-keeping. Hence, in reality the Batched Queue is preferred where 401 | possible. 402 | 403 | Example: `Control.Concurrent.STM.TQueue` from `stm` uses a Batched Queue, since 404 | the queue is not used persistently, but ephemerally. 405 | 406 | 407 | 408 | ## Finger Trees 409 | 410 | [Ralf Hinze and Ross Paterson, »Finger trees: a simple general-purpose data 411 | structure«, Journal of Functional Programming 16:2 (2006). 412 | ](http://www.staff.city.ac.uk/~ross/papers/FingerTree.pdf) 413 | 414 | Used in: `Data.Sequence` 415 | 416 | FingerTree a • 1..8 items 417 | ┌─┬─┬─┬───┼───┬─┬─┐ 418 | a b c d │ X Y Z 419 | │ 420 | FingerTree (Node a) │ 2..24 items 421 | ┌───────┬───────┬─────┼─────┬──────┐ 422 | ┌─┼─┐ ┌─┼─┐ ┌─┼─┐ │ ┌─┼─┐ ┌┴┐ 423 | e f g h i j k l m │ S T U V W 424 | │ 425 | FingerTree (Node (Node a)) │ 4..72 items 426 | ┌───────────────┬───────┼─────────┐ 427 | ┌──────┼──────┐ ┌──┴──┐ │ ┌───┴───┐ 428 | ┌─┼─┐ ┌┴┐ ┌┴┐ ┌┴┐ ┌┴┐ │ ┌─┼─┐ ┌─┼─┐ 429 | n o p q r s t u v w x │ M N O P Q R 430 | │ 431 | FingerTree (Node (Node (Node a))) │ 8..216 items 432 | ┌────────────┼────────────┐ 433 | ┌──┴──┐ ┌───┴──┐ ┌──┴───┐ 434 | ┌┴┐ ┌┴┐ ┌┴┐ ┌─┼─┐ ┌┴┐ ┌─┼─┐ 435 | y z A B C D E F G H I J K L 436 | 437 | 438 | ### Finger Tree: Data Types 439 | 440 | ```haskell 441 | data FingerTree a 442 | = Empty 443 | | Single a 444 | | Deep !Int !(Digit a) (FingerTree (Node a)) !(Digit a) 445 | 446 | data Digit a = One a | Two a a | Three a a a | Four a a a a 447 | 448 | data Node a = Node2 a a | Node3 a a a 449 | 450 | class Sized a where 451 | size :: Int 452 | 453 | instance Sized a => Sized (FingerTree a) 454 | instance Sized a => Sized (Digit a) 455 | instance Sized a => Sized (Node a) 456 | ``` 457 | 458 | 459 | ### Finger Tree: Inserting Elements 460 | 461 | ```haskell 462 | (<|) -- `cons` 463 | :: Sized a => a -> FingerTree a -> FingerTree a 464 | (|>) -- `snoc` (`cons` backwards) 465 | :: Sized a => FingerTree a -> a -> FingerTree a 466 | 467 | a <| Single b = Deep (One a) Empty (One b) 468 | a <| Deep s l t r = case l of 469 | One b -> Deep s' (Two a b) t r 470 | Two b c -> Deep s' (Three a b c) t r 471 | Three b c d -> Deep s' (Four a b c d) t r 472 | Four b c d e -> t `seq` -- Push a node down the spine 473 | Deep s' (Two a b) (Node3 c d e <| t) r 474 | where s' = s + size a 475 | ``` 476 | 477 | 478 | ### Building a Tree 479 | 480 | 1 <| 2 <| 3 <| 4 <| 5 <| 6 <| 7 <| 8 <| 9 <| Empty 481 | 482 | 483 | 1 <| 2 <| 3 <| 4 <| 5 <| 6 <| 7 <| 8 <| Single 9 484 | 485 | • 486 | | 487 | 9 488 | 489 | 490 | 1 <| 2 <| 3 <| 4 <| 5 <| 6 <| 7 <| Deep (One 8) Empty (One 9) 491 | 492 | • 493 | ┌───┴───┐ 494 | 8 9 495 | 496 | `Single` is split into a `Deep` tree with `One` on each side and `Empty` spine. 497 | 498 | 499 | 1 <| 2 <| 3 <| 4 <| 5 <| 6 <| Deep (Two 7 8) Empty (One 9) 500 | 501 | • 502 | ┌─┬───┴───┐ 503 | 7 8 9 504 | 505 | 506 | 1 <| 2 <| 3 <| 4 <| 5 <| Deep (Three 6 7 8) Empty (One 9) 507 | 508 | • 509 | ┌─┬─┬───┴───┐ 510 | 6 7 8 9 511 | 512 | 513 | 1 <| 2 <| 3 <| 4 <| Deep (Four 5 6 7 8) Empty (One 9) 514 | 515 | • 516 | ┌─┬─┬─┬───┴───┐ 517 | 5 6 7 8 9 518 | 519 | Elements are inserted into the left `Digit` until it reaches `Four`. 520 | 521 | 522 | 1 <| 2 <| 3 <| Deep (Two 4 5) (Single (Node3 6 7 8)) (One 9) 523 | 524 | • 525 | ┌─┬───┼───┐ 526 | 4 5 │ 9 527 | ┌─┼─┐ 528 | 6 7 8 529 | 530 | When the left `Digit` is full, three elements are pushed down the spine as a 531 | `Single Node3`, leaving `Two` on the left `Digit`. 532 | 533 | 534 | 1 <| 2 <| Deep (Three 3 4 5) (Single (Node3 6 7 8)) (One 9) 535 | 536 | • 537 | ┌─┬─┬───┼───┐ 538 | 3 4 5 │ 9 539 | ┌─┼─┐ 540 | 6 7 8 541 | 542 | Now we can insert two more elements into the left `Digit`. 543 | 544 | 1 <| Deep (Four 2 3 4 5) (Single (Node3 6 7 8)) (One 9) 545 | 546 | • 547 | ┌─┬─┬─┬───┼───┐ 548 | 2 3 4 5 │ 9 549 | ┌─┼─┐ 550 | 6 7 8 551 | 552 | 553 | Deep (Two 1 2) (Deep (One (Node3 3 4 5)) Empty (One (Node3 6 7 8))) (One 9) 554 | 555 | • 556 | ┌─┬───┼───┐ 557 | 1 2 │ 9 558 | ┌───┴───┐ 559 | ┌─┼─┐ ┌─┼─┐ 560 | 3 4 5 6 7 8 561 | 562 | One more `Node3` is pushed down the spine, recursively splitting the `Single` 563 | into a `Deep` with two `One`s of `Node3`s. 564 | 565 | 566 | 567 | * `<|` tries to pack as tighly as possible (always creates `Node3`) 568 | * Always keeps two elements on either side, if possible (for fast `view`) 569 | * `|>` works exactly the same 570 | 571 | 572 | ### Finger Tree: Decomposition 573 | 574 | ```haskell 575 | viewL :: Sized a => FingerTree a -> Maybe (a, FingerTree a) 576 | viewR :: Sized a => FingerTree a -> Maybe (FingerTree a, a) 577 | 578 | viewL Empty = Nothing 579 | 580 | viewL (Single a) = Just (a, Empty) 581 | 582 | viewL (Deep s l t r) = Just $ case l of 583 | Four a b c d -> (a, Deep (s - size a) (Three b c d) t r) 584 | Three a b c -> (a, Deep (s - size a) (Two b c) t r) 585 | Two a b -> (a, Deep (s - size a) (One b) t r) 586 | 587 | One a -> case viewL t of -- Pull a node up from the spine 588 | Just (Node3 b c d, t') -> (a, Deep (s - size a) (Three b c d) t' r) 589 | Just (Node2 b c, t') -> (a, Deep (s - size a) (Two b c) t' r) 590 | 591 | Nothing -> case r of -- If the spine is empty, balance with the right digit 592 | Four b c d e -> (a, Deep (s - size a) (Two b c) Empty (Two d e)) 593 | Three b c d -> (a, Deep (s - size a) (Two b c) Empty (One d)) 594 | Two b c -> (a, Deep (s - size a) (One b) Empty (One c)) 595 | One b -> (a, Single b) 596 | ``` 597 | 598 | 599 | ### Viewing or Deleting Elements from a Tree 600 | 601 | Deep (Two 1 2) (Deep (One (Node3 3 4 5)) Empty (One (Node3 6 7 8))) (Two 9 10) 602 | 603 | • 604 | ┌─┬───┼───┬─┐ 605 | 1 2 │ 9 10 606 | ┌───┴───┐ 607 | ┌─┼─┐ ┌─┼─┐ 608 | 3 4 5 6 7 8 609 | 610 | 611 | Deep (One 2) (Deep (One (Node3 3 4 5)) Empty (One (Node3 6 7 8))) (Two 9 10) 612 | 613 | • 614 | ┌───┼───┬─┐ 615 | 2 │ 9 10 616 | ┌───┴───┐ 617 | ┌─┼─┐ ┌─┼─┐ 618 | 3 4 5 6 7 8 619 | 620 | 621 | Deep (Three 3 4 5) (Single (Node3 6 7 8)) (Two 9 10) 622 | 623 | • 624 | ┌─┬─┬───┼───┬─┐ 625 | 3 4 5 │ 9 10 626 | ┌─┼─┐ 627 | 6 7 8 628 | 629 | If the left `Digit` would become empty, recursively fetch a `Node` from the spine. 630 | 631 | 632 | Deep (Two 4 5) (Single (Node3 6 7 8)) (Two 9 10) 633 | 634 | • 635 | ┌─┬───┼───┬─┐ 636 | 4 5 │ 9 10 637 | ┌─┼─┐ 638 | 6 7 8 639 | 640 | 641 | Deep (One 5) (Single (Node3 6 7 8)) (Two 9 10) 642 | 643 | • 644 | ┌───┼───┬─┐ 645 | 5 │ 9 10 646 | ┌─┼─┐ 647 | 6 7 8 648 | 649 | 650 | Deep (Three 6 7 8) Empty (Two 9 10) 651 | 652 | • 653 | ┌─┬─┬───┴───┬─┐ 654 | 6 7 8 9 10 655 | 656 | Fetch one more `Node` from the sping, leaving the spine `Empty`. 657 | 658 | 659 | Deep (Two 7 8) Empty (Two 9 10) 660 | 661 | • 662 | ┌─┬───┴───┬─┐ 663 | 7 8 9 10 664 | 665 | 666 | Deep (One 8) Empty (Two 9 10) 667 | 668 | • 669 | ┌───┴───┬─┐ 670 | 8 9 10 671 | 672 | 673 | Deep (One 9) Empty (One 10) 674 | 675 | • 676 | ┌───┴───┐ 677 | 9 10 678 | 679 | If the spine is empty, try to fetch nodes from the right. 680 | 681 | Single 10 682 | 683 | • 684 | │ 685 | 10 686 | 687 | 688 | * Never leaves four elements on either side, for fast subsequent `<|`. 689 | * `viewR` works exactly the same. 690 | 691 | `viewL` performs in amortized `O(1)`. 692 | 693 | 694 | ### Finger Tree: Amortization 695 | 696 | * Rewriting a `Deep` with its (strict) `Digit`s costs one credit. 697 | * Every access to the spine (push down/pull up) costs one credit. 698 | 699 | Access to the spine only happens for `One` and `Four`. Those `Digit`s are called 700 | *dangerous*, the others are *safe*. 701 | 702 | Note that every access to a dangerous digit makes it safe: 703 | * Adding/removing elements: `One` -> `Two`, `Four` -> `Three` 704 | * Accessing the spine: `One` -> `Three`/`Two`, `Four` -> `Two` 705 | 706 | 707 | ### Finger Tree: Layaway plan 708 | 709 | #### Pushing a node down the spine: 710 | 711 | * Costs one credit for writing the `Two`. 712 | * Each recursion creates a thunk that will eventually cost one credit. 713 | * Each recursion turns a dangerous digit into a safe one. 714 | 715 | #### Pulling a node from the spine: 716 | 717 | * Accessing the `Digit` costs one credit. 718 | * Each recursion forces a thunk in the spine, which must already be paid for. 719 | * Each recursion turns a dangerous digit into a safe one. 720 | 721 | #### Layaway Plan 722 | 723 | Charge two credits per `cons` and `viewL`: One to rewrite the `Digit`, and one 724 | to pay the debt of a spine thunk. 725 | 726 | **Invariant:** Every time a digit becomes dangerous, the debt for the spine 727 | thunk is resolved. 728 | 729 | Inductive proof: 730 | * **Step:** When recursing down the spine, assuming its debt has been paid, we 731 | use our extra credit to pay for the spine of the first safe `Digit` we 732 | encounter. All the `Digit`s on the way are now safe. 733 | * **Initial:** When creating a spine, we immediately use the extra credit to 734 | resolve its debt. 735 | 736 | => Spines of dangerous `Digit`s are guaranteed to be paid for, spines of safe 737 | `Digit`s may have open debt. 738 | 739 | => Each time we access the spine, the debt has already been paid! 740 | 741 | 742 | ### Finger Tree: Splitting and appending 743 | 744 | #### Splitting 745 | 746 | `split :: Sized a => Int -> FingerTree a -> (FingerTree a, FingerTree a)` uses 747 | the size annotation to decide which subtree/digit/node to split. 748 | 749 | `O(log n)`: On each level, we create two digits and two lazy spines. 750 | 751 | #### Merging 752 | 753 | `merge :: FingerTree a -> FingerTree a -> FingerTree a` creates `Node`s from 754 | adjacent `Digit`s and pushes them up the spine. 755 | 756 | `O(log n)`: On each level, we merge two digits, and push at most four nodes up 757 | the spine. 758 | 759 | #### Random Access 760 | 761 | `lookup :: Sized a => Int -> FingerTree a -> Maybe a` looks up the `i`-th 762 | element by splitting the tree at `i` and returning the minimum element of the 763 | right tree. 764 | 765 | `O(log n)`: It's just a `split` plus a constant time operation. 766 | 767 | 768 | ### Finger Tree: Applications 769 | 770 | * Sequences (`Data.Sequence`), Queues: `O(log n)` random access, `O(1)` access to 771 | both ends, O(log n) `append`. 772 | 773 | * (Fair) Priority Queues: Replace the Size annotation by a Priority annotation. 774 | `O(1)` insert and `O(log n)` access to the minimum element. 775 | 776 | 777 | ## Other Widely-Used Functional Data Structures 778 | 779 | ### Size-Balanced Binary Trees 780 | 781 | Used in `Data.Set` and `Data.Map` in `containers`. 782 | 783 | * `Map`s (`Set`s) use the `Ord` instance of the keys (elements) to maintain 784 | ordering for `O(log n)` worst-case insert and lookup. 785 | * To prevent degeneration to `O(n)` in pathological cases, two subtrees are 786 | rebalanced if their sizes differ by a factor greater than 3. 787 | 788 | ```haskell 789 | data Map k v 790 | = Bin { size :: !Int 791 | , key :: !k 792 | , root :: v 793 | , left :: !(Map k v) 794 | , right :: !(Map k v) } 795 | | Tip 796 | ``` 797 | 798 | ### Skew Binomial Heaps 799 | 800 | Used in `Data.Heap` in Edward Kmett's `heaps`. 801 | 802 | * A variant of Binomaial Heaps with worst-case instead of amortized bounds. 803 | * Used as Priority Queues 804 | * Same asymptotic bounds as Finger Trees, slightly faster, but not stable (fair). 805 | 806 | ```haskell 807 | data Heap a 808 | = Empty 809 | | Tree { rank :: !Int 810 | , root :: a 811 | , forest :: [Heap a] 812 | -- ^ Zero or one tree of each rank smaller than this tree's rank, 813 | -- ordered by increasing rank. First two trees may have the same rank, 814 | -- to limit number of carries per operation. 815 | } 816 | ``` 817 | 818 | 819 | 820 | ## Conclusion 821 | 822 | * Immutability does not prevent efficient data structures. 823 | * Smart compilers make stupid programs run fast. 824 | * Being lazy can save you a lot of work. 825 | 826 | 827 | 828 | ## Thank you! 829 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-8.4 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: [] 39 | 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.3" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor 67 | --------------------------------------------------------------------------------