diff --git a/Data/FingerTree.hs b/Data/FingerTree.hs --- a/Data/FingerTree.hs +++ b/Data/FingerTree.hs @@ -1,796 +1,1416 @@ -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances #-} ------------------------------------------------------------------------------ --- | --- Module : Data.FingerTree --- Copyright : (c) Ross Paterson, Ralf Hinze 2006 --- License : BSD-style --- Maintainer : ross@soi.city.ac.uk --- Stability : experimental --- Portability : non-portable (MPTCs and functional dependencies) --- --- A general sequence representation with arbitrary annotations, for --- 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. --- --- --- For a directly usable sequence type, see @Data.Sequence@, which is --- a specialization of this structure. --- --- An amortized running time is given for each operation, with /n/ --- referring to the length of the sequence. These bounds hold even in --- a persistent (shared) setting. --- --- /Note/: Many of these operations have the same names as similar --- operations on lists in the "Prelude". The ambiguity may be resolved --- using either qualification or the @hiding@ clause. --- ------------------------------------------------------------------------------ - -module Data.FingerTree ( - FingerTree, - 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) - -import Control.Applicative (Applicative(pure, (<*>)), (<$>)) -import Data.Monoid -import Data.Foldable (Foldable(foldMap), toList) -import Data.Traversable (Traversable(traverse)) - -infixr 5 >< -infixr 5 <|, :< -infixl 5 |>, :> - --- | 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) - --- | 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) - -instance Functor s => Functor (ViewL s) where - fmap f EmptyL = EmptyL - fmap f (x :< xs) = f x :< fmap f xs - -instance Functor s => Functor (ViewR s) where - fmap f EmptyR = EmptyR - fmap f (xs :> x) = fmap f xs :> f x - -instance Measured v a => Monoid (FingerTree v a) where - 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 - -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 - -------------------- --- 4.1 Measurements -------------------- - --- | Things that can be measured. -class (Monoid v) => Measured v a | a -> v where - measure :: a -> v - -instance (Measured v a) => Measured v (Digit a) where - measure = foldMap measure - ---------------------------- --- 4.2 Caching measurements ---------------------------- - -data Node v a = Node2 !v a a | Node3 !v a a a - 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 - -node2 :: (Measured v a) => a -> a -> Node v a -node2 a b = Node2 (measure a `mappend` measure b) a b - -node3 :: (Measured v a) => a -> a -> a -> Node v a -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 - -nodeToDigit :: Node v a -> Digit a -nodeToDigit (Node2 _ a b) = Two a b -nodeToDigit (Node3 _ a b c) = Three a b c - --- | A representation of a sequence of values of type @a@, allowing --- access to the ends in constant time, and append and split in time --- logarithmic in the size of the smaller piece. --- --- The collection is also parameterized by a measure type @v@, which --- is used to specify a position in the sequence for the 'split' operation. --- The types of the operations enforce the constraint @'Measured' v a@, --- which also implies that the type @v@ is determined by @a@. --- --- 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) - -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 - -instance (Measured v a) => Measured v (FingerTree v a) where - 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 - -instance (Measured v a, Eq a) => Eq (FingerTree v a) where - xs == ys = toList xs == toList ys - -instance (Measured v a, Ord a) => Ord (FingerTree v a) where - compare xs ys = compare (toList xs) (toList ys) - -instance (Measured v a, Show a) => Show (FingerTree v a) where - showsPrec p xs = showParen (p > 10) $ - showString "fromList " . shows (toList xs) - --- | Like 'fmap', but with a more constrained type. -fmap' :: (Measured v1 a1, Measured v2 a2) => - (a1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2 -fmap' = mapTree - -mapTree :: (Measured 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) - -mapNode :: (Measured 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) - -mapDigit :: (a -> b) -> Digit a -> Digit b -mapDigit f (One a) = One (f a) -mapDigit f (Two a b) = Two (f a) (f b) -mapDigit f (Three a b c) = Three (f a) (f b) (f c) -mapDigit f (Four a b c d) = Four (f a) (f b) (f c) (f d) - --- | 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 -fmapWithPos f = mapWPTree f mempty - -mapWPTree :: (Measured v1 a1, Measured 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 - -mapWPNode :: (Measured v1 a1, Measured 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 -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 - -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 -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 -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 - --- | 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) - -unsafeFmapNode :: (a -> b) -> Node v a -> Node v b -unsafeFmapNode f (Node2 v a b) = Node2 v (f a) (f b) -unsafeFmapNode f (Node3 v a b c) = Node3 v (f a) (f b) (f c) - --- | 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) -traverse' = traverseTree - -traverseTree :: (Measured v2 a2, Applicative f) => - (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 - -traverseNode :: (Measured v2 a2, Applicative f) => - (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 - -traverseDigit :: (Applicative f) => (a -> f b) -> Digit a -> f (Digit b) -traverseDigit f (One a) = One <$> f a -traverseDigit f (Two a b) = Two <$> f a <*> f b -traverseDigit f (Three a b c) = Three <$> f a <*> f b <*> f c -traverseDigit f (Four a b c d) = Four <$> f a <*> f b <*> f c <*> f d - --- | 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) -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) -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 - -traverseWPNode :: (Measured v1 a1, Measured v2 a2, Applicative f) => - (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 -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 - -traverseWPDigit :: (Measured v a, Applicative f) => - (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 -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 -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 - --- | Like 'traverse', but safe only if the function preserves the measure. -unsafeTraverse :: (Applicative f) => - (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 - -unsafeTraverseNode :: (Applicative f) => - (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 - ------------------------------------------------------ --- 4.3 Construction, deconstruction and concatenation ------------------------------------------------------ - --- | /O(1)/. The empty sequence. -empty :: Measured v a => FingerTree v a -empty = Empty - --- | /O(1)/. A singleton sequence. -singleton :: Measured v a => a -> FingerTree v a -singleton = Single - --- | /O(n)/. Create a sequence from a finite list of elements. -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 <| 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 - -consDigit :: a -> Digit a -> Digit a -consDigit a (One b) = Two a b -consDigit a (Two b c) = Three a b c -consDigit a (Three b c d) = Four a b c d - --- | /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) -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) - -snocDigit :: Digit a -> a -> Digit a -snocDigit (One a) b = Two a b -snocDigit (Two a b) c = Three a b c -snocDigit (Three a b c) d = Four a b c d - --- | /O(1)/. Is this the empty sequence? -null :: (Measured v a) => FingerTree v a -> Bool -null Empty = True -null _ = False - --- | /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 - -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 - -lheadDigit :: Digit a -> a -lheadDigit (One a) = a -lheadDigit (Two a _) = a -lheadDigit (Three a _ _) = a -lheadDigit (Four a _ _ _) = a - -ltailDigit :: Digit a -> Digit a -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 - -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) - -rheadDigit :: Digit a -> a -rheadDigit (One a) = a -rheadDigit (Two _ b) = b -rheadDigit (Three _ _ c) = c -rheadDigit (Four _ _ _ d) = d - -rtailDigit :: Digit a -> Digit a -rtailDigit (Two a _) = One a -rtailDigit (Three a b _) = Two a b -rtailDigit (Four a b c _) = Three a b c - -digitToTree :: (Measured v a) => Digit a -> FingerTree v a -digitToTree (One a) = Single a -digitToTree (Two a b) = deep (One a) Empty (One b) -digitToTree (Three a b c) = deep (Two a b) Empty (One c) -digitToTree (Four a b c d) = deep (Two a b) Empty (Two c d) - ----------------- --- Concatenation ----------------- - --- | /O(log(min(n1,n2)))/. Concatenate two sequences. -(><) :: (Measured v a) => FingerTree v a -> FingerTree v a -> FingerTree v a -(><) = appendTree0 - -appendTree0 :: (Measured v a) => FingerTree v a -> FingerTree v a -> FingerTree v a -appendTree0 Empty xs = - xs -appendTree0 xs Empty = - xs -appendTree0 (Single x) xs = - x <| xs -appendTree0 xs (Single x) = - xs |> x -appendTree0 (Deep _ pr1 m1 sf1) (Deep _ 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 -addDigits0 m1 (One a) (Two 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 -addDigits0 m1 (One a) (Four b c 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 -addDigits0 m1 (Two a b) (Two 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 -addDigits0 m1 (Two a b) (Four c 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 -addDigits0 m1 (Three a b c) (Two 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 -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 -addDigits0 m1 (Four a b c d) (One 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 -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 -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 - -appendTree1 :: (Measured v a) => FingerTree v a -> a -> FingerTree v a -> FingerTree v a -appendTree1 Empty a xs = - a <| xs -appendTree1 xs a Empty = - xs |> a -appendTree1 (Single x) a xs = - x <| a <| xs -appendTree1 xs a (Single x) = - xs |> a |> x -appendTree1 (Deep _ pr1 m1 sf1) a (Deep _ 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 -addDigits1 m1 (One a) b (Two 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 -addDigits1 m1 (One a) b (Four c 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 -addDigits1 m1 (Two a b) c (Two 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 -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 -addDigits1 m1 (Three a b c) d (One 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 -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 -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 -addDigits1 m1 (Four a b c d) e (One 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 -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 -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 - -appendTree2 :: (Measured v a) => FingerTree v a -> a -> a -> FingerTree v a -> FingerTree v a -appendTree2 Empty a b xs = - a <| b <| xs -appendTree2 xs a b Empty = - xs |> a |> b -appendTree2 (Single x) a b xs = - x <| a <| b <| xs -appendTree2 xs a b (Single 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 - -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 -addDigits2 m1 (One a) b c (Two 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 -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 -addDigits2 m1 (Two a b) c d (One 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 -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 -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 -addDigits2 m1 (Three a b c) d e (One 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 -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 -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 -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 -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 -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 -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 - -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 -appendTree3 xs a b c Empty = - xs |> a |> b |> c -appendTree3 (Single x) a b c xs = - x <| a <| b <| c <| xs -appendTree3 xs a b c (Single 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 - -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 -addDigits3 m1 (One a) b c d (Two 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 -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 -addDigits3 m1 (Two a b) c d e (One 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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 :: (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 -appendTree4 xs a b c d Empty = - xs |> a |> b |> c |> d -appendTree4 (Single 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 -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 - -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 - ----------------- --- 4.4 Splitting ----------------- - --- | /O(log(min(i,n-i)))/. Split a sequence at a point where the predicate --- on the accumulated measure changes from 'False' to 'True'. --- --- 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 _p Empty = (Empty, Empty) -split p xs - | p (measure xs) = (l, x <| r) - | 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 --- prefix of @t@ whose measure does not satisfy @p@. --- --- * @'takeUntil' p t = 'fst' ('split' p t)@ -takeUntil :: (Measured v a) => (v -> Bool) -> FingerTree v a -> FingerTree v a -takeUntil p = fst . split p - --- | /O(log(min(i,n-i)))/. --- Given a monotonic predicate @p@, @'dropUntil' p t@ is the rest of @t@ --- after removing the largest prefix whose measure does not satisfy @p@. --- --- * @'dropUntil' p t = 'snd' ('split' p t)@ -dropUntil :: (Measured v a) => (v -> Bool) -> FingerTree v a -> FingerTree v a -dropUntil p = snd . split p - -data Split t a = Split t a t - -splitTree :: (Measured v a) => - (v -> Bool) -> v -> FingerTree v a -> Split (FingerTree v a) a -splitTree _p _i (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 - --- 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 - -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 -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 -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 - -splitDigit :: (Measured v a) => (v -> Bool) -> v -> Digit a -> - Split (Maybe (Digit a)) a -splitDigit p 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 -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 -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 - ------------------- --- Transformations ------------------- - --- | /O(n)/. The reverse of a sequence. -reverse :: (Measured v a) => FingerTree v a -> FingerTree v a -reverse = reverseTree id - -reverseTree :: (Measured v2 a2) => (a1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2 -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) - -reverseNode :: (Measured v2 a2) => (a1 -> a2) -> Node v1 a1 -> Node v2 a2 -reverseNode f (Node2 _ a b) = node2 (f b) (f a) -reverseNode f (Node3 _ a b c) = node3 (f c) (f b) (f a) - -reverseDigit :: (a -> b) -> Digit a -> Digit b -reverseDigit f (One a) = One (f a) -reverseDigit f (Two a b) = Two (f b) (f a) -reverseDigit f (Three a b c) = Three (f c) (f b) (f a) -reverseDigit f (Four a b c d) = Four (f d) (f c) (f b) (f a) - -{- $example - -Particular abstract data types may be implemented by defining -element types with suitable 'Measured' instances. - -(from section 4.5 of the paper) -Simple sequences can be implemented using a 'Sum' monoid as a measure: +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE DeriveGeneric #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 802 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE DeriveAnyClass #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Data.FingerTree +-- Copyright : Ross Paterson and Ralf Hinze 2006, +-- Ross Paterson 2006-2022, +-- James Cranch 2021 +-- License : BSD-style +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : non-portable (MPTCs and functional dependencies) +-- +-- A general sequence representation with arbitrary annotations, for +-- 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. +-- +-- +-- For a directly usable sequence type, see @Data.Sequence@, which is +-- a specialization of this structure. +-- +-- An amortized running time is given for each operation, with /n/ +-- referring to the length of the sequence. These bounds hold even in +-- a persistent (shared) setting. +-- +-- /Note/: Many of these operations have the same names as similar +-- operations on lists in the "Prelude". The ambiguity may be resolved +-- using either qualification or the @hiding@ clause. +-- +----------------------------------------------------------------------------- + +module Data.FingerTree ( +#if TESTING + FingerTree(..), Digit(..), Node(..), deep, node2, node3, +#else + FingerTree, +#endif + Measured(..), + -- * Construction + empty, singleton, + (<|), (|>), (><), + fromList, + -- * Deconstruction + null, + -- ** Examining the ends + ViewL(..), viewl, + ViewR(..), viewr, + -- ** Search + SearchResult(..), search, + -- ** Splitting + -- | These functions are special cases of 'search'. + split, takeUntil, dropUntil, + -- * Transformation + reverse, + -- ** Maps + fmap', fmapWithPos, fmapWithContext, unsafeFmap, + -- ** Folds + foldlWithPos, foldrWithPos, foldlWithContext, foldrWithContext, + -- ** Traversals + traverse', traverseWithPos, traverseWithContext, unsafeTraverse, + -- * Example + -- $example + ) where + +import Prelude hiding (null, reverse) +#if MIN_VERSION_base(4,6,0) +import GHC.Generics +#endif +#if MIN_VERSION_base(4,8,0) +import qualified Prelude (null) +#else +import Control.Applicative (Applicative(pure, (<*>)), (<$>)) +import Data.Monoid +#endif +#if !(MIN_VERSION_base(4,8,0)) || defined(__MHS__) +import Data.Foldable (Foldable(foldMap)) +#endif +#if (MIN_VERSION_base(4,9,0)) && !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup +#endif +import Control.DeepSeq +import Data.Foldable (toList) + +infixr 5 >< +infixr 5 <|, :< +infixl 5 |>, :> + +-- | 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 +#if __GLASGOW_HASKELL__ >= 706 + , Generic +#if __GLASGOW_HASKELL__ >= 710 + , NFData +#endif +#endif + ) + +-- | 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 +#if __GLASGOW_HASKELL__ >= 706 + , Generic +#if __GLASGOW_HASKELL__ >= 710 + , NFData +#endif +#endif + ) + +instance (Functor s) => Functor (ViewL s) where + 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 + +#if MIN_VERSION_base(4,9,0) +instance (Measured v a) => Semigroup (FingerTree v a) where + (<>) = (><) +#endif + +-- | 'empty' and '><'. +instance (Measured v a) => Monoid (FingerTree v a) where + mempty = empty +#if !(MIN_VERSION_base(4,11,0)) + mappend = (><) +#endif + +-- Explicit Digit type (Exercise 1) + +data Digit a + = One a + | Two a a + | Three a a a + | Four a a a a + deriving (Show +#if __GLASGOW_HASKELL__ >= 706 + , Generic +#if __GLASGOW_HASKELL__ >= 710 + , NFData +#endif +#endif + ) + +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 + +------------------- +-- 4.1 Measurements +------------------- + +-- | Things that can be measured. +class (Monoid v) => Measured v a | a -> v where + measure :: a -> v + +instance (Measured v a) => Measured v (Digit a) where + measure = foldMap measure + +--------------------------- +-- 4.2 Caching measurements +--------------------------- + +data Node v a = Node2 !v a a | Node3 !v a a a + deriving (Show +#if __GLASGOW_HASKELL__ >= 706 + , Generic +#if __GLASGOW_HASKELL__ >= 710 + , NFData +#endif +#endif + ) + +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 + +node2 :: (Measured v a) => a -> a -> Node v a +node2 a b = Node2 (measure a `mappend` measure b) a b + +node3 :: (Measured v a) => a -> a -> a -> Node v a +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 + +nodeToDigit :: Node v a -> Digit a +nodeToDigit (Node2 _ a b) = Two a b +nodeToDigit (Node3 _ a b c) = Three a b c + +-- | A representation of a sequence of values of type @a@, allowing +-- access to the ends in constant time, and append and split in time +-- logarithmic in the size of the smaller piece. +-- +-- The collection is also parameterized by a measure type @v@, which +-- is used to specify a position in the sequence for the 'split' operation. +-- The types of the operations enforce the constraint @'Measured' v a@, +-- which also implies that the type @v@ is determined by @a@. +-- +-- 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) +#if TESTING + deriving (Show +#if __GLASGOW_HASKELL__ >= 706 + , Generic +#if __GLASGOW_HASKELL__ >= 710 + , NFData +#endif +#endif + ) +#elif __GLASGOW_HASKELL__ >= 710 + deriving (Generic, NFData) +#elif __GLASGOW_HASKELL__ >= 706 + deriving (Generic) +#endif + +deep :: (Measured v a) => + Digit a -> FingerTree v (Node v a) -> Digit a -> FingerTree v a +deep pr m sf = + Deep ((measure pr `mappend` measure 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 + +-- | Elements from left to right. +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 + +#if MIN_VERSION_base(4,8,0) + null Empty = True + null _ = False +#endif + +instance (Eq a) => Eq (FingerTree v a) where + xs == ys = toList xs == toList ys + +-- | Lexicographical order from left to right. +instance (Ord a) => Ord (FingerTree v a) where + 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) +#endif + +-- | Like 'fmap', but with constraints on the element types. +fmap' :: (Measured v1 a1, Measured v2 a2) => + (a1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2 +fmap' = mapTree + +mapTree :: (Measured 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) + +mapNode :: (Measured 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) + +mapDigit :: (a -> b) -> Digit a -> Digit b +mapDigit f (One a) = One (f a) +mapDigit f (Two a b) = Two (f a) (f b) +mapDigit f (Three a b c) = Three (f a) (f b) (f c) +mapDigit f (Four a b c d) = Four (f a) (f b) (f c) (f d) + +-- | 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 +fmapWithPos f = mapWPTree f mempty + +mapWPTree :: (Measured v1 a1, Measured v2 a2) => + (v1 -> a1 -> a2) -> v1 -> FingerTree v1 a1 -> FingerTree v2 a2 +mapWPTree _ _ Empty = Empty +mapWPTree f vl (Single x) = Single (f vl x) +mapWPTree f vl (Deep _ pr m sf) = + deep (mapWPDigit f vl pr) + (mapWPTree (mapWPNode f) vlp m) + (mapWPDigit f vlpm sf) + where + vlp = vl `mappend` measure pr + vlpm = vlp `mappend` measure m + +mapWPNode :: (Measured v1 a1, Measured v2 a2) => + (v1 -> a1 -> a2) -> v1 -> Node v1 a1 -> Node v2 a2 +mapWPNode f vl (Node2 _ a b) = node2 (f vl a) (f vla b) + where + vla = vl `mappend` measure a +mapWPNode f vl (Node3 _ a b c) = node3 (f vl a) (f vla b) (f vlab c) + where + va = vl `mappend` measure a + vla = vl `mappend` measure a + vlab = vla `mappend` measure b + +mapWPDigit :: (Measured v a) => (v -> a -> b) -> v -> Digit a -> Digit b +mapWPDigit f vl (One a) = One (f vl a) +mapWPDigit f vl (Two a b) = Two (f vl a) (f vla b) + where + vla = vl `mappend` measure a +mapWPDigit f vl (Three a b c) = Three (f vl a) (f vla b) (f vlab c) + where + vla = vl `mappend` measure a + vlab = vla `mappend` measure b +mapWPDigit f vl (Four a b c d) = Four (f vl a) (f vla b) (f vlab c) (f vlabc d) + where + vla = vl `mappend` measure a + vlab = vla `mappend` measure b + vlabc = vlab `mappend` measure c + +-- | Map all elements of the tree with a function that also takes the +-- measure of the prefix to the left and of the suffix to the right of +-- the element. +-- +-- @since 0.1.2.0 +fmapWithContext :: (Measured v1 a1, Measured v2 a2) => + (v1 -> a1 -> v1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2 +fmapWithContext f t = mapWCTree f mempty t mempty + +mapWCTree :: (Measured v1 a1, Measured v2 a2) => + (v1 -> a1 -> v1 -> a2) -> v1 -> FingerTree v1 a1 -> v1 -> FingerTree v2 a2 +mapWCTree _ _ Empty _ = Empty +mapWCTree f vl (Single x) vr = Single (f vl x vr) +mapWCTree f vl (Deep _ pr m sf) vr = + deep (mapWCDigit f vl pr vmsr) + (mapWCTree (mapWCNode f) vlp m vsr) + (mapWCDigit f vlpm sf vr) + where + vlp = vl `mappend` measure pr + vlpm = vlp `mappend` vm + vmsr = vm `mappend` vsr + vsr = measure sf `mappend` vr + vm = measure m + +mapWCNode :: (Measured v1 a1, Measured v2 a2) => + (v1 -> a1 -> v1 -> a2) -> v1 -> Node v1 a1 -> v1 -> Node v2 a2 +mapWCNode f vl (Node2 _ a b) vr = node2 (f vl a vbr) (f vla b vr) + where + vla = vl `mappend` measure a + vbr = measure b `mappend` vr +mapWCNode f vl (Node3 _ a b c) vr = + node3 (f vl a vbcr) (f vla b vcr) (f vlab c vr) + where + vla = vl `mappend` measure a + vlab = vla `mappend` measure b + vcr = measure c `mappend` vr + vbcr = measure b `mappend` vcr + +mapWCDigit :: + (Measured v a) => (v -> a -> v -> b) -> v -> Digit a -> v -> Digit b +mapWCDigit f vl (One a) vr = One (f vl a vr) +mapWCDigit f vl (Two a b) vr = Two (f vl a vbr) (f vla b vr) + where + vla = vl `mappend` measure a + vbr = measure b `mappend` vr +mapWCDigit f vl (Three a b c) vr = + Three (f vl a vbcr) (f vla b vcr) (f vlab c vr) + where + vla = vl `mappend` measure a + vlab = vla `mappend` measure b + vcr = measure c `mappend` vr + vbcr = measure b `mappend` vcr +mapWCDigit f vl (Four a b c d) vr = + Four (f vl a vbcdr) (f vla b vcdr) (f vlab c vdr) (f vlabc d vr) + where + vla = vl `mappend` measure a + vlab = vla `mappend` measure b + vlabc = vlab `mappend` measure c + vdr = measure d `mappend` vr + vcdr = measure c `mappend` vdr + vbcdr = measure b `mappend` vcdr + +-- | 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) + +unsafeFmapNode :: (a -> b) -> Node v a -> Node v b +unsafeFmapNode f (Node2 v a b) = Node2 v (f a) (f b) +unsafeFmapNode f (Node3 v a b c) = Node3 v (f a) (f b) (f c) + +-- | Fold the tree from the left with a function that also takes the +-- measure of the prefix to the left of the element. +-- +-- @since 0.1.5.0 +foldlWithPos :: (Measured v a) => + (b -> v -> a -> b) -> b -> FingerTree v a -> b +foldlWithPos f z = foldlWPTree f z mempty + +foldlWPTree :: (Measured v a) => + (b -> v -> a -> b) -> b -> v -> FingerTree v a -> b +foldlWPTree _ z _ Empty = z +foldlWPTree f z vl (Single x) = f z vl x +foldlWPTree f z vl (Deep _ pr m sf) = zpms + where + vlp = vl `mappend` measure pr + vlpm = vlp `mappend` measure m + zp = foldlWPDigit f z vl pr + zpm = foldlWPTree (foldlWPNode f) zp vlp m + zpms = foldlWPDigit f zpm vlpm sf + +foldlWPNode :: (Measured v a) => + (b -> v -> a -> b) -> b -> v -> Node v a -> b +foldlWPNode f z vl (Node2 _ a b) = f (f z vl a) vla b + where + vla = vl `mappend` measure a +foldlWPNode f z vl (Node3 _ a b c) = f (f (f z vl a) vla b) vlab c + where + vla = vl `mappend` measure a + vlab = vla `mappend` measure b + +foldlWPDigit :: (Measured v a) => + (b -> v -> a -> b) -> b -> v -> Digit a -> b +foldlWPDigit f z vl (One a) = f z vl a +foldlWPDigit f z vl (Two a b) = f (f z vl a) vla b + where + vla = vl `mappend` measure a +foldlWPDigit f z vl (Three a b c) = f (f (f z vl a) vla b) vlab c + where + vla = vl `mappend` measure a + vlab = vla `mappend` measure b +foldlWPDigit f z vl (Four a b c d) = f (f (f (f z vl a) vla b) vlab c) vlabc d + where + vla = vl `mappend` measure a + vlab = vla `mappend` measure b + vlabc = vlab `mappend` measure c + +-- | Fold the tree from the right with a function that also takes the +-- measure of the prefix to the left of the element. +-- +-- @since 0.1.5.0 +foldrWithPos :: (Measured v a) => + (v -> a -> b -> b) -> b -> FingerTree v a -> b +foldrWithPos f z = foldrWPTree f z mempty + +foldrWPTree :: (Measured v a) => + (v -> a -> b -> b) -> b -> v -> FingerTree v a -> b +foldrWPTree _ z _ Empty = z +foldrWPTree f z vl (Single x) = f vl x z +foldrWPTree f z vl (Deep _ pr m sf) = zpms + where + vlp = vl `mappend` measure pr + vlpm = vlp `mappend` measure m + zpms = foldrWPDigit f zms vl pr + zms = foldrWPTree (foldrWPNode f) zs vlp m + zs = foldrWPDigit f z vlpm sf + +-- different argument order for convenience +foldrWPNode :: (Measured v a) => + (v -> a -> b -> b) -> v -> Node v a -> b -> b +foldrWPNode f vl (Node2 _ a b) z = f vl a (f vla b z) + where + vla = vl `mappend` measure a +foldrWPNode f vl (Node3 _ a b c) z = f vl a (f vla b (f vlab c z)) + where + vla = vl `mappend` measure a + vlab = vla `mappend` measure b + +foldrWPDigit :: (Measured v a) => + (v -> a -> b -> b) -> b -> v -> Digit a -> b +foldrWPDigit f z vl (One a) = f vl a z +foldrWPDigit f z vl (Two a b) = f vl a (f vla b z) + where + vla = vl `mappend` measure a +foldrWPDigit f z vl (Three a b c) = f vl a (f vla b (f vlab c z)) + where + vla = vl `mappend` measure a + vlab = vla `mappend` measure b +foldrWPDigit f z vl (Four a b c d) = f vl a (f vla b (f vlab c (f vlabc d z))) + where + vla = vl `mappend` measure a + vlab = vla `mappend` measure b + vlabc = vlab `mappend` measure c + +-- | Fold the tree from the left with a function that also takes the +-- measure of the prefix to the left of the element and the measure of +-- the suffix to the right of the element. +-- +-- @since 0.1.5.0 +foldlWithContext :: (Measured v a) => + (b -> v -> a -> v -> b) -> b -> FingerTree v a -> b +foldlWithContext f z t = foldlWCTree f z mempty t mempty + +foldlWCTree :: (Measured v a) => + (b -> v -> a -> v -> b) -> b -> v -> FingerTree v a -> v -> b +foldlWCTree _ z _ Empty _ = z +foldlWCTree f z vl (Single x) vr = f z vl x vr +foldlWCTree f z vl (Deep _ pr m sf) vr = zpms + where + vlp = vl `mappend` measure pr + vlpm = vlp `mappend` vm + vmsr = vm `mappend` vsr + vsr = measure sf `mappend` vr + vm = measure m + zp = foldlWCDigit f z vl pr vmsr + zpm = foldlWCTree (foldlWCNode f) zp vlp m vsr + zpms = foldlWCDigit f zpm vlpm sf vr + +foldlWCNode :: (Measured v a) => + (b -> v -> a -> v -> b) -> b -> v -> Node v a -> v -> b +foldlWCNode f z vl (Node2 _ a b) vr = f (f z vl a vbr) vla b vr + where + vla = vl `mappend` measure a + vbr = measure b `mappend` vr +foldlWCNode f z vl (Node3 _ a b c) vr = + f (f (f z vl a vbcr) vla b vcr) vlab c vr + where + vla = vl `mappend` measure a + vlab = vla `mappend` measure b + vcr = measure c `mappend` vr + vbcr = measure b `mappend` vcr + +foldlWCDigit :: (Measured v a) => + (b -> v -> a -> v -> b) -> b -> v -> Digit a -> v -> b +foldlWCDigit f z vl (One a) vr = f z vl a vr +foldlWCDigit f z vl (Two a b) vr = f (f z vl a vbr) vla b vr + where + vla = vl `mappend` measure a + vbr = measure b `mappend` vr +foldlWCDigit f z vl (Three a b c) vr = + f (f (f z vl a vbcr) vla b vcr) vlab c vr + where + vla = vl `mappend` measure a + vlab = vla `mappend` measure b + vcr = measure c `mappend` vr + vbcr = measure b `mappend` vcr +foldlWCDigit f z vl (Four a b c d) vr = + f (f (f (f z vl a vbcdr) vla b vcdr) vlab c vdr) vlabc d vr + where + vla = vl `mappend` measure a + vlab = vla `mappend` measure b + vlabc = vlab `mappend` measure c + vdr = measure d `mappend` vr + vcdr = measure c `mappend` vdr + vbcdr = measure b `mappend` vcdr + +-- | Fold the tree from the right with a function that also takes the +-- measure of the prefix to the left of the element and the measure of +-- the suffix to the right of the element. +-- +-- @since 0.1.5.0 +foldrWithContext :: (Measured v a) => + (v -> a -> v -> b -> b) -> b -> FingerTree v a -> b +foldrWithContext f z t = foldrWCTree f z mempty t mempty + +foldrWCTree :: (Measured v a) => + (v -> a -> v -> b -> b) -> b -> v -> FingerTree v a -> v -> b +foldrWCTree _ z _ Empty _ = z +foldrWCTree f z vl (Single x) vr = f vl x vr z +foldrWCTree f z vl (Deep _ pr m sf) vr = zpms + where + vlp = vl `mappend` measure pr + vlpm = vlp `mappend` vm + vmsr = vm `mappend` vsr + vsr = measure sf `mappend` vr + vm = measure m + zpms = foldrWCDigit f zms vl pr vmsr + zms = foldrWCTree (foldrWCNode f) zs vlp m vsr + zs = foldrWCDigit f z vlpm sf vr + +-- different argument order for convenience +foldrWCNode :: (Measured v a) => + (v -> a -> v -> b -> b) -> v -> Node v a -> v -> b -> b +foldrWCNode f vl (Node2 _ a b) vr z = f vl a vbr (f vla b vr z) + where + vla = vl `mappend` measure a + vbr = measure b `mappend` vr +foldrWCNode f vl (Node3 _ a b c) vr z = + f vl a vbcr (f vla b vcr (f vlab c vr z)) + where + vla = vl `mappend` measure a + vlab = vla `mappend` measure b + vcr = measure c `mappend` vr + vbcr = measure b `mappend` vcr + +foldrWCDigit :: (Measured v a) => + (v -> a -> v -> b -> b) -> b -> v -> Digit a -> v -> b +foldrWCDigit f z vl (One a) vr = f vl a vr z +foldrWCDigit f z vl (Two a b) vr = f vl a vbr (f vla b vr z) + where + vla = vl `mappend` measure a + vbr = measure b `mappend` vr +foldrWCDigit f z vl (Three a b c) vr = + f vl a vbcr (f vla b vcr (f vlab c vr z)) + where + vla = vl `mappend` measure a + vlab = vla `mappend` measure b + vcr = measure c `mappend` vr + vbcr = measure b `mappend` vcr +foldrWCDigit f z vl (Four a b c d) vr = + f vl a vbcdr (f vla b vcdr (f vlab c vdr (f vlabc d vr z))) + where + vla = vl `mappend` measure a + vlab = vla `mappend` measure b + vlabc = vlab `mappend` measure c + vdr = measure d `mappend` vr + vcdr = measure c `mappend` vdr + vbcdr = measure b `mappend` vcdr + +-- | Like 'traverse', but with constraints on the element types. +traverse' :: (Measured v1 a1, Measured v2 a2, Applicative f) => + (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) +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 + +traverseNode :: (Measured v2 a2, Applicative f) => + (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 + +traverseDigit :: (Applicative f) => (a -> f b) -> Digit a -> f (Digit b) +traverseDigit f (One a) = One <$> f a +traverseDigit f (Two a b) = Two <$> f a <*> f b +traverseDigit f (Three a b c) = Three <$> f a <*> f b <*> f c +traverseDigit f (Four a b c d) = Four <$> f a <*> f b <*> f c <*> f d + +-- | Traverse the tree from left to right 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) +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) +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 `mappend` measure m + +traverseWPNode :: (Measured v1 a1, Measured v2 a2, Applicative f) => + (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 +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 + +traverseWPDigit :: (Measured v a, Applicative f) => + (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 +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 +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 + +-- | Traverse the tree from left to right with a function that also +-- takes the measure of the prefix to the left and the measure of the +-- suffix to the right of the element. +-- +-- @since 0.1.2.0 +traverseWithContext :: (Measured v1 a1, Measured v2 a2, Applicative f) => + (v1 -> a1 -> v1 -> f a2) -> FingerTree v1 a1 -> f (FingerTree v2 a2) +traverseWithContext f t = traverseWCTree f mempty t mempty + +traverseWCTree :: (Measured v1 a1, Measured v2 a2, Applicative f) => + (v1 -> a1 -> v1 -> f a2) -> v1 -> FingerTree v1 a1 -> v1 -> f (FingerTree v2 a2) +traverseWCTree _ _ Empty _ = pure Empty +traverseWCTree f vl (Single x) vr = Single <$> f vl x vr +traverseWCTree f vl (Deep _ pr m sf) vr = + deep <$> traverseWCDigit f vl pr vmsr <*> traverseWCTree (traverseWCNode f) vlp m vsr <*> traverseWCDigit f vlpm sf vr + where + vlp = vl `mappend` measure pr + vlpm = vlp `mappend` vm + vmsr = vm `mappend` vsr + vsr = measure sf `mappend` vr + vm = measure m + +traverseWCNode :: (Measured v1 a1, Measured v2 a2, Applicative f) => + (v1 -> a1 -> v1 -> f a2) -> v1 -> Node v1 a1 -> v1 -> f (Node v2 a2) +traverseWCNode f vl (Node2 _ a b) vr = node2 <$> f vl a vbr <*> f vla b vr + where + vla = vl `mappend` measure a + vbr = measure b `mappend` vr +traverseWCNode f vl (Node3 _ a b c) vr = + node3 <$> f vl a vbcr <*> f vla b vcr <*> f vlab c vr + where + vla = vl `mappend` measure a + vlab = vla `mappend` measure b + vcr = measure c `mappend` vr + vbcr = measure b `mappend` vcr + +traverseWCDigit :: (Measured v a, Applicative f) => + (v -> a -> v -> f b) -> v -> Digit a -> v -> f (Digit b) +traverseWCDigit f vl (One a) vr = One <$> f vl a vr +traverseWCDigit f vl (Two a b) vr = Two <$> f vl a vbr <*> f vla b vr + where + vla = vl `mappend` measure a + vbr = measure b `mappend` vr +traverseWCDigit f vl (Three a b c) vr = + Three <$> f vl a vbcr <*> f vla b vcr <*> f vlab c vr + where + vla = vl `mappend` measure a + vlab = vla `mappend` measure b + vcr = measure c `mappend` vr + vbcr = measure b `mappend` vcr +traverseWCDigit f vl (Four a b c d) vr = + Four <$> f vl a vbcdr <*> f vla b vcdr <*> f vlab c vdr <*> f vlabc d vr + where + vla = vl `mappend` measure a + vlab = vla `mappend` measure b + vlabc = vlab `mappend` measure c + vdr = measure d `mappend` vr + vcdr = measure c `mappend` vdr + vbcdr = measure b `mappend` vcdr + +-- | Like 'traverse', but safe only if the function preserves the measure. +unsafeTraverse :: (Applicative f) => + (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 + +unsafeTraverseNode :: (Applicative f) => + (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 + +----------------------------------------------------- +-- 4.3 Construction, deconstruction and concatenation +----------------------------------------------------- + +-- | /O(1)/. The empty sequence. +empty :: Measured v a => FingerTree v a +empty = Empty + +-- | /O(1)/. A singleton sequence. +singleton :: Measured v a => a -> FingerTree v a +singleton = Single + +-- | /O(n)/. Create a sequence from a finite list of elements. +-- The opposite operation 'toList' is supplied by the 'Foldable' instance. +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 <| 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 + +consDigit :: a -> Digit a -> Digit a +consDigit a (One b) = Two a b +consDigit a (Two b c) = Three a b c +consDigit a (Three b c d) = Four a b c d +consDigit _ (Four _ _ _ _) = illegal_argument "consDigit" + +-- | /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) +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) + +snocDigit :: Digit a -> a -> Digit a +snocDigit (One a) b = Two a b +snocDigit (Two a b) c = Three a b c +snocDigit (Three a b c) d = Four a b c d +snocDigit (Four _ _ _ _) _ = illegal_argument "snocDigit" + +-- | /O(1)/. Is this the empty sequence? +null :: FingerTree v a -> Bool +null Empty = True +null _ = False + +-- | /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 + +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 + +lheadDigit :: Digit a -> a +lheadDigit (One a) = a +lheadDigit (Two a _) = a +lheadDigit (Three a _ _) = a +lheadDigit (Four a _ _ _) = a + +ltailDigit :: Digit a -> Digit a +ltailDigit (One _) = illegal_argument "ltailDigit" +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 + +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 `mappend` measure m) pr m' (nodeToDigit a) + +rheadDigit :: Digit a -> a +rheadDigit (One a) = a +rheadDigit (Two _ b) = b +rheadDigit (Three _ _ c) = c +rheadDigit (Four _ _ _ d) = d + +rtailDigit :: Digit a -> Digit a +rtailDigit (One _) = illegal_argument "rtailDigit" +rtailDigit (Two a _) = One a +rtailDigit (Three a b _) = Two a b +rtailDigit (Four a b c _) = Three a b c + +digitToTree :: (Measured v a) => Digit a -> FingerTree v a +digitToTree (One a) = Single a +digitToTree (Two a b) = deep (One a) Empty (One b) +digitToTree (Three a b c) = deep (Two a b) Empty (One c) +digitToTree (Four a b c d) = deep (Two a b) Empty (Two c d) + +---------------- +-- Concatenation +---------------- + +-- | /O(log(min(n1,n2)))/. Concatenate two sequences. +(><) :: (Measured v a) => FingerTree v a -> FingerTree v a -> FingerTree v a +(><) = appendTree0 + +-- appendTree<0..4> and addDigits<0..4> were generated by misc/mkappend.hs + +appendTree0 :: (Measured v a) => FingerTree v a -> FingerTree v a -> FingerTree v a +appendTree0 Empty xs = + xs +appendTree0 xs Empty = + xs +appendTree0 (Single x) xs = + x <| xs +appendTree0 xs (Single x) = + xs |> x +appendTree0 (Deep _ pr1 m1 sf1) (Deep _ 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 +addDigits0 m1 (One a) (Two 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 +addDigits0 m1 (One a) (Four b c 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 +addDigits0 m1 (Two a b) (Two 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 +addDigits0 m1 (Two a b) (Four c 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 +addDigits0 m1 (Three a b c) (Two 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 +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 +addDigits0 m1 (Four a b c d) (One 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 +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 +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 + +appendTree1 :: (Measured v a) => FingerTree v a -> a -> FingerTree v a -> FingerTree v a +appendTree1 Empty a xs = + a <| xs +appendTree1 xs a Empty = + xs |> a +appendTree1 (Single x) a xs = + x <| a <| xs +appendTree1 xs a (Single x) = + xs |> a |> x +appendTree1 (Deep _ pr1 m1 sf1) a (Deep _ 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 +addDigits1 m1 (One a) b (Two 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 +addDigits1 m1 (One a) b (Four c 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 +addDigits1 m1 (Two a b) c (Two 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 +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 +addDigits1 m1 (Three a b c) d (One 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 +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 +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 +addDigits1 m1 (Four a b c d) e (One 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 +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 +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 + +appendTree2 :: (Measured v a) => FingerTree v a -> a -> a -> FingerTree v a -> FingerTree v a +appendTree2 Empty a b xs = + a <| b <| xs +appendTree2 xs a b Empty = + xs |> a |> b +appendTree2 (Single x) a b xs = + x <| a <| b <| xs +appendTree2 xs a b (Single 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 + +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 +addDigits2 m1 (One a) b c (Two 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 +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 +addDigits2 m1 (Two a b) c d (One 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 +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 +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 +addDigits2 m1 (Three a b c) d e (One 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 +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 +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 +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 +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 +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 +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 + +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 +appendTree3 xs a b c Empty = + xs |> a |> b |> c +appendTree3 (Single x) a b c xs = + x <| a <| b <| c <| xs +appendTree3 xs a b c (Single 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 + +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 +addDigits3 m1 (One a) b c d (Two 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 +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 +addDigits3 m1 (Two a b) c d e (One 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 +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 +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 +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 +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 +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 +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 +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 +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 +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 +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 :: (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 +appendTree4 xs a b c d Empty = + xs |> a |> b |> c |> d +appendTree4 (Single 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 +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 + +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 +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 +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 +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 +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 +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 +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 +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 +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 +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 +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 +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 +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 +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 +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 +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 + +---------------- +-- 4.4 Splitting +---------------- + +-- | A result of 'search', attempting to find a point where a predicate +-- on splits of the sequence changes from 'False' to 'True'. +-- +-- @since 0.1.2.0 +data SearchResult v a + = Position !(FingerTree v a) a !(FingerTree v a) + -- ^ A tree opened at a particular element: the prefix to the + -- left, the element, and the suffix to the right. + | OnLeft + -- ^ A position to the left of the sequence, indicating that the + -- predicate is 'True' at both ends. + | OnRight + -- ^ A position to the right of the sequence, indicating that the + -- predicate is 'False' at both ends. + | Nowhere + -- ^ No position in the tree, returned if the predicate is 'True' + -- at the left end and 'False' at the right end. This will not + -- occur if the predicate in monotonic on the tree. + deriving (Eq, Ord, Show +#if __GLASGOW_HASKELL__ >= 706 + , Generic +#if __GLASGOW_HASKELL__ >= 710 + , NFData +#endif +#endif + ) + +-- | /O(log(min(i,n-i)))/. Search a sequence for a point where a predicate +-- on splits of the sequence changes from 'False' to 'True'. +-- +-- The argument @p@ is a relation between the measures of the two +-- sequences that could be appended together to form the sequence @t@. +-- If the relation is 'False' at the leftmost split and 'True' at the +-- rightmost split, i.e. +-- +-- @not (p 'mempty' ('measure' t)) && p ('measure' t) 'mempty'@ +-- +-- then there must exist an element @x@ in the sequence such that @p@ +-- is 'False' for the split immediately before @x@ and 'True' for the +-- split just after it: +-- +-- <> +-- +-- In this situation, @'search' p t@ returns such an element @x@ and the +-- pieces @l@ and @r@ of the sequence to its left and right respectively. +-- That is, it returns @'Position' l x r@ such that +-- +-- * @l >< (x <| r) = t@ +-- +-- * @not (p (measure l) (measure (x <| r))@ +-- +-- * @p (measure (l |> x)) (measure r)@ +-- +-- For predictable results, one should ensure that there is only one such +-- point, i.e. that the predicate is /monotonic/ on @t@. +-- +-- @since 0.1.2.0 +search :: (Measured v a) => + (v -> v -> Bool) -> FingerTree v a -> SearchResult v a +search p t + | p_left && p_right = OnLeft + | not p_left && p_right = case searchTree p mempty t mempty of + Split l x r -> Position l x r + | not p_left && not p_right = OnRight + | otherwise = Nowhere + where + p_left = p mempty vt + p_right = p vt mempty + vt = measure t + +-- isSplit :: (Measured v a) => (v -> v -> Bool) -> v -> a -> v -> Bool +-- isSplit p vl x vr = not (p vl (v `mappend` vr)) && p (vl `mappend` v) vr +-- where v = measure x +-- +-- property: +-- isSplit p vl t vr => +-- let Split l x r = search t in +-- isSplit p (vl `mappend` measure l) x (measure r `mappend` vr) + +searchTree :: (Measured v a) => + (v -> v -> Bool) -> v -> FingerTree v a -> v -> Split (FingerTree v a) a +searchTree _ _ Empty _ = illegal_argument "searchTree" +searchTree _ _ (Single x) _ = Split Empty x Empty +searchTree p vl (Deep _ pr m sf) vr + | p vlp vmsr = case searchDigit p vl pr vmsr of + Split l x r -> Split (maybe Empty digitToTree l) x (deepL r m sf) + | p vlpm vsr = case searchTree p vlp m vsr of + Split ml xs mr -> case searchNode p (vlp `mappend` measure ml) xs (measure mr `mappend` vsr) of + Split l x r -> Split (deepR pr ml l) x (deepL r mr sf) + | otherwise = case searchDigit p vlpm sf vr of + Split l x r -> Split (deepR pr m l) x (maybe Empty digitToTree r) + where + vlp = vl `mappend` measure pr + vlpm = vlp `mappend` vm + vmsr = vm `mappend` vsr + vsr = measure sf `mappend` vr + vm = measure m + +searchNode :: (Measured v a) => + (v -> v -> Bool) -> v -> Node v a -> v -> Split (Maybe (Digit a)) a +searchNode p vl (Node2 _ a b) vr + | p va vb = Split Nothing a (Just (One b)) + | otherwise = Split (Just (One a)) b Nothing + where + va = vl `mappend` measure a + vb = measure b `mappend` vr +searchNode p vl (Node3 _ a b c) vr + | p va vbc = Split Nothing a (Just (Two b c)) + | p vab vc = Split (Just (One a)) b (Just (One c)) + | otherwise = Split (Just (Two a b)) c Nothing + where + va = vl `mappend` measure a + vab = va `mappend` measure b + vc = measure c `mappend` vr + vbc = measure b `mappend` vc + +searchDigit :: (Measured v a) => + (v -> v -> Bool) -> v -> Digit a -> v -> Split (Maybe (Digit a)) a +searchDigit _ vl (One a) vr = vl `seq` vr `seq` Split Nothing a Nothing +searchDigit p vl (Two a b) vr + | p va vb = Split Nothing a (Just (One b)) + | otherwise = Split (Just (One a)) b Nothing + where + va = vl `mappend` measure a + vb = measure b `mappend` vr +searchDigit p vl (Three a b c) vr + | p va vbc = Split Nothing a (Just (Two b c)) + | p vab vc = Split (Just (One a)) b (Just (One c)) + | otherwise = Split (Just (Two a b)) c Nothing + where + va = vl `mappend` measure a + vab = va `mappend` measure b + vbc = measure b `mappend` vc + vc = measure c `mappend` vr +searchDigit p vl (Four a b c d) vr + | p va vbcd = Split Nothing a (Just (Three b c d)) + | p vab vcd = Split (Just (One a)) b (Just (Two c d)) + | p vabc vd = Split (Just (Two a b)) c (Just (One d)) + | otherwise = Split (Just (Three a b c)) d Nothing + where + va = vl `mappend` measure a + vab = va `mappend` measure b + vabc = vab `mappend` measure c + vbcd = measure b `mappend` vcd + vcd = measure c `mappend` vd + vd = measure d `mappend` vr + +-- | /O(log(min(i,n-i)))/. Split a sequence at a point where the predicate +-- on the accumulated measure of the prefix changes from 'False' to 'True'. +-- +-- 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 _ Empty = (Empty, Empty) +split p xs + | p (measure xs) = (l, x <| r) + | 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 +-- prefix of @t@ whose measure does not satisfy @p@. +-- +-- * @'takeUntil' p t = 'fst' ('split' p t)@ +takeUntil :: (Measured v a) => (v -> Bool) -> FingerTree v a -> FingerTree v a +takeUntil p = fst . split p + +-- | /O(log(min(i,n-i)))/. +-- Given a monotonic predicate @p@, @'dropUntil' p t@ is the rest of @t@ +-- after removing the largest prefix whose measure does not satisfy @p@. +-- +-- * @'dropUntil' p t = 'snd' ('split' p t)@ +dropUntil :: (Measured v a) => (v -> Bool) -> FingerTree v a -> FingerTree v a +dropUntil p = snd . split p + +data Split t a = Split !t a !t + +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 = case splitDigit p i pr of + Split l x r -> Split (maybe Empty digitToTree l) x (deepL r m sf) + | p vm = case splitTree p vpr m of + Split ml xs mr -> case splitNode p (vpr `mappend` measure ml) xs of + Split l x r -> Split (deepR pr ml l) x (deepL r mr sf) + | otherwise = case splitDigit p vm sf of + Split l x r -> Split (deepR pr m l) x (maybe Empty digitToTree r) + where + vpr = i `mappend` measure pr + vm = vpr `mappend` measure m + +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 + +splitNode :: (Measured v a) => + (v -> Bool) -> v -> Node v 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 +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 + +splitDigit :: (Measured v a) => + (v -> Bool) -> v -> Digit 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 +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 +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 + +------------------ +-- Transformations +------------------ + +-- | /O(n)/. The reverse of a sequence. +reverse :: (Measured v a) => FingerTree v a -> FingerTree v a +reverse = reverseTree id + +reverseTree :: (Measured v2 a2) => (a1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2 +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) + +reverseNode :: (Measured v2 a2) => (a1 -> a2) -> Node v1 a1 -> Node v2 a2 +reverseNode f (Node2 _ a b) = node2 (f b) (f a) +reverseNode f (Node3 _ a b c) = node3 (f c) (f b) (f a) + +reverseDigit :: (a -> b) -> Digit a -> Digit b +reverseDigit f (One a) = One (f a) +reverseDigit f (Two a b) = Two (f b) (f a) +reverseDigit f (Three a b c) = Three (f c) (f b) (f a) +reverseDigit f (Four a b c d) = Four (f d) (f c) (f b) (f a) + +illegal_argument :: String -> a +illegal_argument name = + error $ "Logic error: " ++ name ++ " called with illegal argument" + +{- $example + +Particular abstract data types may be implemented by defining +element types with suitable 'Measured' instances. + +(from section 4.5 of the paper) +Simple sequences can be implemented using a 'Data.Monoid.Sum' monoid +as a measure: > newtype Elem a = Elem { getElem :: a } > diff --git a/Data/IntervalMap/FingerTree.hs b/Data/IntervalMap/FingerTree.hs --- a/Data/IntervalMap/FingerTree.hs +++ b/Data/IntervalMap/FingerTree.hs @@ -1,20 +1,33 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE DeriveGeneric #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 802 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE DeriveAnyClass #-} +#endif ----------------------------------------------------------------------------- -- | -- Module : Data.PriorityQueue.FingerTree -- Copyright : (c) Ross Paterson 2008 -- License : BSD-style --- Maintainer : ross@soi.city.ac.uk +-- Maintainer : R.Paterson@city.ac.uk -- Stability : experimental -- Portability : non-portable (MPTCs and functional dependencies) -- -- 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,76 +40,171 @@ ----------------------------------------------------------------------------- module Data.IntervalMap.FingerTree ( - -- * Intervals - Interval(..), point, - -- * Interval maps - IntervalMap, empty, singleton, insert, union, - -- * Searching - search, intersections, dominators - ) where + -- * Intervals + Interval(..), low, high, point, + -- * Interval maps + IntervalMap, empty, singleton, insert, union, + -- * Searching + search, intersections, dominators, + -- * Extraction + bounds, leastView, splitAfter + ) where import qualified Data.FingerTree as FT import Data.FingerTree (FingerTree, Measured(..), ViewL(..), (<|), (><)) +import Prelude hiding (null) +#if MIN_VERSION_base(4,6,0) +import GHC.Generics +#endif +#if MIN_VERSION_base(4,8,0) +import qualified Prelude (null) +#else import Control.Applicative ((<$>)) -import Data.Traversable (Traversable(traverse)) -import Data.Foldable (Foldable(foldMap)) import Data.Monoid +#endif +#if !(MIN_VERSION_base(4,8,0)) || defined(__MHS__) +import Data.Foldable (Foldable(foldMap)) +import Data.Traversable (Traversable(traverse)) +#endif +#if (MIN_VERSION_base(4,9,0)) && !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup +#endif +import Control.DeepSeq +import Data.Foldable (toList) ---------------------------------- -- 4.8 Application: interval trees ---------------------------------- -- | 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) +-- to the upper bound. +data Interval v = Interval v v -- ^ Lower and upper bounds of the interval. + deriving (Eq, Ord, Show, Read +#if __GLASGOW_HASKELL__ >= 706 + , Generic +#if __GLASGOW_HASKELL__ >= 710 + , NFData +#endif +#endif + ) +-- | Lower bound of the interval +low :: Interval v -> v +low (Interval lo _) = lo + +-- | Upper bound of the interval +high :: Interval v -> v +high (Interval _ hi) = hi + -- | An interval in which the lower and upper bounds are equal. point :: v -> Interval v point v = Interval v v data Node v a = Node (Interval v) a + deriving (Eq, Ord, Show, Read +#if __GLASGOW_HASKELL__ >= 706 + , Generic +#if __GLASGOW_HASKELL__ >= 710 + , NFData +#endif +#endif + ) 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 +#if __GLASGOW_HASKELL__ >= 710 + deriving (Generic, NFData) +#elif __GLASGOW_HASKELL__ >= 706 + deriving (Generic) +#endif +#if MIN_VERSION_base(4,9,0) +instance Ord v => Semigroup (IntInterval v) where + (<>) = intervalUnion +#endif + 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 +#if !(MIN_VERSION_base(4,11,0)) + mappend = intervalUnion +#endif +intervalUnion :: Ord v => IntInterval v -> IntInterval v -> IntInterval v +NoInterval `intervalUnion` i = i +i `intervalUnion` NoInterval = i +IntInterval _ hi1 `intervalUnion` 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)) +#if __GLASGOW_HASKELL__ >= 710 + deriving (Generic, NFData) +#elif __GLASGOW_HASKELL__ >= 706 + deriving (Generic) +#endif -- 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) +-- | Values in lexicographical order of intervals. instance Foldable (IntervalMap v) where - foldMap f (IntervalMap t) = foldMap (foldMap f) t + foldMap f (IntervalMap t) = foldMap (foldMap f) t +#if MIN_VERSION_base(4,8,0) + null (IntervalMap t) = FT.null t +#endif +-- | Traverse the intervals in lexicographical order. 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 +instance (Eq v, Eq a) => Eq (IntervalMap v a) where + IntervalMap xs == IntervalMap ys = toList xs == toList ys + +-- | Lexicographical ordering +instance (Ord v, Ord a) => Ord (IntervalMap v a) where + compare (IntervalMap xs) (IntervalMap ys) = compare (toList xs) (toList ys) + +instance (Show v, Show a) => Show (IntervalMap v a) where + showsPrec p (IntervalMap ns) + | FT.null ns = showString "empty" + | otherwise = + showParen (p > 0) (showIntervals (toList ns)) + where + showIntervals [] = showString "empty" + showIntervals (Node i x:ixs) = + showString "insert " . showsPrec 11 i . + showChar ' ' . showsPrec 11 x . + showString " $ " . showIntervals ixs + +#if MIN_VERSION_base(4,9,0) +-- | 'union'. +instance (Ord v) => Semigroup (IntervalMap v a) where + (<>) = union +#endif + +-- | 'empty' and 'union'. +instance (Ord v) => Monoid (IntervalMap v a) where + mempty = empty +#if !(MIN_VERSION_base(4,11,0)) + mappend = union +#endif + -- | /O(1)/. The empty interval map. empty :: (Ord v) => IntervalMap v a empty = IntervalMap FT.empty @@ -105,30 +213,37 @@ singleton :: (Ord v) => Interval v -> a -> IntervalMap v a singleton i x = IntervalMap (FT.singleton (Node i x)) --- | /O(log n)/. Insert an interval into a map. +-- | /O(log n)/. Insert an interval and associated value into a map. -- 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. @@ -149,39 +264,81 @@ -- 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' +-- | /O(1)/. @'bounds' m@ returns @'Nothing'@ if @m@ is empty, and +-- otherwise @'Just' i@, where @i@ is the smallest interval containing +-- all the intervals in the map. +-- +-- @since 0.1.3.0 +bounds :: (Ord v) => IntervalMap v a -> Maybe (Interval v) +bounds (IntervalMap t) = case measure t of + NoInterval -> Nothing + IntInterval _ hi -> case FT.viewl t of + EmptyL -> Nothing + Node (Interval lo _) _ FT.:< _ -> Just (Interval lo hi) + +-- | /O(1)/. @'leastView' m@ returns @'Nothing'@ if @m@ is empty, and +-- otherwise @'Just' ((i, x), m')@, where @i@ is the least interval, +-- @x@ is the associated value, and @m'@ is the rest of the map. +-- +-- @since 0.1.3.0 +leastView :: Ord v => + IntervalMap v a -> Maybe ((Interval v, a), IntervalMap v a) +leastView (IntervalMap t) = case FT.viewl t of + EmptyL -> Nothing + Node i a FT.:< t' -> Just ((i, a), IntervalMap t') + +-- | /O(log(min(i,n-i)))/. @'splitAfter' k m@ returns a pair of submaps, +-- one consisting of intervals whose lower bound is less than or equal +-- to @k@, and the other of those whose lower bound is greater. +-- +-- @since 0.1.3.0 +splitAfter :: Ord v => + v -> IntervalMap v a -> (IntervalMap v a, IntervalMap v a) +splitAfter k (IntervalMap t) = (IntervalMap before, IntervalMap after) + where + (before, after) = FT.split (greater k) t + 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 @@ -1,20 +1,33 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE DeriveGeneric #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 802 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE DeriveAnyClass #-} +#endif ----------------------------------------------------------------------------- -- | -- Module : Data.PriorityQueue.FingerTree -- Copyright : (c) Ross Paterson 2008 -- License : BSD-style --- Maintainer : ross@soi.city.ac.uk +-- Maintainer : R.Paterson@city.ac.uk -- Stability : experimental -- Portability : non-portable (MPTCs and functional dependencies) -- -- 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,66 +46,127 @@ ----------------------------------------------------------------------------- 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 Prelude hiding (null) +#if MIN_VERSION_base(4,6,0) +import GHC.Generics +#endif +#if MIN_VERSION_base(4,8,0) +import qualified Prelude (null) +#else import Data.Monoid +#endif +#if !(MIN_VERSION_base(4,8,0)) || defined(__MHS__) +import Data.Foldable (Foldable(foldMap)) +#endif +#if (MIN_VERSION_base(4,9,0)) && !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup +#endif +import Control.Arrow ((***)) +import Control.DeepSeq import Data.List (unfoldr) -import Prelude hiding (null) -data Entry k v = Entry { key :: k, value :: v } +data Entry k v = Entry k v +#if __GLASGOW_HASKELL__ >= 710 + deriving (Generic, NFData) +#elif __GLASGOW_HASKELL__ >= 706 + deriving (Generic) +#endif 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 +#if __GLASGOW_HASKELL__ >= 710 + deriving (Generic, NFData) +#elif __GLASGOW_HASKELL__ >= 706 + deriving (Generic) +#endif +#if MIN_VERSION_base(4,9,0) +instance Ord k => Semigroup (Prio k v) where + (<>) = unionPrio +#endif + 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 +#if !(MIN_VERSION_base(4,11,0)) + mappend = unionPrio +#endif +unionPrio :: Ord k => Prio k v -> Prio k v -> Prio k v +x `unionPrio` NoPrio = x +NoPrio `unionPrio` y = y +x@(Prio kx _) `unionPrio` 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)) +#if __GLASGOW_HASKELL__ >= 710 + deriving (Generic, NFData) +#elif __GLASGOW_HASKELL__ >= 706 + deriving (Generic) +#endif 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) +-- | In ascending order of keys. 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' +#if MIN_VERSION_base(4,8,0) + null (PQueue q) = FT.null q +#endif +#if MIN_VERSION_base(4,9,0) +instance Ord k => Semigroup (PQueue k v) where + (<>) = union +#endif + +-- | 'empty' and 'union' instance Ord k => Monoid (PQueue k v) where - mempty = empty - mappend = union + mempty = empty +#if !(MIN_VERSION_base(4,11,0)) + mappend = union +#endif +instance (Ord k, Eq v) => Eq (PQueue k v) where + xs == ys = assocs xs == assocs ys + +-- | Lexicographical ordering +instance (Ord k, Ord v) => Ord (PQueue k v) where + compare xs ys = compare (assocs xs) (assocs ys) + +-- | In ascending key order +instance (Ord k, Show k, Show v) => Show (PQueue k v) where + showsPrec p xs = showParen (p > 10) $ + showString "fromList " . shows (assocs xs) + -- | /O(1)/. The empty priority queue. empty :: Ord k => PQueue k v empty = PQueue FT.empty @@ -101,7 +175,7 @@ singleton :: Ord k => k -> v -> PQueue k v singleton k v = PQueue (FT.singleton (Entry k v)) --- | /O(log n)/. Add a (priority, value) pair to the front of a priority queue. +-- | /O(1)/. Add a (priority, value) pair to the front of a priority queue. -- -- * @'insert' k v q = 'union' ('singleton' k v) q@ -- @@ -136,7 +210,7 @@ null :: Ord k => PQueue k v -> Bool null (PQueue q) = FT.null q --- | /O(1)/ (/O(log(n))/ for the reduced queue). +-- | /O(1)/ for the element, /O(log(n))/ for the reduced queue. -- Returns 'Nothing' for an empty map, or the value associated with the -- minimal priority together with the rest of the priority queue. -- @@ -147,7 +221,7 @@ minView :: Ord k => PQueue k v -> Maybe (v, PQueue k v) minView q = fmap (snd *** id) (minViewWithKey q) --- | /O(1)/ (/O(log(n))/ for the reduced queue). +-- | /O(1)/ for the element, /O(log(n))/ for the reduced queue. -- Returns 'Nothing' for an empty map, or the minimal (priority, value) -- pair together with the rest of the priority queue. -- @@ -165,11 +239,16 @@ 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 below k (Prio k' _) = k' <= k + +-- | /O(n)/. Key-value pairs in ascending key order. +assocs :: Ord k => PQueue k v -> [(k, v)] +assocs = unfoldr minViewWithKey diff --git a/changelog b/changelog new file mode 100644 --- /dev/null +++ b/changelog @@ -0,0 +1,66 @@ +-*-change-log-*- + +0.1.6.3 Ross Paterson Dec 2025 + * Patches for MicroHS + +0.1.6.2 Ross Paterson Jul 2025 + * Change http links in docs to https + +0.1.6.1 Ross Paterson May 2025 + * Added NFData instances + +0.1.5.0 Ross Paterson Jan 2022 + * Added foldlWithPos, foldrWithPos, foldlWithContext, foldrWithContext (James Cranch) + * Fixed bug in traverseWithContext + * Made split and search stricter + +0.1.4.2 Ross Paterson Dec 2018 + * Fixed bug in search + +0.1.4.1 Ross Paterson Mar 2018 + * Disabled Generic instances for GHC <= 7.6 + +0.1.4.0 Ross Paterson Mar 2018 + * Added Generic instances + +0.1.3.1 Ross Paterson Dec 2017 + * Fixed Data.IntervalMap.FingerTree.bounds + +0.1.3.0 Ross Paterson Nov 2017 + * Fixed Show instance for IntervalMap + * Added bounds, leastView and splitAfter to IntervalMap + +0.1.2.1 Ross Paterson Oct 2017 + * Fix for GHC <= 7.8 + +0.1.2.0 Ross Paterson Oct 2017 + * Removed constraint on the type of null + * Added versions of fmap and traverse passing the measures of both sides + * Added new search function, a symmetrical generalization of split + * Added Eq, Ord and Show instances for IntervalMap and PriorityQueue + * Made low and high into separate functions + * Updated for Monoid, Foldable, Traversable in Prelude + * Made compatible with Semigroup/Monoid proposal + +0.1.1.0 Ross Paterson Jun 2015 + * Added Safe for GHC >= 7.2 + * Added AutoDeriveTypeable for GHC >= 7.10 + +0.1.0.2 Ross Paterson Mar 2015 + * Cabal file updates + +0.1.0.1 Ross Paterson Feb 2015 + * fix warnings + +0.1.0.0 Ross Paterson Jun 2013 + * Added Monoid instance for IntervalMap + * Removed unnecessary Measured v a constraints on Eq, Ord, and Show instances + +0.0.1.1 Ross Paterson Sep 2012 + * Cabal file updates + +0.0.1.0 Ross Paterson Jul 2009 + * Added Data.IntervalMap.FingerTree and Data.PriorityQueue.FingerTree + +0.0 Ross Paterson May 2007 + * Initial revision diff --git a/fingertree.cabal b/fingertree.cabal --- a/fingertree.cabal +++ b/fingertree.cabal @@ -1,10 +1,11 @@ Name: fingertree -Version: 0.0.1.1 -Cabal-Version: >= 1.6 +Version: 0.1.6.3 +Cabal-Version: 1.18 Copyright: (c) 2006 Ross Paterson, Ralf Hinze License: BSD3 License-File: LICENSE -Maintainer: Ross Paterson +Maintainer: Ross Paterson +bug-reports: https://hub.darcs.net/ross/fingertree/issues Category: Data Structures Synopsis: Generic finger-tree structure, with example instances Description: @@ -16,20 +17,27 @@ * 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 tuned sequence type, see @Data.Sequence@ in the @containers@ package, which is a specialization of this structure. Build-Type: Simple +Extra-Doc-Files: + changelog + images/search.svg Source-Repository head Type: darcs - Location: http://code.haskell.org/~ross/fingertree + Location: https://hub.darcs.net/ross/fingertree Library - Build-Depends: base < 6 - Extensions: MultiParamTypeClasses + Build-Depends: + base < 6, + deepseq >= 1.3 && < 1.6 + Default-Language: Haskell2010 + Other-Extensions: + MultiParamTypeClasses FunctionalDependencies FlexibleInstances UndecidableInstances @@ -37,3 +45,17 @@ Data.FingerTree Data.IntervalMap.FingerTree Data.PriorityQueue.FingerTree + +Test-suite ft-properties + type: exitcode-stdio-1.0 + main-is: tests/ft-properties.hs + cpp-options: -DTESTING + default-language: Haskell2010 + build-depends: + base >= 4.2 && < 6, + deepseq >= 1.3 && < 1.6, + HUnit, + QuickCheck, + test-framework, + test-framework-hunit, + test-framework-quickcheck2 diff --git a/images/search.svg b/images/search.svg new file mode 100644 --- /dev/null +++ b/images/search.svg @@ -0,0 +1,53 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + l + x + r + measure l + measure (x <| r) + measure (l |> x) + measure r + + + + + + p + False + True + + + diff --git a/tests/ft-properties.hs b/tests/ft-properties.hs new file mode 100644 --- /dev/null +++ b/tests/ft-properties.hs @@ -0,0 +1,493 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- QuickCheck properties for Data.FingerTree + +module Main where + +import Data.FingerTree -- needs to be compiled with -DTESTING for use here + +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 +import Test.HUnit (Assertion, (@?=)) +import Test.QuickCheck hiding ((><)) +import Test.QuickCheck.Poly + +import Prelude hiding (null, reverse, foldl, foldl1, foldr, foldr1, all) +import qualified Prelude + +import Control.Applicative (Applicative(..)) +import Control.Monad (ap) +import Data.Foldable (Foldable(foldMap, foldl, foldr), toList, all) +import Data.Functor ((<$>)) +import Data.Traversable (traverse) +import Data.List (inits) +import Data.Maybe (listToMaybe) +import Data.Monoid (Monoid(..)) + +main :: IO () +main = defaultMainWithOpts + [ testProperty "foldr" prop_foldr + , testProperty "foldl" prop_foldl + , testProperty "(==)" prop_equals + , testProperty "compare" prop_compare + , testProperty "mappend" prop_mappend + , testCase "empty" test_empty + , testProperty "singleton" prop_singleton + , testProperty "(<|)" prop_cons + , testProperty "(|>)" prop_snoc + , testProperty "(><)" prop_append + , testProperty "fromList" prop_fromList + , testProperty "null" prop_null + , testProperty "viewl" prop_viewl + , testProperty "viewr" prop_viewr + , testCase "search" test_search + , testProperty "search" prop_search + , testProperty "split" prop_split + , testProperty "takeUntil" prop_takeUntil + , testProperty "dropUntil" prop_dropUntil + , testProperty "reverse" prop_reverse + , testProperty "fmap'" prop_fmap' + , testProperty "fmapWithPos" prop_fmapWithPos + , testProperty "fmapWithContext" prop_fmapWithContext + , testProperty "foldlWithPos" prop_foldlWithPos + , testProperty "foldlWithContext" prop_foldlWithContext + , testProperty "foldrWithPos" prop_foldrWithPos + , testProperty "foldrWithContext" prop_foldrWithContext + , testProperty "traverse'" prop_traverse' + , testProperty "traverseWithPos" prop_traverseWithPos + , testProperty "traverseWithContext" prop_traverseWithContext + ] runner_opts + where + runner_opts = mempty { ropt_test_options = Just test_opts } + test_opts = mempty { + topt_maximum_generated_tests = Just 500 + , topt_maximum_unsuitable_generated_tests = Just 500 + } + +{-------------------------------------------------------------------- + The general plan is to compare each function with a list equivalent. + Each operation should produce a valid tree representing the same + sequence as produced by its list counterpart on corresponding inputs. + (The list versions are often lazier, but these properties ignore + strictness.) +--------------------------------------------------------------------} + +-- utilities for partial conversions + +infix 4 ~= + +(~=) :: (Eq a, Eq v, Measured v a, Valid a) => FingerTree v a -> [a] -> Bool +s ~= xs = valid s && toList s == xs + +-- Partial conversion of an output sequence to a list. +toList' :: (Eq a, Measured [a] a, Valid a) => Seq a -> Maybe [a] +toList' xs + | valid xs = Just (toList xs) + | otherwise = Nothing + +-- instances + +prop_foldr :: Seq A -> Bool +prop_foldr xs = + foldr f z xs == Prelude.foldr f z (toList xs) + where + f = (:) + z = [] + +prop_foldl :: Seq A -> Bool +prop_foldl xs = + foldl f z xs == Prelude.foldl f z (toList xs) + where + f = flip (:) + z = [] + +prop_equals :: Seq OrdA -> Seq OrdA -> Bool +prop_equals xs ys = + (xs == ys) == (toList xs == toList ys) + +prop_compare :: Seq OrdA -> Seq OrdA -> Bool +prop_compare xs ys = + compare xs ys == compare (toList xs) (toList ys) + +prop_mappend :: Seq A -> Seq A -> Bool +prop_mappend xs ys = + mappend xs ys ~= toList xs ++ toList ys + +-- * Construction + +test_empty :: Assertion +test_empty = + toList' (empty :: Seq A) @?= Just [] + +prop_singleton :: A -> Bool +prop_singleton x = + singleton x ~= [x] + +prop_cons :: A -> Seq A -> Bool +prop_cons x xs = + x <| xs ~= x : toList xs + +prop_snoc :: Seq A -> A -> Bool +prop_snoc xs x = + xs |> x ~= toList xs ++ [x] + +prop_append :: Seq A -> Seq A -> Bool +prop_append xs ys = + xs >< ys ~= toList xs ++ toList ys + +prop_fromList :: [A] -> Bool +prop_fromList xs = + fromList xs ~= xs + +-- * Deconstruction + +prop_null :: Seq A -> Bool +prop_null xs = + null xs == Prelude.null (toList xs) + +-- ** Examining the ends + +prop_viewl :: Seq A -> Bool +prop_viewl xs = + case viewl xs of + EmptyL -> Prelude.null (toList xs) + x :< xs' -> valid xs' && toList xs == x : toList xs' + +prop_viewr :: Seq A -> Bool +prop_viewr xs = + case viewr xs of + EmptyR -> Prelude.null (toList xs) + xs' :> x -> valid xs' && toList xs == toList xs' ++ [x] + +-- ** Search + +prop_search :: Int -> Seq A -> Bool +prop_search n xs = + case search p xs of + Position _ b _ -> Just b == indexFromEnd n (toList xs) + OnLeft -> n >= len || null xs + OnRight -> n < 0 + Nowhere -> error "impossible: the predicate is monotonic" + where + p vl vr = Prelude.length vl >= len - n && Prelude.length vr <= n + + len = length xs + + indexFromEnd :: Int -> [a] -> Maybe a + indexFromEnd i = listToMaybe . drop i . Prelude.reverse + +test_search :: Assertion +test_search = do + lookupByIndexFromEnd xs1 1 @?= Just (A 4) + lookupByIndexFromEnd xs2 1 @?= Just (A 4) + where + xs1 = Deep (map A [1..5]) (Four (A 1) (A 2) (A 3) (A 4)) Empty (One (A 5)) + xs2 = Deep (map A [1..5]) (One (A 1)) Empty (Four (A 2) (A 3) (A 4) (A 5)) + lookupByIndexFromEnd xs n = + let len = length xs + p vl vr = Prelude.length vl >= len - n && Prelude.length vr <= n + in case search p xs of + Position _ x _ -> Just x + _ -> Nothing + +-- ** Splitting + +prop_split :: Int -> Seq A -> Bool +prop_split n xs = + s_front ~= l_front && s_back ~= l_back + where + p ys = Prelude.length ys > n + (s_front, s_back) = split p xs + (l_front, l_back) = Prelude.splitAt n (toList xs) + +prop_takeUntil :: Int -> Seq A -> Bool +prop_takeUntil n xs = + takeUntil p xs ~= Prelude.take n (toList xs) + where + p ys = Prelude.length ys > n + +prop_dropUntil :: Int -> Seq A -> Bool +prop_dropUntil n xs = + dropUntil p xs ~= Prelude.drop n (toList xs) + where + p ys = Prelude.length ys > n + +-- * Transformation + +prop_reverse :: Seq A -> Bool +prop_reverse xs = + reverse xs ~= Prelude.reverse (toList xs) + +-- ** Maps + +prop_fmap' :: Seq A -> Bool +prop_fmap' xs = + fmap' f xs ~= map f (toList xs) + where + f = Just + +prop_fmapWithPos :: FingerTree MA VA -> Bool +prop_fmapWithPos xs = + fmapWithPos f xs ~= zipWith f (prefixes xs_list) xs_list + where + f = WithPos + xs_list = toList xs + +prop_fmapWithContext :: FingerTree MA VA -> Bool +prop_fmapWithContext xs = + fmapWithContext f xs ~= zipWith3 f (prefixes xs_list) xs_list (suffixes xs_list) + where + f = WithContext + xs_list = toList xs + +-- ** Folds + +prop_foldlWithPos :: FingerTree MA VA -> Bool +prop_foldlWithPos xs = + foldlWithPos f z xs == foldl uncurry_f z (zip (prefixes xs_list) xs_list) + where + z = [] + f vxs v x = WithPos v x:vxs + uncurry_f vxs (v, x) = f vxs v x + xs_list = toList xs + +prop_foldlWithContext :: FingerTree MA VA -> Bool +prop_foldlWithContext xs = + foldlWithContext f z xs == foldl uncurry_f z (zip3 (prefixes xs_list) xs_list (suffixes xs_list)) + where + z = [] + f vxs vl x vr = WithContext vl x vr:vxs + uncurry_f vxs (vl, x, vr) = f vxs vl x vr + xs_list = toList xs + +prop_foldrWithPos :: FingerTree MA VA -> Bool +prop_foldrWithPos xs = + foldrWithPos f z xs == foldr uncurry_f z (zip (prefixes xs_list) xs_list) + where + z = [] + f v x vxs = WithPos v x:vxs + uncurry_f (v, x) vxs = f v x vxs + xs_list = toList xs + +prop_foldrWithContext :: FingerTree MA VA -> Bool +prop_foldrWithContext xs = + foldrWithContext f z xs == foldr uncurry_f z (zip3 (prefixes xs_list) xs_list (suffixes xs_list)) + where + z = [] + f vl x vr vxs = WithContext vl x vr:vxs + uncurry_f (vl, x, vr) vxs = f vl x vr vxs + xs_list = toList xs + +-- ** Traversals + +prop_traverse' :: Seq A -> Bool +prop_traverse' xs = + evalM (traverse' f xs) ~= evalM (traverse f (toList xs)) + where + f x = do + n <- step + return (n, x) + +prop_traverseWithPos :: FingerTree MA VA -> Bool +prop_traverseWithPos xs = + evalM (traverseWithPos f xs) ~= evalM (traverse (uncurry f) (zip (prefixes xs_list) xs_list)) + where + f v y = do + n <- step + return (WithPos v (n, y)) + xs_list = toList xs + +prop_traverseWithContext :: FingerTree MA VA -> Bool +prop_traverseWithContext xs = + evalM (traverseWithContext f xs) ~= evalM (traverse uncurry_f (zip3 (prefixes xs_list) xs_list (suffixes xs_list))) + where + uncurry_f (vl, y, vr) = f vl y vr + f vl y vr = do + n <- step + return (WithContext vl (n, y) vr) + xs_list = toList xs + +-- measure to the left of each value +prefixes :: (Measured v a) => [a] -> [v] +prefixes = scanl (<>) mempty . map measure + +-- measure to the right of each value +suffixes :: (Measured v a) => [a] -> [v] +suffixes = tail . scanr (<>) mempty . map measure + +------------------------------------------------------------------------ +-- QuickCheck +------------------------------------------------------------------------ + +instance (Arbitrary a, Measured v a) => Arbitrary (FingerTree v a) where + arbitrary = sized arb + where + arb :: (Arbitrary a, Measured v a) => Int -> Gen (FingerTree v a) + arb 0 = return Empty + arb 1 = Single <$> arbitrary + arb n = deep <$> arbitrary <*> arb (n `div` 2) <*> arbitrary + + shrink (Deep _ (One a) Empty (One b)) = [Single a, Single b] + shrink (Deep _ pr m sf) = + [deep pr' m sf | pr' <- shrink pr] ++ + [deep pr m' sf | m' <- shrink m] ++ + [deep pr m sf' | sf' <- shrink sf] + shrink (Single x) = map Single (shrink x) + shrink Empty = [] + +instance (Arbitrary a, Measured v a) => Arbitrary (Node v a) where + arbitrary = oneof [ + node2 <$> arbitrary <*> arbitrary, + node3 <$> arbitrary <*> arbitrary <*> arbitrary] + + shrink (Node2 _ a b) = + [node2 a' b | a' <- shrink a] ++ + [node2 a b' | b' <- shrink b] + shrink (Node3 _ a b c) = + [node2 a b, node2 a c, node2 b c] ++ + [node3 a' b c | a' <- shrink a] ++ + [node3 a b' c | b' <- shrink b] ++ + [node3 a b c' | c' <- shrink c] + +instance Arbitrary a => Arbitrary (Digit a) where + arbitrary = oneof [ + One <$> arbitrary, + Two <$> arbitrary <*> arbitrary, + Three <$> arbitrary <*> arbitrary <*> arbitrary, + Four <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary] + + shrink (One a) = map One (shrink a) + shrink (Two a b) = [One a, One b] + shrink (Three a b c) = [Two a b, Two a c, Two b c] + shrink (Four a b c d) = [Three a b c, Three a b d, Three a c d, Three b c d] + +------------------------------------------------------------------------ +-- Valid trees +------------------------------------------------------------------------ + +class Valid a where + valid :: a -> Bool + +instance (Measured v a, Eq v, Valid a) => Valid (FingerTree v a) where + valid Empty = True + valid (Single x) = valid x + valid (Deep s pr m sf) = + s == measure pr `mappend` measure m `mappend` measure sf && + valid pr && valid m && valid sf + +instance (Measured v a, Eq v, Valid a) => Valid (Node v a) where + valid node = measure node == foldMap measure node && all valid node + +instance Valid a => Valid (Digit a) where + valid = all valid + +instance Valid A where + valid = const True + +instance Valid (a,b) where + valid = const True + +instance Valid (a,b,c) where + valid = const True + +instance Valid (Maybe a) where + valid = const True + +instance Valid [a] where + valid = const True + +------------------------------------------------------------------------ +-- Use list of elements as the measure +------------------------------------------------------------------------ + +type Seq a = FingerTree [a] a + +instance Measured [A] A where + measure x = [x] + +instance Measured [OrdA] OrdA where + measure x = [x] + +instance Measured [Maybe a] (Maybe a) where + measure x = [x] + +instance Measured [(a, b)] (a, b) where + measure x = [x] + +------------------------------------------------------------------------ +-- A noncommutative monoid as a measure: semidirect product +------------------------------------------------------------------------ + +data MA = MA Int Int + deriving (Eq, Show) + +instance Semigroup MA where + MA a x <> MA b y = MA (a*b) (x + a*y) + +instance Monoid MA where + mempty = MA 1 0 + +instance Valid MA where + valid = const True + +newtype VA = VA Int + deriving (Eq, Show) + +instance Measured MA VA where + measure (VA x) = MA 3 x + +instance Arbitrary VA where + arbitrary = VA <$> arbitrary + shrink (VA x) = map VA (shrink x) + +instance Valid VA where + valid = const True + +------------------------------------------------------------------------ +-- Values with positions and contexts +------------------------------------------------------------------------ + +data WithPos v a = WithPos v a + deriving (Eq, Show) + +instance Monoid v => Measured v (WithPos v a) where + measure (WithPos v _) = v + +instance (Valid v, Valid a) => Valid (WithPos v a) where + valid (WithPos v x) = valid v && valid x + +data WithContext v a = WithContext v a v + deriving (Eq, Show) + +instance Monoid v => Measured v (WithContext v a) where + measure (WithContext vl _ vr) = vl + +instance (Valid v, Valid a) => Valid (WithContext v a) where + valid (WithContext vl x vr) = valid vl && valid x && valid vr + +------------------------------------------------------------------------ +-- Simple counting monad +------------------------------------------------------------------------ + +newtype M a = M (Int -> (Int, a)) + +runM :: M a -> Int -> (Int, a) +runM (M m) = m + +evalM :: M a -> a +evalM m = snd (runM m 0) + +instance Monad M where + return = pure + M u >>= f = M $ \ m -> let (n, x) = u m in runM (f x) n + +instance Functor M where + fmap f (M u) = M $ \ m -> let (n, x) = u m in (n, f x) + +instance Applicative M where + pure x = M $ \ n -> (n, x) + (<*>) = ap + +step :: M Int +step = M $ \ n -> (n+1, n)