diff --git a/Data/FingerTree.hs b/Data/FingerTree.hs --- a/Data/FingerTree.hs +++ b/Data/FingerTree.hs @@ -12,10 +12,10 @@ -- use as a base for implementations of various collection types, as -- described in section 4 of -- --- * Ralf Hinze and Ross Paterson, --- \"Finger trees: a simple general-purpose data structure\", --- /Journal of Functional Programming/ 16:2 (2006) pp 197-217. --- +-- * Ralf Hinze and Ross Paterson, +-- \"Finger trees: a simple general-purpose data structure\", +-- /Journal of Functional Programming/ 16:2 (2006) pp 197-217. +-- -- -- For a directly usable sequence type, see @Data.Sequence@, which is -- a specialization of this structure. @@ -32,26 +32,26 @@ module Data.FingerTree ( #if TESTING - FingerTree(..), Digit(..), Node(..), deep, node2, node3, + FingerTree(..), Digit(..), Node(..), deep, node2, node3, #else - FingerTree, + FingerTree, #endif - Measured(..), - -- * Construction - empty, singleton, - (<|), (|>), (><), - fromList, - -- * Deconstruction - null, - ViewL(..), ViewR(..), viewl, viewr, - split, takeUntil, dropUntil, - -- * Transformation - reverse, - fmap', fmapWithPos, unsafeFmap, - traverse', traverseWithPos, unsafeTraverse - -- * Example - -- $example - ) where + Measured(..), + -- * Construction + empty, singleton, + (<|), (|>), (><), + fromList, + -- * Deconstruction + null, + ViewL(..), ViewR(..), viewl, viewr, + split, takeUntil, dropUntil, + -- * Transformation + reverse, + fmap', fmapWithPos, unsafeFmap, + traverse', traverseWithPos, unsafeTraverse + -- * Example + -- $example + ) where import Prelude hiding (null, reverse) @@ -65,44 +65,44 @@ -- | View of the left end of a sequence. data ViewL s a - = EmptyL -- ^ empty sequence - | a :< s a -- ^ leftmost element and the rest of the sequence - deriving (Eq, Ord, Show, Read) + = EmptyL -- ^ empty sequence + | a :< s a -- ^ leftmost element and the rest of the sequence + deriving (Eq, Ord, Show, Read) -- | View of the right end of a sequence. data ViewR s a - = EmptyR -- ^ empty sequence - | s a :> a -- ^ the sequence minus the rightmost element, - -- and the rightmost element - deriving (Eq, Ord, Show, Read) + = EmptyR -- ^ empty sequence + | s a :> a -- ^ the sequence minus the rightmost element, + -- and the rightmost element + deriving (Eq, Ord, Show, Read) instance Functor s => Functor (ViewL s) where - fmap _ EmptyL = EmptyL - fmap f (x :< xs) = f x :< fmap f xs + fmap _ EmptyL = EmptyL + fmap f (x :< xs) = f x :< fmap f xs instance Functor s => Functor (ViewR s) where - fmap _ EmptyR = EmptyR - fmap f (xs :> x) = fmap f xs :> f x + fmap _ EmptyR = EmptyR + fmap f (xs :> x) = fmap f xs :> f x -- | 'empty' and '><'. instance Measured v a => Monoid (FingerTree v a) where - mempty = empty - mappend = (><) + mempty = empty + mappend = (><) -- Explicit Digit type (Exercise 1) data Digit a - = One a - | Two a a - | Three a a a - | Four a a a a - deriving Show + = One a + | Two a a + | Three a a a + | Four a a a a + deriving Show instance Foldable Digit where - foldMap f (One a) = f a - foldMap f (Two a b) = f a `mappend` f b - foldMap f (Three a b c) = f a `mappend` f b `mappend` f c - foldMap f (Four a b c d) = f a `mappend` f b `mappend` f c `mappend` f d + foldMap f (One a) = f a + foldMap f (Two a b) = f a `mappend` f b + foldMap f (Three a b c) = f a `mappend` f b `mappend` f c + foldMap f (Four a b c d) = f a `mappend` f b `mappend` f c `mappend` f d ------------------- -- 4.1 Measurements @@ -110,21 +110,21 @@ -- | Things that can be measured. class (Monoid v) => Measured v a | a -> v where - measure :: a -> v + measure :: a -> v instance (Measured v a) => Measured v (Digit a) where - measure = foldMap measure + measure = foldMap measure --------------------------- -- 4.2 Caching measurements --------------------------- data Node v a = Node2 !v a a | Node3 !v a a a - deriving Show + deriving Show instance Foldable (Node v) where - foldMap f (Node2 _ a b) = f a `mappend` f b - foldMap f (Node3 _ a b c) = f a `mappend` f b `mappend` f c + foldMap f (Node2 _ a b) = f a `mappend` f b + foldMap f (Node3 _ a b c) = f a `mappend` f b `mappend` f c node2 :: (Measured v a) => a -> a -> Node v a node2 a b = Node2 (measure a `mappend` measure b) a b @@ -133,8 +133,8 @@ node3 a b c = Node3 (measure a `mappend` measure b `mappend` measure c) a b c instance (Monoid v) => Measured v (Node v a) where - measure (Node2 v _ _) = v - measure (Node3 v _ _ _) = v + measure (Node2 v _ _) = v + measure (Node3 v _ _ _) = v nodeToDigit :: Node v a -> Digit a nodeToDigit (Node2 _ a b) = Two a b @@ -152,55 +152,55 @@ -- A variety of abstract data types can be implemented by using different -- element types and measurements. data FingerTree v a - = Empty - | Single a - | Deep !v !(Digit a) (FingerTree v (Node v a)) !(Digit a) + = Empty + | Single a + | Deep !v !(Digit a) (FingerTree v (Node v a)) !(Digit a) #if TESTING - deriving Show + deriving Show #endif -deep :: (Measured v a) => - Digit a -> FingerTree v (Node v a) -> Digit a -> FingerTree v a +deep :: (Measured v a) => + Digit a -> FingerTree v (Node v a) -> Digit a -> FingerTree v a deep pr m sf = Deep ((measure pr `mappendVal` m) `mappend` measure sf) pr m sf -- | /O(1)/. The cached measure of a tree. instance (Measured v a) => Measured v (FingerTree v a) where - measure Empty = mempty - measure (Single x) = measure x - measure (Deep v _ _ _) = v + measure Empty = mempty + measure (Single x) = measure x + measure (Deep v _ _ _) = v instance Foldable (FingerTree v) where - foldMap _ Empty = mempty - foldMap f (Single x) = f x - foldMap f (Deep _ pr m sf) = - foldMap f pr `mappend` foldMap (foldMap f) m `mappend` foldMap f sf + foldMap _ Empty = mempty + foldMap f (Single x) = f x + foldMap f (Deep _ pr m sf) = + foldMap f pr `mappend` foldMap (foldMap f) m `mappend` foldMap f sf instance Eq a => Eq (FingerTree v a) where - xs == ys = toList xs == toList ys + xs == ys = toList xs == toList ys instance Ord a => Ord (FingerTree v a) where - compare xs ys = compare (toList xs) (toList ys) + compare xs ys = compare (toList xs) (toList ys) #if !TESTING instance Show a => Show (FingerTree v a) where - showsPrec p xs = showParen (p > 10) $ - showString "fromList " . shows (toList xs) + showsPrec p xs = showParen (p > 10) $ + showString "fromList " . shows (toList xs) #endif -- | Like 'fmap', but with a more constrained type. fmap' :: (Measured v1 a1, Measured v2 a2) => - (a1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2 + (a1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2 fmap' = mapTree mapTree :: (Measured v2 a2) => - (a1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2 + (a1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2 mapTree _ Empty = Empty mapTree f (Single x) = Single (f x) mapTree f (Deep _ pr m sf) = - deep (mapDigit f pr) (mapTree (mapNode f) m) (mapDigit f sf) + deep (mapDigit f pr) (mapTree (mapNode f) m) (mapDigit f sf) mapNode :: (Measured v2 a2) => - (a1 -> a2) -> Node v1 a1 -> Node v2 a2 + (a1 -> a2) -> Node v1 a1 -> Node v2 a2 mapNode f (Node2 _ a b) = node2 (f a) (f b) mapNode f (Node3 _ a b c) = node3 (f a) (f b) (f c) @@ -213,46 +213,52 @@ -- | Map all elements of the tree with a function that also takes the -- measure of the prefix of the tree to the left of the element. fmapWithPos :: (Measured v1 a1, Measured v2 a2) => - (v1 -> a1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2 + (v1 -> a1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2 fmapWithPos f = mapWPTree f mempty mapWPTree :: (Measured v1 a1, Measured v2 a2) => - (v1 -> a1 -> a2) -> v1 -> FingerTree v1 a1 -> FingerTree v2 a2 + (v1 -> a1 -> a2) -> v1 -> FingerTree v1 a1 -> FingerTree v2 a2 mapWPTree _ _ Empty = Empty mapWPTree f v (Single x) = Single (f v x) mapWPTree f v (Deep _ pr m sf) = - deep (mapWPDigit f v pr) - (mapWPTree (mapWPNode f) vpr m) - (mapWPDigit f vm sf) - where vpr = v `mappend` measure pr - vm = vpr `mappendVal` m + deep (mapWPDigit f v pr) + (mapWPTree (mapWPNode f) vpr m) + (mapWPDigit f vm sf) + where + vpr = v `mappend` measure pr + vm = vpr `mappendVal` m mapWPNode :: (Measured v1 a1, Measured v2 a2) => - (v1 -> a1 -> a2) -> v1 -> Node v1 a1 -> Node v2 a2 + (v1 -> a1 -> a2) -> v1 -> Node v1 a1 -> Node v2 a2 mapWPNode f v (Node2 _ a b) = node2 (f v a) (f va b) - where va = v `mappend` measure a + where + va = v `mappend` measure a mapWPNode f v (Node3 _ a b c) = node3 (f v a) (f va b) (f vab c) - where va = v `mappend` measure a - vab = va `mappend` measure b + where + va = v `mappend` measure a + vab = va `mappend` measure b mapWPDigit :: (Measured v a) => (v -> a -> b) -> v -> Digit a -> Digit b mapWPDigit f v (One a) = One (f v a) mapWPDigit f v (Two a b) = Two (f v a) (f va b) - where va = v `mappend` measure a + where + va = v `mappend` measure a mapWPDigit f v (Three a b c) = Three (f v a) (f va b) (f vab c) - where va = v `mappend` measure a - vab = va `mappend` measure b + where + va = v `mappend` measure a + vab = va `mappend` measure b mapWPDigit f v (Four a b c d) = Four (f v a) (f va b) (f vab c) (f vabc d) - where va = v `mappend` measure a - vab = va `mappend` measure b - vabc = vab `mappend` measure c + where + va = v `mappend` measure a + vab = va `mappend` measure b + vabc = vab `mappend` measure c -- | Like 'fmap', but safe only if the function preserves the measure. unsafeFmap :: (a -> b) -> FingerTree v a -> FingerTree v b unsafeFmap _ Empty = Empty unsafeFmap f (Single x) = Single (f x) unsafeFmap f (Deep v pr m sf) = - Deep v (mapDigit f pr) (unsafeFmap (unsafeFmapNode f) m) (mapDigit f sf) + Deep v (mapDigit f pr) (unsafeFmap (unsafeFmapNode f) m) (mapDigit f sf) unsafeFmapNode :: (a -> b) -> Node v a -> Node v b unsafeFmapNode f (Node2 v a b) = Node2 v (f a) (f b) @@ -260,18 +266,18 @@ -- | Like 'traverse', but with a more constrained type. traverse' :: (Measured v1 a1, Measured v2 a2, Applicative f) => - (a1 -> f a2) -> FingerTree v1 a1 -> f (FingerTree v2 a2) + (a1 -> f a2) -> FingerTree v1 a1 -> f (FingerTree v2 a2) traverse' = traverseTree traverseTree :: (Measured v2 a2, Applicative f) => - (a1 -> f a2) -> FingerTree v1 a1 -> f (FingerTree v2 a2) + (a1 -> f a2) -> FingerTree v1 a1 -> f (FingerTree v2 a2) traverseTree _ Empty = pure Empty traverseTree f (Single x) = Single <$> f x traverseTree f (Deep _ pr m sf) = - deep <$> traverseDigit f pr <*> traverseTree (traverseNode f) m <*> traverseDigit f sf + deep <$> traverseDigit f pr <*> traverseTree (traverseNode f) m <*> traverseDigit f sf traverseNode :: (Measured v2 a2, Applicative f) => - (a1 -> f a2) -> Node v1 a1 -> f (Node v2 a2) + (a1 -> f a2) -> Node v1 a1 -> f (Node v2 a2) traverseNode f (Node2 _ a b) = node2 <$> f a <*> f b traverseNode f (Node3 _ a b c) = node3 <$> f a <*> f b <*> f c @@ -284,49 +290,55 @@ -- | Traverse the tree with a function that also takes the -- measure of the prefix of the tree to the left of the element. traverseWithPos :: (Measured v1 a1, Measured v2 a2, Applicative f) => - (v1 -> a1 -> f a2) -> FingerTree v1 a1 -> f (FingerTree v2 a2) + (v1 -> a1 -> f a2) -> FingerTree v1 a1 -> f (FingerTree v2 a2) traverseWithPos f = traverseWPTree f mempty traverseWPTree :: (Measured v1 a1, Measured v2 a2, Applicative f) => - (v1 -> a1 -> f a2) -> v1 -> FingerTree v1 a1 -> f (FingerTree v2 a2) + (v1 -> a1 -> f a2) -> v1 -> FingerTree v1 a1 -> f (FingerTree v2 a2) traverseWPTree _ _ Empty = pure Empty traverseWPTree f v (Single x) = Single <$> f v x traverseWPTree f v (Deep _ pr m sf) = - deep <$> traverseWPDigit f v pr <*> traverseWPTree (traverseWPNode f) vpr m <*> traverseWPDigit f vm sf - where vpr = v `mappend` measure pr - vm = vpr `mappendVal` m + deep <$> traverseWPDigit f v pr <*> traverseWPTree (traverseWPNode f) vpr m <*> traverseWPDigit f vm sf + where + vpr = v `mappend` measure pr + vm = vpr `mappendVal` m traverseWPNode :: (Measured v1 a1, Measured v2 a2, Applicative f) => - (v1 -> a1 -> f a2) -> v1 -> Node v1 a1 -> f (Node v2 a2) + (v1 -> a1 -> f a2) -> v1 -> Node v1 a1 -> f (Node v2 a2) traverseWPNode f v (Node2 _ a b) = node2 <$> f v a <*> f va b - where va = v `mappend` measure a + where + va = v `mappend` measure a traverseWPNode f v (Node3 _ a b c) = node3 <$> f v a <*> f va b <*> f vab c - where va = v `mappend` measure a - vab = va `mappend` measure b + where + va = v `mappend` measure a + vab = va `mappend` measure b traverseWPDigit :: (Measured v a, Applicative f) => - (v -> a -> f b) -> v -> Digit a -> f (Digit b) + (v -> a -> f b) -> v -> Digit a -> f (Digit b) traverseWPDigit f v (One a) = One <$> f v a traverseWPDigit f v (Two a b) = Two <$> f v a <*> f va b - where va = v `mappend` measure a + where + va = v `mappend` measure a traverseWPDigit f v (Three a b c) = Three <$> f v a <*> f va b <*> f vab c - where va = v `mappend` measure a - vab = va `mappend` measure b + where + va = v `mappend` measure a + vab = va `mappend` measure b traverseWPDigit f v (Four a b c d) = Four <$> f v a <*> f va b <*> f vab c <*> f vabc d - where va = v `mappend` measure a - vab = va `mappend` measure b - vabc = vab `mappend` measure c + where + va = v `mappend` measure a + vab = va `mappend` measure b + vabc = vab `mappend` measure c -- | Like 'traverse', but safe only if the function preserves the measure. unsafeTraverse :: (Applicative f) => - (a -> f b) -> FingerTree v a -> f (FingerTree v b) + (a -> f b) -> FingerTree v a -> f (FingerTree v b) unsafeTraverse _ Empty = pure Empty unsafeTraverse f (Single x) = Single <$> f x unsafeTraverse f (Deep v pr m sf) = - Deep v <$> traverseDigit f pr <*> unsafeTraverse (unsafeTraverseNode f) m <*> traverseDigit f sf + Deep v <$> traverseDigit f pr <*> unsafeTraverse (unsafeTraverseNode f) m <*> traverseDigit f sf unsafeTraverseNode :: (Applicative f) => - (a -> f b) -> Node v a -> f (Node v b) + (a -> f b) -> Node v a -> f (Node v b) unsafeTraverseNode f (Node2 v a b) = Node2 v <$> f a <*> f b unsafeTraverseNode f (Node3 v a b c) = Node3 v <$> f a <*> f b <*> f c @@ -343,18 +355,18 @@ singleton = Single -- | /O(n)/. Create a sequence from a finite list of elements. -fromList :: (Measured v a) => [a] -> FingerTree v a +fromList :: (Measured v a) => [a] -> FingerTree v a fromList = foldr (<|) Empty -- | /O(1)/. Add an element to the left end of a sequence. -- Mnemonic: a triangle with the single element at the pointy end. (<|) :: (Measured v a) => a -> FingerTree v a -> FingerTree v a -a <| Empty = Single a -a <| Single b = deep (One a) Empty (One b) +a <| Empty = Single a +a <| Single b = deep (One a) Empty (One b) a <| Deep v (Four b c d e) m sf = m `seq` - Deep (measure a `mappend` v) (Two a b) (node3 c d e <| m) sf -a <| Deep v pr m sf = - Deep (measure a `mappend` v) (consDigit a pr) m sf + Deep (measure a `mappend` v) (Two a b) (node3 c d e <| m) sf +a <| Deep v pr m sf = + Deep (measure a `mappend` v) (consDigit a pr) m sf consDigit :: a -> Digit a -> Digit a consDigit a (One b) = Two a b @@ -365,12 +377,12 @@ -- | /O(1)/. Add an element to the right end of a sequence. -- Mnemonic: a triangle with the single element at the pointy end. (|>) :: (Measured v a) => FingerTree v a -> a -> FingerTree v a -Empty |> a = Single a -Single a |> b = deep (One a) Empty (One b) +Empty |> a = Single a +Single a |> b = deep (One a) Empty (One b) Deep v pr m (Four a b c d) |> e = m `seq` - Deep (v `mappend` measure e) pr (m |> node3 a b c) (Two d e) -Deep v pr m sf |> x = - Deep (v `mappend` measure x) pr m (snocDigit sf x) + Deep (v `mappend` measure e) pr (m |> node3 a b c) (Two d e) +Deep v pr m sf |> x = + Deep (v `mappend` measure x) pr m (snocDigit sf x) snocDigit :: Digit a -> a -> Digit a snocDigit (One a) b = Two a b @@ -385,15 +397,15 @@ -- | /O(1)/. Analyse the left end of a sequence. viewl :: (Measured v a) => FingerTree v a -> ViewL (FingerTree v) a -viewl Empty = EmptyL -viewl (Single x) = x :< Empty -viewl (Deep _ (One x) m sf) = x :< rotL m sf -viewl (Deep _ pr m sf) = lheadDigit pr :< deep (ltailDigit pr) m sf +viewl Empty = EmptyL +viewl (Single x) = x :< Empty +viewl (Deep _ (One x) m sf) = x :< rotL m sf +viewl (Deep _ pr m sf) = lheadDigit pr :< deep (ltailDigit pr) m sf rotL :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> FingerTree v a rotL m sf = case viewl m of - EmptyL -> digitToTree sf - a :< m' -> Deep (measure m `mappend` measure sf) (nodeToDigit a) m' sf + EmptyL -> digitToTree sf + a :< m' -> Deep (measure m `mappend` measure sf) (nodeToDigit a) m' sf lheadDigit :: Digit a -> a lheadDigit (One a) = a @@ -406,18 +418,18 @@ ltailDigit (Two _ b) = One b ltailDigit (Three _ b c) = Two b c ltailDigit (Four _ b c d) = Three b c d - + -- | /O(1)/. Analyse the right end of a sequence. viewr :: (Measured v a) => FingerTree v a -> ViewR (FingerTree v) a -viewr Empty = EmptyR -viewr (Single x) = Empty :> x -viewr (Deep _ pr m (One x)) = rotR pr m :> x -viewr (Deep _ pr m sf) = deep pr m (rtailDigit sf) :> rheadDigit sf +viewr Empty = EmptyR +viewr (Single x) = Empty :> x +viewr (Deep _ pr m (One x)) = rotR pr m :> x +viewr (Deep _ pr m sf) = deep pr m (rtailDigit sf) :> rheadDigit sf rotR :: (Measured v a) => Digit a -> FingerTree v (Node v a) -> FingerTree v a rotR pr m = case viewr m of - EmptyR -> digitToTree pr - m' :> a -> Deep (measure pr `mappendVal` m) pr m' (nodeToDigit a) + EmptyR -> digitToTree pr + m' :> a -> Deep (measure pr `mappendVal` m) pr m' (nodeToDigit a) rheadDigit :: Digit a -> a rheadDigit (One a) = a @@ -447,233 +459,233 @@ appendTree0 :: (Measured v a) => FingerTree v a -> FingerTree v a -> FingerTree v a appendTree0 Empty xs = - xs + xs appendTree0 xs Empty = - xs + xs appendTree0 (Single x) xs = - x <| xs + x <| xs appendTree0 xs (Single x) = - xs |> x + xs |> x appendTree0 (Deep _ pr1 m1 sf1) (Deep _ pr2 m2 sf2) = - deep pr1 (addDigits0 m1 sf1 pr2 m2) sf2 + deep pr1 (addDigits0 m1 sf1 pr2 m2) sf2 addDigits0 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a) addDigits0 m1 (One a) (One b) m2 = - appendTree1 m1 (node2 a b) m2 + appendTree1 m1 (node2 a b) m2 addDigits0 m1 (One a) (Two b c) m2 = - appendTree1 m1 (node3 a b c) m2 + appendTree1 m1 (node3 a b c) m2 addDigits0 m1 (One a) (Three b c d) m2 = - appendTree2 m1 (node2 a b) (node2 c d) m2 + appendTree2 m1 (node2 a b) (node2 c d) m2 addDigits0 m1 (One a) (Four b c d e) m2 = - appendTree2 m1 (node3 a b c) (node2 d e) m2 + appendTree2 m1 (node3 a b c) (node2 d e) m2 addDigits0 m1 (Two a b) (One c) m2 = - appendTree1 m1 (node3 a b c) m2 + appendTree1 m1 (node3 a b c) m2 addDigits0 m1 (Two a b) (Two c d) m2 = - appendTree2 m1 (node2 a b) (node2 c d) m2 + appendTree2 m1 (node2 a b) (node2 c d) m2 addDigits0 m1 (Two a b) (Three c d e) m2 = - appendTree2 m1 (node3 a b c) (node2 d e) m2 + appendTree2 m1 (node3 a b c) (node2 d e) m2 addDigits0 m1 (Two a b) (Four c d e f) m2 = - appendTree2 m1 (node3 a b c) (node3 d e f) m2 + appendTree2 m1 (node3 a b c) (node3 d e f) m2 addDigits0 m1 (Three a b c) (One d) m2 = - appendTree2 m1 (node2 a b) (node2 c d) m2 + appendTree2 m1 (node2 a b) (node2 c d) m2 addDigits0 m1 (Three a b c) (Two d e) m2 = - appendTree2 m1 (node3 a b c) (node2 d e) m2 + appendTree2 m1 (node3 a b c) (node2 d e) m2 addDigits0 m1 (Three a b c) (Three d e f) m2 = - appendTree2 m1 (node3 a b c) (node3 d e f) m2 + appendTree2 m1 (node3 a b c) (node3 d e f) m2 addDigits0 m1 (Three a b c) (Four d e f g) m2 = - appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 addDigits0 m1 (Four a b c d) (One e) m2 = - appendTree2 m1 (node3 a b c) (node2 d e) m2 + appendTree2 m1 (node3 a b c) (node2 d e) m2 addDigits0 m1 (Four a b c d) (Two e f) m2 = - appendTree2 m1 (node3 a b c) (node3 d e f) m2 + appendTree2 m1 (node3 a b c) (node3 d e f) m2 addDigits0 m1 (Four a b c d) (Three e f g) m2 = - appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 addDigits0 m1 (Four a b c d) (Four e f g h) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 appendTree1 :: (Measured v a) => FingerTree v a -> a -> FingerTree v a -> FingerTree v a appendTree1 Empty a xs = - a <| xs + a <| xs appendTree1 xs a Empty = - xs |> a + xs |> a appendTree1 (Single x) a xs = - x <| a <| xs + x <| a <| xs appendTree1 xs a (Single x) = - xs |> a |> x + xs |> a |> x appendTree1 (Deep _ pr1 m1 sf1) a (Deep _ pr2 m2 sf2) = - deep pr1 (addDigits1 m1 sf1 a pr2 m2) sf2 + deep pr1 (addDigits1 m1 sf1 a pr2 m2) sf2 addDigits1 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a) addDigits1 m1 (One a) b (One c) m2 = - appendTree1 m1 (node3 a b c) m2 + appendTree1 m1 (node3 a b c) m2 addDigits1 m1 (One a) b (Two c d) m2 = - appendTree2 m1 (node2 a b) (node2 c d) m2 + appendTree2 m1 (node2 a b) (node2 c d) m2 addDigits1 m1 (One a) b (Three c d e) m2 = - appendTree2 m1 (node3 a b c) (node2 d e) m2 + appendTree2 m1 (node3 a b c) (node2 d e) m2 addDigits1 m1 (One a) b (Four c d e f) m2 = - appendTree2 m1 (node3 a b c) (node3 d e f) m2 + appendTree2 m1 (node3 a b c) (node3 d e f) m2 addDigits1 m1 (Two a b) c (One d) m2 = - appendTree2 m1 (node2 a b) (node2 c d) m2 + appendTree2 m1 (node2 a b) (node2 c d) m2 addDigits1 m1 (Two a b) c (Two d e) m2 = - appendTree2 m1 (node3 a b c) (node2 d e) m2 + appendTree2 m1 (node3 a b c) (node2 d e) m2 addDigits1 m1 (Two a b) c (Three d e f) m2 = - appendTree2 m1 (node3 a b c) (node3 d e f) m2 + appendTree2 m1 (node3 a b c) (node3 d e f) m2 addDigits1 m1 (Two a b) c (Four d e f g) m2 = - appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 addDigits1 m1 (Three a b c) d (One e) m2 = - appendTree2 m1 (node3 a b c) (node2 d e) m2 + appendTree2 m1 (node3 a b c) (node2 d e) m2 addDigits1 m1 (Three a b c) d (Two e f) m2 = - appendTree2 m1 (node3 a b c) (node3 d e f) m2 + appendTree2 m1 (node3 a b c) (node3 d e f) m2 addDigits1 m1 (Three a b c) d (Three e f g) m2 = - appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 addDigits1 m1 (Three a b c) d (Four e f g h) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 addDigits1 m1 (Four a b c d) e (One f) m2 = - appendTree2 m1 (node3 a b c) (node3 d e f) m2 + appendTree2 m1 (node3 a b c) (node3 d e f) m2 addDigits1 m1 (Four a b c d) e (Two f g) m2 = - appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 addDigits1 m1 (Four a b c d) e (Three f g h) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 addDigits1 m1 (Four a b c d) e (Four f g h i) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 + appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 appendTree2 :: (Measured v a) => FingerTree v a -> a -> a -> FingerTree v a -> FingerTree v a appendTree2 Empty a b xs = - a <| b <| xs + a <| b <| xs appendTree2 xs a b Empty = - xs |> a |> b + xs |> a |> b appendTree2 (Single x) a b xs = - x <| a <| b <| xs + x <| a <| b <| xs appendTree2 xs a b (Single x) = - xs |> a |> b |> x + xs |> a |> b |> x appendTree2 (Deep _ pr1 m1 sf1) a b (Deep _ pr2 m2 sf2) = - deep pr1 (addDigits2 m1 sf1 a b pr2 m2) sf2 + deep pr1 (addDigits2 m1 sf1 a b pr2 m2) sf2 addDigits2 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a) addDigits2 m1 (One a) b c (One d) m2 = - appendTree2 m1 (node2 a b) (node2 c d) m2 + appendTree2 m1 (node2 a b) (node2 c d) m2 addDigits2 m1 (One a) b c (Two d e) m2 = - appendTree2 m1 (node3 a b c) (node2 d e) m2 + appendTree2 m1 (node3 a b c) (node2 d e) m2 addDigits2 m1 (One a) b c (Three d e f) m2 = - appendTree2 m1 (node3 a b c) (node3 d e f) m2 + appendTree2 m1 (node3 a b c) (node3 d e f) m2 addDigits2 m1 (One a) b c (Four d e f g) m2 = - appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 addDigits2 m1 (Two a b) c d (One e) m2 = - appendTree2 m1 (node3 a b c) (node2 d e) m2 + appendTree2 m1 (node3 a b c) (node2 d e) m2 addDigits2 m1 (Two a b) c d (Two e f) m2 = - appendTree2 m1 (node3 a b c) (node3 d e f) m2 + appendTree2 m1 (node3 a b c) (node3 d e f) m2 addDigits2 m1 (Two a b) c d (Three e f g) m2 = - appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 addDigits2 m1 (Two a b) c d (Four e f g h) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 addDigits2 m1 (Three a b c) d e (One f) m2 = - appendTree2 m1 (node3 a b c) (node3 d e f) m2 + appendTree2 m1 (node3 a b c) (node3 d e f) m2 addDigits2 m1 (Three a b c) d e (Two f g) m2 = - appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 addDigits2 m1 (Three a b c) d e (Three f g h) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 addDigits2 m1 (Three a b c) d e (Four f g h i) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 + appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 addDigits2 m1 (Four a b c d) e f (One g) m2 = - appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 addDigits2 m1 (Four a b c d) e f (Two g h) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 addDigits2 m1 (Four a b c d) e f (Three g h i) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 + appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 addDigits2 m1 (Four a b c d) e f (Four g h i j) m2 = - appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2 + appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2 appendTree3 :: (Measured v a) => FingerTree v a -> a -> a -> a -> FingerTree v a -> FingerTree v a appendTree3 Empty a b c xs = - a <| b <| c <| xs + a <| b <| c <| xs appendTree3 xs a b c Empty = - xs |> a |> b |> c + xs |> a |> b |> c appendTree3 (Single x) a b c xs = - x <| a <| b <| c <| xs + x <| a <| b <| c <| xs appendTree3 xs a b c (Single x) = - xs |> a |> b |> c |> x + xs |> a |> b |> c |> x appendTree3 (Deep _ pr1 m1 sf1) a b c (Deep _ pr2 m2 sf2) = - deep pr1 (addDigits3 m1 sf1 a b c pr2 m2) sf2 + deep pr1 (addDigits3 m1 sf1 a b c pr2 m2) sf2 addDigits3 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a) addDigits3 m1 (One a) b c d (One e) m2 = - appendTree2 m1 (node3 a b c) (node2 d e) m2 + appendTree2 m1 (node3 a b c) (node2 d e) m2 addDigits3 m1 (One a) b c d (Two e f) m2 = - appendTree2 m1 (node3 a b c) (node3 d e f) m2 + appendTree2 m1 (node3 a b c) (node3 d e f) m2 addDigits3 m1 (One a) b c d (Three e f g) m2 = - appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 addDigits3 m1 (One a) b c d (Four e f g h) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 addDigits3 m1 (Two a b) c d e (One f) m2 = - appendTree2 m1 (node3 a b c) (node3 d e f) m2 + appendTree2 m1 (node3 a b c) (node3 d e f) m2 addDigits3 m1 (Two a b) c d e (Two f g) m2 = - appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 addDigits3 m1 (Two a b) c d e (Three f g h) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 addDigits3 m1 (Two a b) c d e (Four f g h i) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 + appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 addDigits3 m1 (Three a b c) d e f (One g) m2 = - appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 addDigits3 m1 (Three a b c) d e f (Two g h) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 addDigits3 m1 (Three a b c) d e f (Three g h i) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 + appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 addDigits3 m1 (Three a b c) d e f (Four g h i j) m2 = - appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2 + appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2 addDigits3 m1 (Four a b c d) e f g (One h) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 addDigits3 m1 (Four a b c d) e f g (Two h i) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 + appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 addDigits3 m1 (Four a b c d) e f g (Three h i j) m2 = - appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2 + appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2 addDigits3 m1 (Four a b c d) e f g (Four h i j k) m2 = - appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2 + appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2 appendTree4 :: (Measured v a) => FingerTree v a -> a -> a -> a -> a -> FingerTree v a -> FingerTree v a appendTree4 Empty a b c d xs = - a <| b <| c <| d <| xs + a <| b <| c <| d <| xs appendTree4 xs a b c d Empty = - xs |> a |> b |> c |> d + xs |> a |> b |> c |> d appendTree4 (Single x) a b c d xs = - x <| a <| b <| c <| d <| xs + x <| a <| b <| c <| d <| xs appendTree4 xs a b c d (Single x) = - xs |> a |> b |> c |> d |> x + xs |> a |> b |> c |> d |> x appendTree4 (Deep _ pr1 m1 sf1) a b c d (Deep _ pr2 m2 sf2) = - deep pr1 (addDigits4 m1 sf1 a b c d pr2 m2) sf2 + deep pr1 (addDigits4 m1 sf1 a b c d pr2 m2) sf2 addDigits4 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a) addDigits4 m1 (One a) b c d e (One f) m2 = - appendTree2 m1 (node3 a b c) (node3 d e f) m2 + appendTree2 m1 (node3 a b c) (node3 d e f) m2 addDigits4 m1 (One a) b c d e (Two f g) m2 = - appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 addDigits4 m1 (One a) b c d e (Three f g h) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 addDigits4 m1 (One a) b c d e (Four f g h i) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 + appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 addDigits4 m1 (Two a b) c d e f (One g) m2 = - appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 addDigits4 m1 (Two a b) c d e f (Two g h) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 addDigits4 m1 (Two a b) c d e f (Three g h i) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 + appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 addDigits4 m1 (Two a b) c d e f (Four g h i j) m2 = - appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2 + appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2 addDigits4 m1 (Three a b c) d e f g (One h) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 addDigits4 m1 (Three a b c) d e f g (Two h i) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 + appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 addDigits4 m1 (Three a b c) d e f g (Three h i j) m2 = - appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2 + appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2 addDigits4 m1 (Three a b c) d e f g (Four h i j k) m2 = - appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2 + appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2 addDigits4 m1 (Four a b c d) e f g h (One i) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 + appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 addDigits4 m1 (Four a b c d) e f g h (Two i j) m2 = - appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2 + appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2 addDigits4 m1 (Four a b c d) e f g h (Three i j k) m2 = - appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2 + appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2 addDigits4 m1 (Four a b c d) e f g h (Four i j k l) m2 = - appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2 + appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2 ---------------- -- 4.4 Splitting @@ -684,13 +696,14 @@ -- -- For predictable results, one should ensure that there is only one such -- point, i.e. that the predicate is /monotonic/. -split :: (Measured v a) => - (v -> Bool) -> FingerTree v a -> (FingerTree v a, FingerTree v a) +split :: (Measured v a) => + (v -> Bool) -> FingerTree v a -> (FingerTree v a, FingerTree v a) split _ Empty = (Empty, Empty) split p xs | p (measure xs) = (l, x <| r) - | otherwise = (xs, Empty) - where Split l x r = splitTree p mempty xs + | otherwise = (xs, Empty) + where + Split l x r = splitTree p mempty xs -- | /O(log(min(i,n-i)))/. -- Given a monotonic predicate @p@, @'takeUntil' p t@ is the largest @@ -710,70 +723,76 @@ data Split t a = Split t a t -splitTree :: (Measured v a) => - (v -> Bool) -> v -> FingerTree v a -> Split (FingerTree v a) a +splitTree :: (Measured v a) => + (v -> Bool) -> v -> FingerTree v a -> Split (FingerTree v a) a splitTree _ _ Empty = illegal_argument "splitTree" splitTree _ _ (Single x) = Split Empty x Empty splitTree p i (Deep _ pr m sf) - | p vpr = let Split l x r = splitDigit p i pr - in Split (maybe Empty digitToTree l) x (deepL r m sf) - | p vm = let Split ml xs mr = splitTree p vpr m - Split l x r = splitNode p (vpr `mappendVal` ml) xs - in Split (deepR pr ml l) x (deepL r mr sf) - | otherwise = let Split l x r = splitDigit p vm sf - in Split (deepR pr m l) x (maybe Empty digitToTree r) - where vpr = i `mappend` measure pr - vm = vpr `mappendVal` m + | p vpr = let Split l x r = splitDigit p i pr + in Split (maybe Empty digitToTree l) x (deepL r m sf) + | p vm = let Split ml xs mr = splitTree p vpr m + Split l x r = splitNode p (vpr `mappendVal` ml) xs + in Split (deepR pr ml l) x (deepL r mr sf) + | otherwise = let Split l x r = splitDigit p vm sf + in Split (deepR pr m l) x (maybe Empty digitToTree r) + where + vpr = i `mappend` measure pr + vm = vpr `mappendVal` m -- Avoid relying on right identity (cf Exercise 7) mappendVal :: (Measured v a) => v -> FingerTree v a -> v mappendVal v Empty = v mappendVal v t = v `mappend` measure t -deepL :: (Measured v a) => - Maybe (Digit a) -> FingerTree v (Node v a) -> Digit a -> FingerTree v a -deepL Nothing m sf = rotL m sf -deepL (Just pr) m sf = deep pr m sf +deepL :: (Measured v a) => + Maybe (Digit a) -> FingerTree v (Node v a) -> Digit a -> FingerTree v a +deepL Nothing m sf = rotL m sf +deepL (Just pr) m sf = deep pr m sf -deepR :: (Measured v a) => - Digit a -> FingerTree v (Node v a) -> Maybe (Digit a) -> FingerTree v a -deepR pr m Nothing = rotR pr m -deepR pr m (Just sf) = deep pr m sf +deepR :: (Measured v a) => + Digit a -> FingerTree v (Node v a) -> Maybe (Digit a) -> FingerTree v a +deepR pr m Nothing = rotR pr m +deepR pr m (Just sf) = deep pr m sf splitNode :: (Measured v a) => (v -> Bool) -> v -> Node v a -> - Split (Maybe (Digit a)) a + Split (Maybe (Digit a)) a splitNode p i (Node2 _ a b) - | p va = Split Nothing a (Just (One b)) - | otherwise = Split (Just (One a)) b Nothing - where va = i `mappend` measure a + | p va = Split Nothing a (Just (One b)) + | otherwise = Split (Just (One a)) b Nothing + where + va = i `mappend` measure a splitNode p i (Node3 _ a b c) - | p va = Split Nothing a (Just (Two b c)) - | p vab = Split (Just (One a)) b (Just (One c)) - | otherwise = Split (Just (Two a b)) c Nothing - where va = i `mappend` measure a - vab = va `mappend` measure b + | p va = Split Nothing a (Just (Two b c)) + | p vab = Split (Just (One a)) b (Just (One c)) + | otherwise = Split (Just (Two a b)) c Nothing + where + va = i `mappend` measure a + vab = va `mappend` measure b splitDigit :: (Measured v a) => (v -> Bool) -> v -> Digit a -> - Split (Maybe (Digit a)) a + Split (Maybe (Digit a)) a splitDigit _ i (One a) = i `seq` Split Nothing a Nothing splitDigit p i (Two a b) - | p va = Split Nothing a (Just (One b)) - | otherwise = Split (Just (One a)) b Nothing - where va = i `mappend` measure a + | p va = Split Nothing a (Just (One b)) + | otherwise = Split (Just (One a)) b Nothing + where + va = i `mappend` measure a splitDigit p i (Three a b c) - | p va = Split Nothing a (Just (Two b c)) - | p vab = Split (Just (One a)) b (Just (One c)) - | otherwise = Split (Just (Two a b)) c Nothing - where va = i `mappend` measure a - vab = va `mappend` measure b + | p va = Split Nothing a (Just (Two b c)) + | p vab = Split (Just (One a)) b (Just (One c)) + | otherwise = Split (Just (Two a b)) c Nothing + where + va = i `mappend` measure a + vab = va `mappend` measure b splitDigit p i (Four a b c d) - | p va = Split Nothing a (Just (Three b c d)) - | p vab = Split (Just (One a)) b (Just (Two c d)) - | p vabc = Split (Just (Two a b)) c (Just (One d)) - | otherwise = Split (Just (Three a b c)) d Nothing - where va = i `mappend` measure a - vab = va `mappend` measure b - vabc = vab `mappend` measure c + | p va = Split Nothing a (Just (Three b c d)) + | p vab = Split (Just (One a)) b (Just (Two c d)) + | p vabc = Split (Just (Two a b)) c (Just (One d)) + | otherwise = Split (Just (Three a b c)) d Nothing + where + va = i `mappend` measure a + vab = va `mappend` measure b + vabc = vab `mappend` measure c ------------------ -- Transformations @@ -787,7 +806,7 @@ reverseTree _ Empty = Empty reverseTree f (Single x) = Single (f x) reverseTree f (Deep _ pr m sf) = - deep (reverseDigit f sf) (reverseTree (reverseNode f) m) (reverseDigit f pr) + deep (reverseDigit f sf) (reverseTree (reverseNode f) m) (reverseDigit f pr) reverseNode :: (Measured v2 a2) => (a1 -> a2) -> Node v1 a1 -> Node v2 a2 reverseNode f (Node2 _ a b) = node2 (f b) (f a) @@ -801,7 +820,7 @@ illegal_argument :: String -> a illegal_argument name = - error $ "Logic error: " ++ name ++ " called with illegal argument" + error $ "Logic error: " ++ name ++ " called with illegal argument" {- $example diff --git a/Data/IntervalMap/FingerTree.hs b/Data/IntervalMap/FingerTree.hs --- a/Data/IntervalMap/FingerTree.hs +++ b/Data/IntervalMap/FingerTree.hs @@ -11,10 +11,10 @@ -- Interval maps implemented using the 'FingerTree' type, following -- section 4.8 of -- --- * Ralf Hinze and Ross Paterson, --- \"Finger trees: a simple general-purpose data structure\", --- /Journal of Functional Programming/ 16:2 (2006) pp 197-217. --- +-- * Ralf Hinze and Ross Paterson, +-- \"Finger trees: a simple general-purpose data structure\", +-- /Journal of Functional Programming/ 16:2 (2006) pp 197-217. +-- -- -- An amortized running time is given for each operation, with /n/ -- referring to the size of the priority queue. These bounds hold even @@ -27,13 +27,13 @@ ----------------------------------------------------------------------------- module Data.IntervalMap.FingerTree ( - -- * Intervals - Interval(..), point, - -- * Interval maps - IntervalMap, empty, singleton, insert, union, - -- * Searching - search, intersections, dominators - ) where + -- * Intervals + Interval(..), point, + -- * Interval maps + IntervalMap, empty, singleton, insert, union, + -- * Searching + search, intersections, dominators + ) where import qualified Data.FingerTree as FT import Data.FingerTree (FingerTree, Measured(..), ViewL(..), (<|), (><)) @@ -50,7 +50,7 @@ -- | A closed interval. The lower bound should be less than or equal -- to the higher bound. data Interval v = Interval { low :: v, high :: v } - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show) -- | An interval in which the lower and upper bounds are equal. point :: v -> Interval v @@ -59,48 +59,48 @@ data Node v a = Node (Interval v) a instance Functor (Node v) where - fmap f (Node i x) = Node i (f x) + fmap f (Node i x) = Node i (f x) instance Foldable (Node v) where - foldMap f (Node _ x) = f x + foldMap f (Node _ x) = f x instance Traversable (Node v) where - traverse f (Node i x) = Node i <$> f x + traverse f (Node i x) = Node i <$> f x -- rightmost interval (including largest lower bound) and largest upper bound. data IntInterval v = NoInterval | IntInterval (Interval v) v instance Ord v => Monoid (IntInterval v) where - mempty = NoInterval - NoInterval `mappend` i = i - i `mappend` NoInterval = i - IntInterval _ hi1 `mappend` IntInterval int2 hi2 = - IntInterval int2 (max hi1 hi2) + mempty = NoInterval + NoInterval `mappend` i = i + i `mappend` NoInterval = i + IntInterval _ hi1 `mappend` IntInterval int2 hi2 = + IntInterval int2 (max hi1 hi2) instance (Ord v) => Measured (IntInterval v) (Node v a) where - measure (Node i _) = IntInterval i (high i) + measure (Node i _) = IntInterval i (high i) -- | Map of closed intervals, possibly with duplicates. -- The 'Foldable' and 'Traversable' instances process the intervals in -- lexicographical order. newtype IntervalMap v a = - IntervalMap (FingerTree (IntInterval v) (Node v a)) + IntervalMap (FingerTree (IntInterval v) (Node v a)) -- ordered lexicographically by interval instance Functor (IntervalMap v) where - fmap f (IntervalMap t) = IntervalMap (FT.unsafeFmap (fmap f) t) + fmap f (IntervalMap t) = IntervalMap (FT.unsafeFmap (fmap f) t) instance Foldable (IntervalMap v) where - foldMap f (IntervalMap t) = foldMap (foldMap f) t + foldMap f (IntervalMap t) = foldMap (foldMap f) t instance Traversable (IntervalMap v) where - traverse f (IntervalMap t) = - IntervalMap <$> FT.unsafeTraverse (traverse f) t + traverse f (IntervalMap t) = + IntervalMap <$> FT.unsafeTraverse (traverse f) t -- | 'empty' and 'union'. instance (Ord v) => Monoid (IntervalMap v a) where - mempty = empty - mappend = union + mempty = empty + mappend = union -- | /O(1)/. The empty interval map. empty :: (Ord v) => IntervalMap v a @@ -114,26 +114,33 @@ -- The map may contain duplicate intervals; the new entry will be inserted -- before any existing entries for the same interval. insert :: (Ord v) => Interval v -> a -> IntervalMap v a -> IntervalMap v a -insert (Interval lo hi) x m | lo > hi = m +insert (Interval lo hi) _ m | lo > hi = m insert i x (IntervalMap t) = IntervalMap (l >< Node i x <| r) - where (l, r) = FT.split larger t - larger (IntInterval k _) = k >= i + where + (l, r) = FT.split larger t + larger (IntInterval k _) = k >= i + larger NoInterval = error "larger NoInterval" -- | /O(m log (n/\//m))/. Merge two interval maps. -- The map may contain duplicate intervals; entries with equal intervals -- are kept in the original order. union :: (Ord v) => IntervalMap v a -> IntervalMap v a -> IntervalMap v a union (IntervalMap xs) (IntervalMap ys) = IntervalMap (merge1 xs ys) - where merge1 as bs = case FT.viewl as of - EmptyL -> bs - a@(Node i _) :< as' -> l >< a <| merge2 as' r - where (l, r) = FT.split larger bs - larger (IntInterval k _) = k >= i - merge2 as bs = case FT.viewl bs of - EmptyL -> as - b@(Node i _) :< bs' -> l >< b <| merge1 r bs' - where (l, r) = FT.split larger as - larger (IntInterval k _) = k > i + where + merge1 as bs = case FT.viewl as of + EmptyL -> bs + a@(Node i _) :< as' -> l >< a <| merge2 as' r + where + (l, r) = FT.split larger bs + larger (IntInterval k _) = k >= i + larger NoInterval = error "larger NoInterval" + merge2 as bs = case FT.viewl bs of + EmptyL -> as + b@(Node i _) :< bs' -> l >< b <| merge1 r bs' + where + (l, r) = FT.split larger as + larger (IntInterval k _) = k > i + larger NoInterval = error "larger NoInterval" -- | /O(k log (n/\//k))/. All intervals that intersect with the given -- interval, in lexicographical order. @@ -154,39 +161,47 @@ -- interval, in lexicographical order. inRange :: (Ord v) => v -> v -> IntervalMap v a -> [(Interval v, a)] inRange lo hi (IntervalMap t) = matches (FT.takeUntil (greater hi) t) - where matches xs = case FT.viewl (FT.dropUntil (atleast lo) xs) of - EmptyL -> [] - Node i x :< xs' -> (i, x) : matches xs' + where + matches xs = case FT.viewl (FT.dropUntil (atleast lo) xs) of + EmptyL -> [] + Node i x :< xs' -> (i, x) : matches xs' atleast :: (Ord v) => v -> IntInterval v -> Bool atleast k (IntInterval _ hi) = k <= hi +atleast _ NoInterval = error "atleast NoInterval" greater :: (Ord v) => v -> IntInterval v -> Bool greater k (IntInterval i _) = low i > k +greater _ NoInterval = error "greater NoInterval" +{- +-- Examples + mkMap :: (Ord v) => [(v, v, a)] -> IntervalMap v a mkMap = foldr ins empty - where ins (lo, hi, n) = insert (Interval lo hi) n + where + ins (lo, hi, n) = insert (Interval lo hi) n composers :: IntervalMap Int String composers = mkMap [ - (1685, 1750, "Bach"), - (1685, 1759, "Handel"), - (1732, 1809, "Haydn"), - (1756, 1791, "Mozart"), - (1770, 1827, "Beethoven"), - (1782, 1840, "Paganini"), - (1797, 1828, "Schubert"), - (1803, 1869, "Berlioz"), - (1810, 1849, "Chopin"), - (1833, 1897, "Brahms"), - (1838, 1875, "Bizet")] + (1685, 1750, "Bach"), + (1685, 1759, "Handel"), + (1732, 1809, "Haydn"), + (1756, 1791, "Mozart"), + (1770, 1827, "Beethoven"), + (1782, 1840, "Paganini"), + (1797, 1828, "Schubert"), + (1803, 1869, "Berlioz"), + (1810, 1849, "Chopin"), + (1833, 1897, "Brahms"), + (1838, 1875, "Bizet")] mathematicians :: IntervalMap Int String mathematicians = mkMap [ - (1642, 1727, "Newton"), - (1646, 1716, "Leibniz"), - (1707, 1783, "Euler"), - (1736, 1813, "Lagrange"), - (1777, 1855, "Gauss"), - (1811, 1831, "Galois")] + (1642, 1727, "Newton"), + (1646, 1716, "Leibniz"), + (1707, 1783, "Euler"), + (1736, 1813, "Lagrange"), + (1777, 1855, "Gauss"), + (1811, 1831, "Galois")] +-} diff --git a/Data/PriorityQueue/FingerTree.hs b/Data/PriorityQueue/FingerTree.hs --- a/Data/PriorityQueue/FingerTree.hs +++ b/Data/PriorityQueue/FingerTree.hs @@ -11,10 +11,10 @@ -- Min-priority queues implemented using the 'FingerTree' type, -- following section 4.6 of -- --- * Ralf Hinze and Ross Paterson, --- \"Finger trees: a simple general-purpose data structure\", --- /Journal of Functional Programming/ 16:2 (2006) pp 197-217. --- +-- * Ralf Hinze and Ross Paterson, +-- \"Finger trees: a simple general-purpose data structure\", +-- /Journal of Functional Programming/ 16:2 (2006) pp 197-217. +-- -- -- These have the same big-O complexity as skew heap implementations, -- but are approximately an order of magnitude slower. @@ -33,65 +33,63 @@ ----------------------------------------------------------------------------- module Data.PriorityQueue.FingerTree ( - PQueue, - -- * Construction - empty, - singleton, - union, - insert, - add, - fromList, - -- * Deconstruction - null, - minView, - minViewWithKey - ) where + PQueue, + -- * Construction + empty, + singleton, + union, + insert, + add, + fromList, + -- * Deconstruction + null, + minView, + minViewWithKey + ) where import qualified Data.FingerTree as FT -import Data.FingerTree (FingerTree, (<|), (|>), (><), - ViewL(..), Measured(measure)) +import Data.FingerTree (FingerTree, (<|), (|>), (><), ViewL(..), Measured(..)) import Control.Arrow ((***)) import Data.Foldable (Foldable(foldMap)) import Data.Monoid -import Data.List (unfoldr) import Prelude hiding (null) -data Entry k v = Entry { key :: k, value :: v } +data Entry k v = Entry k v instance Functor (Entry k) where - fmap f (Entry k v) = Entry k (f v) + fmap f (Entry k v) = Entry k (f v) instance Foldable (Entry k) where - foldMap f (Entry _ v) = f v + foldMap f (Entry _ v) = f v data Prio k v = NoPrio | Prio k v instance Ord k => Monoid (Prio k v) where - mempty = NoPrio - x `mappend` NoPrio = x - NoPrio `mappend` y = y - x@(Prio kx _) `mappend` y@(Prio ky _) - | kx <= ky = x - | otherwise = y + mempty = NoPrio + x `mappend` NoPrio = x + NoPrio `mappend` y = y + x@(Prio kx _) `mappend` y@(Prio ky _) + | kx <= ky = x + | otherwise = y instance Ord k => Measured (Prio k v) (Entry k v) where - measure (Entry k v) = Prio k v + measure (Entry k v) = Prio k v -- | Priority queues. newtype PQueue k v = PQueue (FingerTree (Prio k v) (Entry k v)) instance Ord k => Functor (PQueue k) where - fmap f (PQueue xs) = PQueue (FT.fmap' (fmap f) xs) + fmap f (PQueue xs) = PQueue (FT.fmap' (fmap f) xs) instance Ord k => Foldable (PQueue k) where - foldMap f q = case minView q of - Nothing -> mempty - Just (v, q') -> f v `mappend` foldMap f q' + foldMap f q = case minView q of + Nothing -> mempty + Just (v, q') -> f v `mappend` foldMap f q' instance Ord k => Monoid (PQueue k v) where - mempty = empty - mappend = union + mempty = empty + mappend = union -- | /O(1)/. The empty priority queue. empty :: Ord k => PQueue k v @@ -165,10 +163,11 @@ minViewWithKey (PQueue q) | FT.null q = Nothing | otherwise = Just ((k, v), case FT.viewl r of - _ :< r' -> PQueue (l >< r') - _ -> error "can't happen") - where Prio k v = measure q - (l, r) = FT.split (below k) q + _ :< r' -> PQueue (l >< r') + _ -> error "can't happen") + where + Prio k v = measure q + (l, r) = FT.split (below k) q below :: Ord k => k -> Prio k v -> Bool below _ NoPrio = False diff --git a/fingertree.cabal b/fingertree.cabal --- a/fingertree.cabal +++ b/fingertree.cabal @@ -1,5 +1,5 @@ Name: fingertree -Version: 0.1.0.0 +Version: 0.1.0.1 Cabal-Version: >= 1.8 Copyright: (c) 2006 Ross Paterson, Ralf Hinze License: BSD3