fingertree 0.1.4.2 → 0.1.6.3
raw patch · 6 files changed
Files
- Data/FingerTree.hs +342/−88
- Data/IntervalMap/FingerTree.hs +21/−5
- Data/PriorityQueue/FingerTree.hs +19/−7
- changelog +14/−0
- fingertree.cabal +9/−7
- tests/ft-properties.hs +168/−44
Data/FingerTree.hs view
@@ -9,13 +9,18 @@ #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE DeriveGeneric #-} #endif-#if __GLASGOW_HASKELL__ >= 710+#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 802 {-# LANGUAGE AutoDeriveTypeable #-} #endif+#if __GLASGOW_HASKELL__ >= 710+{-# LANGUAGE DeriveAnyClass #-}+#endif ----------------------------------------------------------------------------- -- | -- Module : Data.FingerTree--- Copyright : (c) Ross Paterson, Ralf Hinze 2006+-- 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@@ -28,7 +33,7 @@ -- * Ralf Hinze and Ross Paterson, -- \"Finger trees: a simple general-purpose data structure\", -- /Journal of Functional Programming/ 16:2 (2006) pp 197-217.--- <http://staff.city.ac.uk/~ross/papers/FingerTree.html>+-- <https://staff.city.ac.uk/~ross/papers/FingerTree.html> -- -- For a directly usable sequence type, see @Data.Sequence@, which is -- a specialization of this structure.@@ -68,6 +73,8 @@ reverse, -- ** Maps fmap', fmapWithPos, fmapWithContext, unsafeFmap,+ -- ** Folds+ foldlWithPos, foldrWithPos, foldlWithContext, foldrWithContext, -- ** Traversals traverse', traverseWithPos, traverseWithContext, unsafeTraverse, -- * Example@@ -83,11 +90,14 @@ #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 ><@@ -101,7 +111,10 @@ 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.@@ -112,7 +125,10 @@ deriving (Eq, Ord, Show, Read #if __GLASGOW_HASKELL__ >= 706 , Generic+#if __GLASGOW_HASKELL__ >= 710+ , NFData #endif+#endif ) instance (Functor s) => Functor (ViewL s) where@@ -145,7 +161,10 @@ deriving (Show #if __GLASGOW_HASKELL__ >= 706 , Generic+#if __GLASGOW_HASKELL__ >= 710+ , NFData #endif+#endif ) instance Foldable Digit where@@ -173,7 +192,10 @@ deriving (Show #if __GLASGOW_HASKELL__ >= 706 , Generic+#if __GLASGOW_HASKELL__ >= 710+ , NFData #endif+#endif ) instance Foldable (Node v) where@@ -213,8 +235,13 @@ 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@@ -287,39 +314,40 @@ 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)+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- vpr = v `mappend` measure pr- vm = vpr `mappend` measure m+ 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 v (Node2 _ a b) = node2 (f v a) (f va b)+mapWPNode f vl (Node2 _ a b) = node2 (f vl a) (f vla b) where- va = v `mappend` measure a-mapWPNode f v (Node3 _ a b c) = node3 (f v a) (f va b) (f vab c)+ vla = vl `mappend` measure a+mapWPNode f vl (Node3 _ a b c) = node3 (f vl a) (f vla b) (f vlab c) where- va = v `mappend` measure a- vab = va `mappend` measure b+ 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 v (One a) = One (f v a)-mapWPDigit f v (Two a b) = Two (f v a) (f va b)+mapWPDigit f vl (One a) = One (f vl a)+mapWPDigit f vl (Two a b) = Two (f vl a) (f vla b) where- va = v `mappend` measure a-mapWPDigit f v (Three a b c) = Three (f v a) (f va b) (f vab c)+ vla = vl `mappend` measure a+mapWPDigit f vl (Three a b c) = Three (f vl a) (f vla b) (f vlab 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)+ 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- va = v `mappend` measure a- vab = va `mappend` measure b- vabc = vab `mappend` measure c+ 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@@ -347,39 +375,41 @@ 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 vb) (f va b vr)+mapWCNode f vl (Node2 _ a b) vr = node2 (f vl a vbr) (f vla b vr) where- va = vl `mappend` measure a- vb = measure b `mappend` vr-mapWCNode f vl (Node3 _ a b c) vr = node3 (f vl a vbc) (f va b vc) (f vab c vr)+ 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- va = vl `mappend` measure a- vab = va `mappend` measure b- vbc = measure b `mappend` vc- vc = measure c `mappend` vr+ 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 vb) (f va b vr)+mapWCDigit f vl (Two a b) vr = Two (f vl a vbr) (f vla b vr) where- va = vl `mappend` measure a- vb = measure b `mappend` vr-mapWCDigit f vl (Three a b c) vr = Three (f vl a vbc) (f va b vc) (f vab c vr)+ 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- va = vl `mappend` measure a- vab = va `mappend` measure b- vbc = measure b `mappend` vc- vc = measure c `mappend` vr+ 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 vbcd) (f va b vcd) (f vab c vd) (f vabc d vr)+ Four (f vl a vbcdr) (f vla b vcdr) (f vlab c vdr) (f vlabc d vr) 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+ 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@@ -392,6 +422,224 @@ 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)@@ -481,41 +729,41 @@ 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 vb <*> f va b vr+traverseWCNode f vl (Node2 _ a b) vr = node2 <$> f vl a vbr <*> f vla b vr where- va = vl `mappend` measure a- vb = measure a `mappend` vr+ vla = vl `mappend` measure a+ vbr = measure b `mappend` vr traverseWCNode f vl (Node3 _ a b c) vr =- node3 <$> f vl a vbc <*> f va b vc <*> f vab c vr+ node3 <$> f vl a vbcr <*> f vla b vcr <*> f vlab c vr where- va = vl `mappend` measure a- vab = va `mappend` measure b- vc = measure c `mappend` vr- vbc = measure b `mappend` vc+ 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 vb <*> f va b vr+traverseWCDigit f vl (Two a b) vr = Two <$> f vl a vbr <*> f vla b vr where- va = vl `mappend` measure a- vb = measure a `mappend` vr+ vla = vl `mappend` measure a+ vbr = measure b `mappend` vr traverseWCDigit f vl (Three a b c) vr =- Three <$> f vl a vbc <*> f va b vc <*> f vab c vr+ Three <$> f vl a vbcr <*> f vla b vcr <*> f vlab c vr where- va = vl `mappend` measure a- vab = va `mappend` measure b- vc = measure c `mappend` vr- vbc = measure b `mappend` vc+ 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 vbcd <*> f va b vcd <*> f vab c vd <*> f vabc d vr+ Four <$> f vl a vbcdr <*> f vla b vcdr <*> f vlab c vdr <*> f vlabc d vr where- va = vl `mappend` measure a- vab = va `mappend` measure b- vabc = vab `mappend` measure c- vd = measure d `mappend` vr- vcd = measure c `mappend` vd- vbcd = measure b `mappend` vcd+ 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) =>@@ -646,6 +894,8 @@ (><) :: (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@@ -885,7 +1135,7 @@ -- -- @since 0.1.2.0 data SearchResult v a- = Position (FingerTree v a) a (FingerTree 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@@ -901,7 +1151,10 @@ 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@@ -961,13 +1214,13 @@ searchTree _ _ Empty _ = illegal_argument "searchTree" searchTree _ _ (Single x) _ = Split Empty x Empty searchTree p vl (Deep _ pr m sf) vr- | p vlp vmsr = let Split l x r = searchDigit p vl pr vmsr- in Split (maybe Empty digitToTree l) x (deepL r m sf)- | p vlpm vsr = let Split ml xs mr = searchTree p vlp m vsr- Split l x r = searchNode p (vlp `mappend` measure ml) xs (measure mr `mappend` vsr)- in Split (deepR pr ml l) x (deepL r mr sf)- | otherwise = let Split l x r = searchDigit p vlpm sf vr- in Split (deepR pr m l) x (maybe Empty digitToTree r)+ | 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@@ -1054,20 +1307,20 @@ 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+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 = 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 `mappend` measure 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)+ | 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@@ -1156,7 +1409,8 @@ 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:+Simple sequences can be implemented using a 'Data.Monoid.Sum' monoid+as a measure: > newtype Elem a = Elem { getElem :: a } >
Data/IntervalMap/FingerTree.hs view
@@ -6,9 +6,12 @@ #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE DeriveGeneric #-} #endif-#if __GLASGOW_HASKELL__ >= 710+#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 802 {-# LANGUAGE AutoDeriveTypeable #-} #endif+#if __GLASGOW_HASKELL__ >= 710+{-# LANGUAGE DeriveAnyClass #-}+#endif ----------------------------------------------------------------------------- -- | -- Module : Data.PriorityQueue.FingerTree@@ -24,7 +27,7 @@ -- * Ralf Hinze and Ross Paterson, -- \"Finger trees: a simple general-purpose data structure\", -- /Journal of Functional Programming/ 16:2 (2006) pp 197-217.--- <http://staff.city.ac.uk/~ross/papers/FingerTree.html>+-- <https://staff.city.ac.uk/~ross/papers/FingerTree.html> -- -- An amortized running time is given for each operation, with /n/ -- referring to the size of the priority queue. These bounds hold even@@ -58,13 +61,16 @@ import qualified Prelude (null) #else import Control.Applicative ((<$>))-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) ----------------------------------@@ -77,7 +83,10 @@ deriving (Eq, Ord, Show, Read #if __GLASGOW_HASKELL__ >= 706 , Generic+#if __GLASGOW_HASKELL__ >= 710+ , NFData #endif+#endif ) -- | Lower bound of the interval@@ -96,7 +105,10 @@ deriving (Eq, Ord, Show, Read #if __GLASGOW_HASKELL__ >= 706 , Generic+#if __GLASGOW_HASKELL__ >= 710+ , NFData #endif+#endif ) instance Functor (Node v) where@@ -110,7 +122,9 @@ -- rightmost interval (including largest lower bound) and largest upper bound. data IntInterval v = NoInterval | IntInterval (Interval v) v-#if __GLASGOW_HASKELL__ >= 706+#if __GLASGOW_HASKELL__ >= 710+ deriving (Generic, NFData)+#elif __GLASGOW_HASKELL__ >= 706 deriving (Generic) #endif @@ -137,7 +151,9 @@ -- | Map of closed intervals, possibly with duplicates. newtype IntervalMap v a = IntervalMap (FingerTree (IntInterval v) (Node v a))-#if __GLASGOW_HASKELL__ >= 706+#if __GLASGOW_HASKELL__ >= 710+ deriving (Generic, NFData)+#elif __GLASGOW_HASKELL__ >= 706 deriving (Generic) #endif -- ordered lexicographically by interval
Data/PriorityQueue/FingerTree.hs view
@@ -6,9 +6,12 @@ #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE DeriveGeneric #-} #endif-#if __GLASGOW_HASKELL__ >= 710+#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 802 {-# LANGUAGE AutoDeriveTypeable #-} #endif+#if __GLASGOW_HASKELL__ >= 710+{-# LANGUAGE DeriveAnyClass #-}+#endif ----------------------------------------------------------------------------- -- | -- Module : Data.PriorityQueue.FingerTree@@ -24,7 +27,7 @@ -- * Ralf Hinze and Ross Paterson, -- \"Finger trees: a simple general-purpose data structure\", -- /Journal of Functional Programming/ 16:2 (2006) pp 197-217.--- <http://staff.city.ac.uk/~ross/papers/FingerTree.html>+-- <https://staff.city.ac.uk/~ross/papers/FingerTree.html> -- -- These have the same big-O complexity as skew heap implementations, -- but are approximately an order of magnitude slower.@@ -67,17 +70,22 @@ #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,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) data Entry k v = Entry k v-#if __GLASGOW_HASKELL__ >= 706+#if __GLASGOW_HASKELL__ >= 710+ deriving (Generic, NFData)+#elif __GLASGOW_HASKELL__ >= 706 deriving (Generic) #endif @@ -88,7 +96,9 @@ foldMap f (Entry _ v) = f v data Prio k v = NoPrio | Prio k v-#if __GLASGOW_HASKELL__ >= 706+#if __GLASGOW_HASKELL__ >= 710+ deriving (Generic, NFData)+#elif __GLASGOW_HASKELL__ >= 706 deriving (Generic) #endif @@ -115,7 +125,9 @@ -- | Priority queues. newtype PQueue k v = PQueue (FingerTree (Prio k v) (Entry k v))-#if __GLASGOW_HASKELL__ >= 706+#if __GLASGOW_HASKELL__ >= 710+ deriving (Generic, NFData)+#elif __GLASGOW_HASKELL__ >= 706 deriving (Generic) #endif @@ -163,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@ --
changelog view
@@ -1,5 +1,19 @@ -*-change-log-*- +0.1.6.3 Ross Paterson <R.Paterson@city.ac.uk> Dec 2025+ * Patches for MicroHS++0.1.6.2 Ross Paterson <R.Paterson@city.ac.uk> Jul 2025+ * Change http links in docs to https++0.1.6.1 Ross Paterson <R.Paterson@city.ac.uk> May 2025+ * Added NFData instances++0.1.5.0 Ross Paterson <R.Paterson@city.ac.uk> Jan 2022+ * Added foldlWithPos, foldrWithPos, foldlWithContext, foldrWithContext (James Cranch)+ * Fixed bug in traverseWithContext+ * Made split and search stricter+ 0.1.4.2 Ross Paterson <R.Paterson@city.ac.uk> Dec 2018 * Fixed bug in search
fingertree.cabal view
@@ -1,11 +1,11 @@ Name: fingertree-Version: 0.1.4.2+Version: 0.1.6.3 Cabal-Version: 1.18 Copyright: (c) 2006 Ross Paterson, Ralf Hinze License: BSD3 License-File: LICENSE Maintainer: Ross Paterson <R.Paterson@city.ac.uk>-bug-reports: http://hub.darcs.net/ross/fingertree/issues+bug-reports: https://hub.darcs.net/ross/fingertree/issues Category: Data Structures Synopsis: Generic finger-tree structure, with example instances Description:@@ -17,23 +17,24 @@ * Ralf Hinze and Ross Paterson, \"Finger trees: a simple general-purpose data structure\", /Journal of Functional Programming/ 16:2 (2006) pp 197-217.- <http://staff.city.ac.uk/~ross/papers/FingerTree.html>+ <https://staff.city.ac.uk/~ross/papers/FingerTree.html> . 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:+ changelog images/search.svg Source-Repository head Type: darcs- Location: http://hub.darcs.net/ross/fingertree+ Location: https://hub.darcs.net/ross/fingertree Library- Build-Depends: base < 6+ Build-Depends:+ base < 6,+ deepseq >= 1.3 && < 1.6 Default-Language: Haskell2010 Other-Extensions: MultiParamTypeClasses@@ -52,6 +53,7 @@ default-language: Haskell2010 build-depends: base >= 4.2 && < 6,+ deepseq >= 1.3 && < 1.6, HUnit, QuickCheck, test-framework,
tests/ft-properties.hs view
@@ -48,9 +48,15 @@ , testProperty "dropUntil" prop_dropUntil , testProperty "reverse" prop_reverse , testProperty "fmap'" prop_fmap'- -- , testProperty "fmapWithPos" prop_fmapWithPos -- (slow)+ , 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 -- (slow)+ , testProperty "traverseWithPos" prop_traverseWithPos+ , testProperty "traverseWithContext" prop_traverseWithContext ] runner_opts where runner_opts = mempty { ropt_test_options = Just test_opts }@@ -71,8 +77,8 @@ infix 4 ~= -(~=) :: Eq a => Maybe a -> a -> Bool-(~=) = maybe (const False) (==)+(~=) :: (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]@@ -80,11 +86,6 @@ | valid xs = Just (toList xs) | otherwise = Nothing -toListPair' ::- (Eq a, Measured [a] a, Valid a, Eq b, Measured [b] b, Valid b) =>- (Seq a, Seq b) -> Maybe ([a], [b])-toListPair' (xs, ys) = (,) <$> toList' xs <*> toList' ys- -- instances prop_foldr :: Seq A -> Bool@@ -111,7 +112,7 @@ prop_mappend :: Seq A -> Seq A -> Bool prop_mappend xs ys =- toList' (mappend xs ys) ~= toList xs ++ toList ys+ mappend xs ys ~= toList xs ++ toList ys -- * Construction @@ -121,23 +122,23 @@ prop_singleton :: A -> Bool prop_singleton x =- toList' (singleton x) ~= [x]+ singleton x ~= [x] prop_cons :: A -> Seq A -> Bool prop_cons x xs =- toList' (x <| xs) ~= x : toList xs+ x <| xs ~= x : toList xs prop_snoc :: Seq A -> A -> Bool prop_snoc xs x =- toList' (xs |> x) ~= toList xs ++ [x]+ xs |> x ~= toList xs ++ [x] prop_append :: Seq A -> Seq A -> Bool prop_append xs ys =- toList' (xs >< ys) ~= toList xs ++ toList ys+ xs >< ys ~= toList xs ++ toList ys prop_fromList :: [A] -> Bool prop_fromList xs =- toList' (fromList xs) ~= xs+ fromList xs ~= xs -- * Deconstruction @@ -145,6 +146,8 @@ prop_null xs = null xs == Prelude.null (toList xs) +-- ** Examining the ends+ prop_viewl :: Seq A -> Bool prop_viewl xs = case viewl xs of@@ -157,6 +160,8 @@ 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@@ -164,13 +169,13 @@ 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+ where+ p vl vr = Prelude.length vl >= len - n && Prelude.length vr <= n - indexFromEnd :: Int -> [a] -> Maybe a- indexFromEnd i = listToMaybe . drop i . Prelude.reverse+ len = length xs + indexFromEnd :: Int -> [a] -> Maybe a+ indexFromEnd i = listToMaybe . drop i . Prelude.reverse test_search :: Assertion test_search = do@@ -186,60 +191,131 @@ Position _ x _ -> Just x _ -> Nothing +-- ** Splitting+ prop_split :: Int -> Seq A -> Bool prop_split n xs =- toListPair' (split p xs) ~= Prelude.splitAt n (toList xs)- where p ys = Prelude.length ys > n+ 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 =- toList' (takeUntil p xs) ~= Prelude.take n (toList xs)- where p ys = Prelude.length ys > n+ 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 =- toList' (dropUntil p xs) ~= Prelude.drop n (toList xs)- where p ys = Prelude.length ys > n+ dropUntil p xs ~= Prelude.drop n (toList xs)+ where+ p ys = Prelude.length ys > n -- * Transformation prop_reverse :: Seq A -> Bool prop_reverse xs =- toList' (reverse xs) ~= Prelude.reverse (toList xs)+ reverse xs ~= Prelude.reverse (toList xs) +-- ** Maps+ prop_fmap' :: Seq A -> Bool prop_fmap' xs =- toList' (fmap' f xs) ~= map f (toList xs)- where f = Just+ fmap' f xs ~= map f (toList xs)+ where+ f = Just -prop_fmapWithPos :: Seq A -> Bool+prop_fmapWithPos :: FingerTree MA VA -> Bool prop_fmapWithPos xs =- toList' (fmapWithPos f xs) ~= zipWith f (inits xs_list) xs_list+ fmapWithPos f xs ~= zipWith f (prefixes xs_list) xs_list where- f = (,)+ 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 =- toList' (evalM (traverse' f xs)) ~= evalM (traverse f (toList xs))+ evalM (traverse' f xs) ~= evalM (traverse f (toList xs)) where f x = do n <- step return (n, x) -prop_traverseWithPos :: Seq A -> Bool+prop_traverseWithPos :: FingerTree MA VA -> Bool prop_traverseWithPos xs =- toList' (evalM (traverseWithPos f xs)) ~= evalM (traverse (uncurry f) (zip (inits xs_list) xs_list))+ evalM (traverseWithPos f xs) ~= evalM (traverse (uncurry f) (zip (prefixes xs_list) xs_list)) where- f xs y = do+ f v y = do n <- step- return (xs, n, y)+ return (WithPos v (n, y)) xs_list = toList xs -{- untested:-traverseWithPos--}+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 ------------------------------------------------------------------------@@ -339,10 +415,58 @@ 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 ------------------------------------------------------------------------ @@ -355,14 +479,14 @@ evalM m = snd (runM m 0) instance Monad M where- return x = M $ \ n -> (n, x)+ 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 = return+ pure x = M $ \ n -> (n, x) (<*>) = ap step :: M Int