fingertree-0.1.5.0/0000755000000000000000000000000007346545000012176 5ustar0000000000000000fingertree-0.1.5.0/Data/0000755000000000000000000000000007346545000013047 5ustar0000000000000000fingertree-0.1.5.0/Data/FingerTree.hs0000644000000000000000000014756707346545000015461 0ustar0000000000000000{-# 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 ----------------------------------------------------------------------------- -- | -- 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 import Data.Foldable (Foldable(foldMap)) #endif #if (MIN_VERSION_base(4,9,0)) && !(MIN_VERSION_base(4,11,0)) import Data.Semigroup #endif 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 #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 #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 #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 #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 #endif ) #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 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 #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 } > > instance Measured (Sum Int) (Elem a) where > measure (Elem _) = Sum 1 > > newtype Seq a = Seq (FingerTree (Sum Int) (Elem a)) Then the measure of a subsequence is simply its length. This representation supports log-time extraction of subsequences: > take :: Int -> Seq a -> Seq a > take k (Seq xs) = Seq (takeUntil (> Sum k) xs) > > drop :: Int -> Seq a -> Seq a > drop k (Seq xs) = Seq (dropUntil (> Sum k) xs) The module @Data.Sequence@ is an optimized instantiation of this type. For further examples, see "Data.IntervalMap.FingerTree" and "Data.PriorityQueue.FingerTree". -} fingertree-0.1.5.0/Data/IntervalMap/0000755000000000000000000000000007346545000015271 5ustar0000000000000000fingertree-0.1.5.0/Data/IntervalMap/FingerTree.hs0000644000000000000000000002520707346545000017665 0ustar0000000000000000{-# 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 ----------------------------------------------------------------------------- -- | -- Module : Data.PriorityQueue.FingerTree -- Copyright : (c) Ross Paterson 2008 -- License : BSD-style -- 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. -- -- -- An amortized running time is given for each operation, with /n/ -- referring to the size of the priority queue. 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.IntervalMap.FingerTree ( -- * 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.Foldable (Foldable(foldMap)) import Data.Monoid import Data.Traversable (Traversable(traverse)) #endif #if (MIN_VERSION_base(4,9,0)) && !(MIN_VERSION_base(4,11,0)) import Data.Semigroup #endif import Data.Foldable (toList) ---------------------------------- -- 4.8 Application: interval trees ---------------------------------- -- | A closed interval. The lower bound should be less than or equal -- 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 #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 #endif ) instance Functor (Node v) where fmap f (Node i x) = Node i (f x) instance Foldable (Node v) where foldMap f (Node _ x) = f x instance Traversable (Node v) where 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__ >= 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 #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) -- | Map of closed intervals, possibly with duplicates. newtype IntervalMap v a = IntervalMap (FingerTree (IntInterval v) (Node v a)) #if __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) -- | Values in lexicographical order of intervals. instance Foldable (IntervalMap v) where 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 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 -- | /O(1)/. Interval map with a single entry. singleton :: (Ord v) => Interval v -> a -> IntervalMap v a singleton i x = IntervalMap (FT.singleton (Node i x)) -- | /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) _ 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 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 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. intersections :: (Ord v) => Interval v -> IntervalMap v a -> [(Interval v, a)] intersections i = inRange (low i) (high i) -- | /O(k log (n/\//k))/. All intervals that contain the given interval, -- in lexicographical order. dominators :: (Ord v) => Interval v -> IntervalMap v a -> [(Interval v, a)] dominators i = inRange (high i) (low i) -- | /O(k log (n/\//k))/. All intervals that contain the given point, -- in lexicographical order. search :: (Ord v) => v -> IntervalMap v a -> [(Interval v, a)] search p = inRange p p -- | /O(k log (n/\//k))/. All intervals that intersect with the given -- 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' -- | /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 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")] mathematicians :: IntervalMap Int String mathematicians = mkMap [ (1642, 1727, "Newton"), (1646, 1716, "Leibniz"), (1707, 1783, "Euler"), (1736, 1813, "Lagrange"), (1777, 1855, "Gauss"), (1811, 1831, "Galois")] -} fingertree-0.1.5.0/Data/PriorityQueue/0000755000000000000000000000000007346545000015675 5ustar0000000000000000fingertree-0.1.5.0/Data/PriorityQueue/FingerTree.hs0000644000000000000000000001660307346545000020271 0ustar0000000000000000{-# 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 ----------------------------------------------------------------------------- -- | -- Module : Data.PriorityQueue.FingerTree -- Copyright : (c) Ross Paterson 2008 -- License : BSD-style -- 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. -- -- -- These have the same big-O complexity as skew heap implementations, -- but are approximately an order of magnitude slower. -- On the other hand, they are stable, so they can be used for fair -- queueing. They are also shallower, so that 'fmap' consumes less -- space. -- -- An amortized running time is given for each operation, with /n/ -- referring to the size of the priority queue. 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.PriorityQueue.FingerTree ( 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(..)) 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.Foldable (Foldable(foldMap)) import Data.Monoid #endif #if (MIN_VERSION_base(4,9,0)) && !(MIN_VERSION_base(4,11,0)) import Data.Semigroup #endif import Control.Arrow ((***)) import Data.List (unfoldr) data Entry k v = Entry k v #if __GLASGOW_HASKELL__ >= 706 deriving (Generic) #endif instance Functor (Entry k) where fmap f (Entry k v) = Entry k (f v) instance Foldable (Entry k) where foldMap f (Entry _ v) = f v data Prio k v = NoPrio | Prio k v #if __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 #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 -- | Priority queues. newtype PQueue k v = PQueue (FingerTree (Prio k v) (Entry k v)) #if __GLASGOW_HASKELL__ >= 706 deriving (Generic) #endif instance Ord k => Functor (PQueue k) where 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' #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 #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 -- | /O(1)/. A singleton priority queue. singleton :: Ord k => k -> v -> PQueue k v singleton k v = PQueue (FT.singleton (Entry k v)) -- | /O(1)/. Add a (priority, value) pair to the front of a priority queue. -- -- * @'insert' k v q = 'union' ('singleton' k v) q@ -- -- If @q@ contains entries with the same priority @k@, 'minView' of -- @'insert' k v q@ will return them after this one. insert :: Ord k => k -> v -> PQueue k v -> PQueue k v insert k v (PQueue q) = PQueue (Entry k v <| q) -- | /O(log n)/. Add a (priority, value) pair to the back of a priority queue. -- -- * @'add' k v q = 'union' q ('singleton' k v)@ -- -- If @q@ contains entries with the same priority @k@, 'minView' of -- @'add' k v q@ will return them before this one. add :: Ord k => k -> v -> PQueue k v -> PQueue k v add k v (PQueue q) = PQueue (q |> Entry k v) -- | /O(log(min(n1,n2)))/. Concatenate two priority queues. -- 'union' is associative, with identity 'empty'. -- -- If there are entries with the same priority in both arguments, 'minView' -- of @'union' xs ys@ will return those from @xs@ before those from @ys@. union :: Ord k => PQueue k v -> PQueue k v -> PQueue k v union (PQueue xs) (PQueue ys) = PQueue (xs >< ys) -- | /O(n)/. Create a priority queue from a finite list of priorities -- and values. fromList :: Ord k => [(k, v)] -> PQueue k v fromList = foldr (uncurry insert) empty -- | /O(1)/. Is this the empty priority queue? null :: Ord k => PQueue k v -> Bool null (PQueue q) = FT.null q -- | /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. -- -- * @'minView' 'empty' = 'Nothing'@ -- -- * @'minView' ('singleton' k v) = 'Just' (v, 'empty')@ -- minView :: Ord k => PQueue k v -> Maybe (v, PQueue k v) minView q = fmap (snd *** id) (minViewWithKey q) -- | /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. -- -- * @'minViewWithKey' 'empty' = 'Nothing'@ -- -- * @'minViewWithKey' ('singleton' k v) = 'Just' ((k, v), 'empty')@ -- -- * If @'minViewWithKey' qi = 'Just' ((ki, vi), qi')@ and @k1 <= k2@, -- then @'minViewWithKey' ('union' q1 q2) = 'Just' ((k1, v1), 'union' q1' q2)@ -- -- * If @'minViewWithKey' qi = 'Just' ((ki, vi), qi')@ and @k2 < k1@, -- then @'minViewWithKey' ('union' q1 q2) = 'Just' ((k2, v2), 'union' q1 q2')@ -- minViewWithKey :: Ord k => PQueue k v -> Maybe ((k, v), PQueue k v) 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 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 fingertree-0.1.5.0/LICENSE0000644000000000000000000000311307346545000013201 0ustar0000000000000000The Glasgow Haskell Compiler License Copyright 2006, The University Court of the University of Glasgow. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - Neither name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. fingertree-0.1.5.0/Setup.hs0000644000000000000000000000005607346545000013633 0ustar0000000000000000import Distribution.Simple main = defaultMain fingertree-0.1.5.0/changelog0000755000000000000000000000366207346545000014062 0ustar0000000000000000-*-change-log-*- 0.1.5.0 Ross Paterson Jan 2022 * Added foldlWithPos, foldrWithPos, foldlWithContext, foldrWithContext (James Cranch) * Fixed bug in traverseWithContext 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 fingertree-0.1.5.0/fingertree.cabal0000644000000000000000000000401707346545000015316 0ustar0000000000000000Name: fingertree Version: 0.1.5.0 Cabal-Version: 1.18 Copyright: (c) 2006 Ross Paterson, Ralf Hinze License: BSD3 License-File: LICENSE Maintainer: Ross Paterson bug-reports: http://hub.darcs.net/ross/fingertree/issues Category: Data Structures Synopsis: Generic finger-tree structure, with example instances Description: A general sequence representation with arbitrary annotations, for use as a base for implementations of various collection types, with examples, 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 tuned sequence type, see @Data.Sequence@ in the @containers@ package, which is a specialization of this structure. Build-Type: Simple Extra-Source-Files: changelog Extra-Doc-Files: images/search.svg Source-Repository head Type: darcs Location: http://hub.darcs.net/ross/fingertree Library Build-Depends: base < 6 Default-Language: Haskell2010 Other-Extensions: MultiParamTypeClasses FunctionalDependencies FlexibleInstances UndecidableInstances Exposed-Modules: 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, HUnit, QuickCheck, test-framework, test-framework-hunit, test-framework-quickcheck2 fingertree-0.1.5.0/images/0000755000000000000000000000000007346545000013443 5ustar0000000000000000fingertree-0.1.5.0/images/search.svg0000644000000000000000000000405207346545000015432 0ustar0000000000000000 l x r measure l measure (x <| r) measure (l |> x) measure r p False True fingertree-0.1.5.0/tests/0000755000000000000000000000000007346545000013340 5ustar0000000000000000fingertree-0.1.5.0/tests/ft-properties.hs0000644000000000000000000003420707346545000016505 0ustar0000000000000000{-# 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] instance Measured [(a, b, c)] (a, b, c) 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 x = M $ \ n -> (n, x) 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 = return (<*>) = ap step :: M Int step = M $ \ n -> (n+1, n)