hw-fingertree-strict (empty) → 0.1.0.0
raw patch · 17 files changed
+2359/−0 lines, 17 filesdep +HUnitdep +QuickCheckdep +basesetup-changed
Dependencies added: HUnit, QuickCheck, base, hedgehog, hspec, hw-fingertree-strict, hw-hspec-hedgehog, test-framework, test-framework-hunit, test-framework-quickcheck2
Files
- LICENSE +31/−0
- README.md +1/−0
- Setup.hs +2/−0
- hw-fingertree-strict.cabal +69/−0
- src/HaskellWorks/Data/FingerTree/Strict.hs +871/−0
- src/HaskellWorks/Data/IntervalMap/Strict.hs +216/−0
- src/HaskellWorks/Data/Item/Strict.hs +20/−0
- src/HaskellWorks/Data/PriorityQueue/Strict.hs +181/−0
- src/HaskellWorks/Data/Segment/Strict.hs +18/−0
- src/HaskellWorks/Data/SegmentMap/Strict.hs +202/−0
- src/HaskellWorks/Data/SegmentSet/Strict.hs +221/−0
- test/HaskellWorks/Data/Gen.hs +41/−0
- test/HaskellWorks/Data/SegmentMap/StrictSpec.hs +144/−0
- test/HaskellWorks/Data/SegmentSet/Naive.hs +68/−0
- test/HaskellWorks/Data/SegmentSet/NaiveSpec.hs +65/−0
- test/HaskellWorks/Data/SegmentSet/StrictSpec.hs +208/−0
- test/Spec.hs +1/−0
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright John Ky (c) 2017+Copyright Ross Paterson, Ralf Hinze (c) 2006 ++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 the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 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 COPYRIGHT+OWNER OR 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.
+ README.md view
@@ -0,0 +1,1 @@+# hw-fingertree-strict
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hw-fingertree-strict.cabal view
@@ -0,0 +1,69 @@+name: hw-fingertree-strict+version: 0.1.0.0+-- synopsis:+-- description:+homepage: https://github.com/githubuser/hw-fingertree-strict#readme+license: BSD3+license-file: LICENSE+author: John Ky+maintainer: newhoggy@gmail.com+copyright: 2017 John Ky; 2006 Ross Paterson, Ralf Hinze+category: Data Structures+Synopsis: Generic strict finger-tree structure+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.+ <http://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: README.md+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: HaskellWorks.Data.FingerTree.Strict+ , HaskellWorks.Data.IntervalMap.Strict+ , HaskellWorks.Data.Item.Strict+ , HaskellWorks.Data.PriorityQueue.Strict+ , HaskellWorks.Data.SegmentMap.Strict+ , HaskellWorks.Data.SegmentSet.Strict+ , HaskellWorks.Data.Segment.Strict+ build-depends: base >= 4.7 && < 5+ default-language: Haskell2010++test-suite hw-fingertree-strict-test+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ other-modules: HaskellWorks.Data.Gen+ , HaskellWorks.Data.SegmentMap.StrictSpec+ , HaskellWorks.Data.SegmentSet.StrictSpec+ , HaskellWorks.Data.SegmentSet.Naive+ , HaskellWorks.Data.SegmentSet.NaiveSpec+ hs-source-dirs: test+ main-is: Spec.hs+ cpp-options: -DTESTING+ build-depends: base >= 4.2 && < 6+ , hedgehog+ , hspec+ , HUnit+ , hw-fingertree-strict+ , hw-hspec-hedgehog+ , QuickCheck+ , test-framework+ , test-framework-hunit+ , test-framework-quickcheck2+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/haskell-works/hw-fingertree-strict
+ src/HaskellWorks/Data/FingerTree/Strict.hs view
@@ -0,0 +1,871 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif+#if __GLASGOW_HASKELL__ >= 710+{-# LANGUAGE AutoDeriveTypeable #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module : Data.FingerTree+-- Copyright : (c) Ross Paterson, Ralf Hinze 2006+-- 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.+-- <http://staff.city.ac.uk/~ross/papers/FingerTree.html>+--+-- 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 HaskellWorks.Data.FingerTree.Strict (+ FingerTree(..), Digit(..), Node(..), deep, node2, node3,+ Measured(..),+ -- * Construction+ empty, singleton,+ (<|), (|>), (><),+ fromList,+ -- * Deconstruction+ null,+ ViewL(..), ViewR(..), viewl, viewr,+ split, takeUntil, dropUntil,+ -- * Transformation+ reverse,+ fmap', fmapWithPos, unsafeFmap,+ traverse', traverseWithPos, unsafeTraverse,+ maybeHead, maybeLast+ -- * Example+ -- $example+ ) where++import Prelude hiding (null, reverse)++import Control.Applicative (Applicative (pure, (<*>)), (<$>))+import Data.Foldable (Foldable (foldMap), foldr', toList)+import Data.Monoid++infixr 5 ><+infixr 5 <|, :<+infixl 5 |>, :>++-- | View of the left end of a sequence.+data ViewL s a+ = EmptyL -- ^ empty sequence+ | !a :< !(s a) -- ^ leftmost element and the rest of the sequence+ deriving (Eq, Ord, Show, Read)++-- | View of the right end of a sequence.+data ViewR s a+ = EmptyR -- ^ empty sequence+ | !(s a) :> !a -- ^ the sequence minus the rightmost element,+ -- and the rightmost element+ deriving (Eq, Ord, Show, Read)++instance Functor s => Functor (ViewL s) where+ fmap _ 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++-- | 'empty' and '><'.+instance Measured v a => Monoid (FingerTree v a) where+ mempty = empty+ mappend = (><)++-- Explicit Digit type (Exercise 1)++data Digit a+ = One !a+ | Two !a !a+ | Three !a !a !a+ | Four !a !a !a !a+ deriving Show++instance Foldable Digit where+ foldMap f (One a) = f a+ foldMap f (Two a b) = f a `mappend` f b+ foldMap f (Three a b c) = f a `mappend` f b `mappend` f c+ foldMap f (Four a b c d) = f a `mappend` f b `mappend` f c `mappend` f d++-------------------+-- 4.1 Measurements+-------------------++-- | Things that can be measured.+class (Monoid v) => Measured v a | a -> v where+ measure :: a -> v++instance (Measured v a) => Measured v (Digit a) where+ measure = foldMap measure++---------------------------+-- 4.2 Caching measurements+---------------------------++data Node v a = Node2 !v !a !a | Node3 !v !a !a !a+ deriving Show++instance Foldable (Node v) where+ foldMap f (Node2 _ a b) = f a `mappend` f b+ foldMap f (Node3 _ a b c) = f a `mappend` f b `mappend` f c++node2 :: (Measured v a) => a -> a -> Node v a+node2 a b = Node2 (measure a `mappend` measure b) a b++node3 :: (Measured v a) => a -> a -> a -> Node v a+node3 a b c = Node3 (measure a `mappend` measure b `mappend` measure c) a b c++instance (Monoid v) => Measured v (Node v a) where+ measure (Node2 v _ _) = v+ measure (Node3 v _ _ _) = v++nodeToDigit :: Node v a -> Digit a+nodeToDigit (Node2 _ a b) = Two a b+nodeToDigit (Node3 _ a b c) = Three a b c++-- | A representation of a sequence of values of type @a@, allowing+-- access to the ends in constant time, and append and split in time+-- logarithmic in the size of the smaller piece.+--+-- The collection is also parameterized by a measure type @v@, which+-- is used to specify a position in the sequence for the 'split' operation.+-- The types of the operations enforce the constraint @'Measured' v a@,+-- which also implies that the type @v@ is determined by @a@.+--+-- A variety of abstract data types can be implemented by using different+-- element types and measurements.+data FingerTree v a+ = Empty+ | Single !a+ | Deep !v !(Digit a) !(FingerTree v (Node v a)) !(Digit a)+ deriving (Show)++deep :: (Measured v a) =>+ Digit a -> FingerTree v (Node v a) -> Digit a -> FingerTree v a+deep pr m sf = Deep ((measure pr `mappendVal` m) `mappend` measure sf) pr m sf++-- | /O(1)/. The cached measure of a tree.+instance (Measured v a) => Measured v (FingerTree v a) where+ measure Empty = mempty+ measure (Single x) = measure x+ measure (Deep v _ _ _) = v++instance Foldable (FingerTree v) where+ foldMap _ Empty = mempty+ foldMap f (Single x) = f x+ foldMap f (Deep _ pr m sf) =+ foldMap f pr `mappend` foldMap (foldMap f) m `mappend` foldMap f sf++instance Eq a => Eq (FingerTree v a) where+ xs == ys = toList xs == toList ys++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 a more constrained type.+fmap' :: (Measured v1 a1, Measured v2 a2) =>+ (a1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2+fmap' = mapTree++mapTree :: (Measured v2 a2) =>+ (a1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2+mapTree _ Empty = Empty+mapTree f (Single x) = Single (f x)+mapTree f (Deep _ pr m sf) =+ deep (mapDigit f pr) (mapTree (mapNode f) m) (mapDigit f sf)++mapNode :: (Measured v2 a2) =>+ (a1 -> a2) -> Node v1 a1 -> Node v2 a2+mapNode f (Node2 _ a b) = node2 (f a) (f b)+mapNode f (Node3 _ a b c) = node3 (f a) (f b) (f c)++mapDigit :: (a -> b) -> Digit a -> Digit b+mapDigit f (One a) = One (f a)+mapDigit f (Two a b) = Two (f a) (f b)+mapDigit f (Three a b c) = Three (f a) (f b) (f c)+mapDigit f (Four a b c d) = Four (f a) (f b) (f c) (f d)++-- | Map all elements of the tree with a function that also takes the+-- measure of the prefix of the tree to the left of the element.+fmapWithPos :: (Measured v1 a1, Measured v2 a2) =>+ (v1 -> a1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2+fmapWithPos f = mapWPTree f mempty++mapWPTree :: (Measured v1 a1, Measured v2 a2) =>+ (v1 -> a1 -> a2) -> v1 -> FingerTree v1 a1 -> FingerTree v2 a2+mapWPTree _ _ Empty = Empty+mapWPTree f v (Single x) = Single (f v x)+mapWPTree f v (Deep _ pr m sf) =+ deep (mapWPDigit f v pr)+ (mapWPTree (mapWPNode f) vpr m)+ (mapWPDigit f vm sf)+ where+ vpr = v `mappend` measure pr+ vm = vpr `mappendVal` m++mapWPNode :: (Measured v1 a1, Measured v2 a2) =>+ (v1 -> a1 -> a2) -> v1 -> Node v1 a1 -> Node v2 a2+mapWPNode f v (Node2 _ a b) = node2 (f v a) (f va b)+ where+ va = v `mappend` measure a+mapWPNode f v (Node3 _ a b c) = node3 (f v a) (f va b) (f vab c)+ where+ va = v `mappend` measure a+ vab = va `mappend` measure b++mapWPDigit :: (Measured v a) => (v -> a -> b) -> v -> Digit a -> Digit b+mapWPDigit f v (One a) = One (f v a)+mapWPDigit f v (Two a b) = Two (f v a) (f va b)+ where+ va = v `mappend` measure a+mapWPDigit f v (Three a b c) = Three (f v a) (f va b) (f vab c)+ where+ va = v `mappend` measure a+ vab = va `mappend` measure b+mapWPDigit f v (Four a b c d) = Four (f v a) (f va b) (f vab c) (f vabc d)+ where+ va = v `mappend` measure a+ vab = va `mappend` measure b+ vabc = vab `mappend` measure c++-- | Like 'fmap', but safe only if the function preserves the measure.+unsafeFmap :: (a -> b) -> FingerTree v a -> FingerTree v b+unsafeFmap _ Empty = Empty+unsafeFmap f (Single x) = Single (f x)+unsafeFmap f (Deep v pr m sf) =+ Deep v (mapDigit f pr) (unsafeFmap (unsafeFmapNode f) m) (mapDigit f sf)++unsafeFmapNode :: (a -> b) -> Node v a -> Node v b+unsafeFmapNode f (Node2 v a b) = Node2 v (f a) (f b)+unsafeFmapNode f (Node3 v a b c) = Node3 v (f a) (f b) (f c)++-- | Like 'traverse', but with a more constrained type.+traverse' :: (Measured v1 a1, Measured v2 a2, Applicative f) =>+ (a1 -> f a2) -> FingerTree v1 a1 -> f (FingerTree v2 a2)+traverse' = traverseTree++traverseTree :: (Measured v2 a2, Applicative f) =>+ (a1 -> f a2) -> FingerTree v1 a1 -> f (FingerTree v2 a2)+traverseTree _ Empty = pure Empty+traverseTree f (Single x) = Single <$> f x+traverseTree f (Deep _ pr m sf) =+ deep <$> traverseDigit f pr <*> traverseTree (traverseNode f) m <*> traverseDigit f sf++traverseNode :: (Measured v2 a2, Applicative f) =>+ (a1 -> f a2) -> Node v1 a1 -> f (Node v2 a2)+traverseNode f (Node2 _ a b) = node2 <$> f a <*> f b+traverseNode f (Node3 _ a b c) = node3 <$> f a <*> f b <*> f c++traverseDigit :: (Applicative f) => (a -> f b) -> Digit a -> f (Digit b)+traverseDigit f (One a) = One <$> f a+traverseDigit f (Two a b) = Two <$> f a <*> f b+traverseDigit f (Three a b c) = Three <$> f a <*> f b <*> f c+traverseDigit f (Four a b c d) = Four <$> f a <*> f b <*> f c <*> f d++-- | Traverse the tree with a function that also takes the+-- measure of the prefix of the tree to the left of the element.+traverseWithPos :: (Measured v1 a1, Measured v2 a2, Applicative f) =>+ (v1 -> a1 -> f a2) -> FingerTree v1 a1 -> f (FingerTree v2 a2)+traverseWithPos f = traverseWPTree f mempty++traverseWPTree :: (Measured v1 a1, Measured v2 a2, Applicative f) =>+ (v1 -> a1 -> f a2) -> v1 -> FingerTree v1 a1 -> f (FingerTree v2 a2)+traverseWPTree _ _ Empty = pure Empty+traverseWPTree f v (Single x) = Single <$> f v x+traverseWPTree f v (Deep _ pr m sf) =+ deep <$> traverseWPDigit f v pr <*> traverseWPTree (traverseWPNode f) vpr m <*> traverseWPDigit f vm sf+ where+ vpr = v `mappend` measure pr+ vm = vpr `mappendVal` m++traverseWPNode :: (Measured v1 a1, Measured v2 a2, Applicative f) =>+ (v1 -> a1 -> f a2) -> v1 -> Node v1 a1 -> f (Node v2 a2)+traverseWPNode f v (Node2 _ a b) = node2 <$> f v a <*> f va b+ where+ va = v `mappend` measure a+traverseWPNode f v (Node3 _ a b c) = node3 <$> f v a <*> f va b <*> f vab c+ where+ va = v `mappend` measure a+ vab = va `mappend` measure b++traverseWPDigit :: (Measured v a, Applicative f) =>+ (v -> a -> f b) -> v -> Digit a -> f (Digit b)+traverseWPDigit f v (One a) = One <$> f v a+traverseWPDigit f v (Two a b) = Two <$> f v a <*> f va b+ where+ va = v `mappend` measure a+traverseWPDigit f v (Three a b c) = Three <$> f v a <*> f va b <*> f vab c+ where+ va = v `mappend` measure a+ vab = va `mappend` measure b+traverseWPDigit f v (Four a b c d) = Four <$> f v a <*> f va b <*> f vab c <*> f vabc d+ where+ va = v `mappend` measure a+ vab = va `mappend` measure b+ vabc = vab `mappend` measure c++-- | Like 'traverse', but safe only if the function preserves the measure.+unsafeTraverse :: (Applicative f) =>+ (a -> f b) -> FingerTree v a -> f (FingerTree v b)+unsafeTraverse _ Empty = pure Empty+unsafeTraverse f (Single x) = Single <$> f x+unsafeTraverse f (Deep v pr m sf) =+ Deep v <$> traverseDigit f pr <*> unsafeTraverse (unsafeTraverseNode f) m <*> traverseDigit f sf++unsafeTraverseNode :: (Applicative f) =>+ (a -> f b) -> Node v a -> f (Node v b)+unsafeTraverseNode f (Node2 v a b) = Node2 v <$> f a <*> f b+unsafeTraverseNode f (Node3 v a b c) = Node3 v <$> f a <*> f b <*> f c++-----------------------------------------------------+-- 4.3 Construction, deconstruction and concatenation+-----------------------------------------------------++-- | /O(1)/. The empty sequence.+empty :: Measured v a => FingerTree v a+empty = Empty++-- | /O(1)/. A singleton sequence.+singleton :: Measured v a => a -> FingerTree v a+singleton = Single++-- | /O(n)/. Create a sequence from a finite list of elements.+fromList :: (Measured v a) => [a] -> FingerTree v a+fromList = foldr' (<|) Empty++-- | /O(1)/. Add an element to the left end of a sequence.+-- Mnemonic: a triangle with the single element at the pointy end.+(<|) :: (Measured v a) => a -> FingerTree v a -> FingerTree v a+a <| Empty = Single a+a <| Single b = deep (One a) Empty (One b)+a <| Deep v (Four b c d e) m sf = m `seq`+ Deep (measure a `mappend` v) (Two a b) (node3 c d e <| m) sf+a <| Deep v pr m sf =+ Deep (measure a `mappend` v) (consDigit a pr) m sf++consDigit :: a -> Digit a -> Digit a+consDigit a (One b) = Two a b+consDigit a (Two b c) = Three a b c+consDigit a (Three b c d) = Four a b c d+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 :: (Measured v a) => FingerTree v a -> Bool+null Empty = True+null _ = False++-- | /O(1)/. Analyse the left end of a sequence.+viewl :: (Measured v a) => FingerTree v a -> ViewL (FingerTree v) a+viewl Empty = EmptyL+viewl (Single x) = x :< Empty+viewl (Deep _ (One x) m sf) = x :< rotL m sf+viewl (Deep _ pr m sf) = lheadDigit pr :< deep (ltailDigit pr) m sf++rotL :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> FingerTree v a+rotL m sf = case viewl m of+ EmptyL -> digitToTree sf+ a :< m' -> Deep (measure m `mappend` measure sf) (nodeToDigit a) m' sf++lheadDigit :: Digit a -> a+lheadDigit (One a) = a+lheadDigit (Two a _) = a+lheadDigit (Three a _ _) = a+lheadDigit (Four a _ _ _) = a++ltailDigit :: Digit a -> Digit a+ltailDigit (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 `mappendVal` m) pr m' (nodeToDigit a)++rheadDigit :: Digit a -> a+rheadDigit (One a) = a+rheadDigit (Two _ b) = b+rheadDigit (Three _ _ c) = c+rheadDigit (Four _ _ _ d) = d++rtailDigit :: Digit a -> Digit a+rtailDigit (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+----------------++-- | /O(log(min(i,n-i)))/. Split a sequence at a point where the predicate+-- on the accumulated measure changes from 'False' to 'True'.+--+-- For predictable results, one should ensure that there is only one such+-- point, i.e. that the predicate is /monotonic/.+split :: (Measured v a) =>+ (v -> Bool) -> FingerTree v a -> (FingerTree v a, FingerTree v a)+split _ 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 = let Split l x r = splitDigit p i pr+ in Split (maybe Empty digitToTree l) x (deepL r m sf)+ | p vm = let Split ml xs mr = splitTree p vpr m+ Split l x r = splitNode p (vpr `mappendVal` ml) xs+ in Split (deepR pr ml l) x (deepL r mr sf)+ | otherwise = let Split l x r = splitDigit p vm sf+ in Split (deepR pr m l) x (maybe Empty digitToTree r)+ where+ vpr = i `mappend` measure pr+ vm = vpr `mappendVal` m++-- Avoid relying on right identity (cf Exercise 7)+mappendVal :: (Measured v a) => v -> FingerTree v a -> v+mappendVal v Empty = v+mappendVal v t = v `mappend` measure t++deepL :: (Measured v a) =>+ Maybe (Digit a) -> FingerTree v (Node v a) -> Digit a -> FingerTree v a+deepL Nothing m sf = rotL m sf+deepL (Just pr) m sf = deep pr m sf++deepR :: (Measured v a) =>+ Digit a -> FingerTree v (Node v a) -> Maybe (Digit a) -> FingerTree v a+deepR pr m Nothing = rotR pr m+deepR pr m (Just sf) = deep pr m sf++splitNode :: (Measured v a) => (v -> Bool) -> v -> Node v a ->+ Split (Maybe (Digit a)) a+splitNode p i (Node2 _ a b)+ | p va = Split Nothing a (Just (One b))+ | otherwise = Split (Just (One a)) b Nothing+ where+ va = i `mappend` measure a+splitNode p i (Node3 _ a b c)+ | p va = Split Nothing a (Just (Two b c))+ | p vab = Split (Just (One a)) b (Just (One c))+ | otherwise = Split (Just (Two a b)) c Nothing+ where+ va = i `mappend` measure a+ vab = va `mappend` measure b++splitDigit :: (Measured v a) => (v -> Bool) -> v -> Digit a ->+ Split (Maybe (Digit a)) a+splitDigit _ 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"++maybeHead :: Measured v a => FingerTree v a -> Maybe a+maybeHead zs = case viewl zs of+ EmptyL -> Nothing+ n :< _ -> Just n++maybeLast :: Measured v a => FingerTree v a -> Maybe a+maybeLast zs = case viewr zs of+ EmptyR -> Nothing+ _ :> n -> Just n++{- $example++Particular abstract data types may be implemented by defining+element types with suitable 'Measured' instances.++(from section 4.5 of the paper)+Simple sequences can be implemented using a 'Sum' monoid as a measure:++> 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".++-}
+ src/HaskellWorks/Data/IntervalMap/Strict.hs view
@@ -0,0 +1,216 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE MultiParamTypeClasses #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif+#if __GLASGOW_HASKELL__ >= 710+{-# LANGUAGE AutoDeriveTypeable #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module : Data.IntervalMap.Strict+-- Copyright : (c) Arbor Networks 2017+-- License : BSD-style+-- Maintainer : mayhem@arbor.net+-- 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.+-- <http://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 map. 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 HaskellWorks.Data.IntervalMap.Strict (+ -- * Intervals+ Interval(..), point,+ -- * Interval maps+ IntervalMap(..), empty, singleton, insert, union,+ -- * Searching+ search, intersections, dominators+ ) where++import HaskellWorks.Data.FingerTree.Strict (FingerTree, Measured (..), ViewL (..), (<|), (><))+import qualified HaskellWorks.Data.FingerTree.Strict as FT++import Control.Applicative ((<$>))+import Data.Foldable (Foldable (foldMap))+import Data.Monoid+import Data.Traversable (Traversable (traverse))++----------------------------------+-- 4.8 Application: interval trees+----------------------------------++-- | A closed interval. The lower bound should be less than or equal+-- to the higher bound.+data Interval v = Interval { low :: !v, high :: !v }+ deriving (Eq, Ord, Show)++-- | 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++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++instance Ord v => Monoid (IntInterval v) where+ mempty = NoInterval+ NoInterval `mappend` i = i+ i `mappend` NoInterval = i+ IntInterval _ hi1 `mappend` IntInterval int2 hi2 =+ IntInterval int2 (max hi1 hi2)++instance (Ord v) => Measured (IntInterval v) (Node v a) where+ measure (Node i _) = IntInterval i (high i)++-- | Map of closed intervals, possibly with duplicates.+-- The 'Foldable' and 'Traversable' instances process the intervals in+-- lexicographical order.+newtype IntervalMap v a =+ IntervalMap (FingerTree (IntInterval v) (Node v a))+-- ordered lexicographically by interval++instance Functor (IntervalMap v) where+ fmap f (IntervalMap t) = IntervalMap (FT.unsafeFmap (fmap f) t)++instance Foldable (IntervalMap v) where+ foldMap f (IntervalMap t) = foldMap (foldMap f) t++instance Traversable (IntervalMap v) where+ traverse f (IntervalMap t) =+ IntervalMap <$> FT.unsafeTraverse (traverse f) t++-- | 'empty' and 'union'.+instance (Ord v) => Monoid (IntervalMap v a) where+ mempty = empty+ mappend = union++-- | /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 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'++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")]+-}
+ src/HaskellWorks/Data/Item/Strict.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module HaskellWorks.Data.Item.Strict where++import HaskellWorks.Data.FingerTree.Strict++data Item k a = Item !k !a deriving (Eq, Show)++instance Functor (Item k) where+ fmap f (Item i t) = Item i (f t)++instance Foldable (Item k) where+ foldMap f (Item _ x) = f x++instance Traversable (Item k) where+ traverse f (Item i x) = Item i <$> f x++instance (Monoid k) => Measured k (Item k a) where+ measure (Item k _) = k
+ src/HaskellWorks/Data/PriorityQueue/Strict.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiParamTypeClasses #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif+#if __GLASGOW_HASKELL__ >= 710+{-# 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.+-- <http://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.+-- 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 HaskellWorks.Data.PriorityQueue.Strict (+ PQueue,+ -- * Construction+ empty,+ singleton,+ union,+ insert,+ add,+ fromList,+ -- * Deconstruction+ null,+ minView,+ minViewWithKey+ ) where++import HaskellWorks.Data.FingerTree.Strict (FingerTree, Measured (..), ViewL (..), (<|), (><), (|>))+import qualified HaskellWorks.Data.FingerTree.Strict as FT++import Control.Arrow ((***))+import Data.Foldable (Foldable (foldMap))+import Data.Monoid+import Prelude hiding (null)++data Entry k v = Entry k v++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++instance Ord k => Monoid (Prio k v) where+ mempty = NoPrio+ x `mappend` NoPrio = x+ NoPrio `mappend` y = y+ x@(Prio kx _) `mappend` y@(Prio ky _)+ | kx <= ky = x+ | otherwise = y++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))++instance Ord k => Functor (PQueue k) where+ fmap f (PQueue xs) = PQueue (FT.fmap' (fmap f) xs)++instance Ord k => Foldable (PQueue k) where+ foldMap f q = case minView q of+ Nothing -> mempty+ Just (v, q') -> f v `mappend` foldMap f q'++instance Ord k => Monoid (PQueue k v) where+ mempty = empty+ mappend = union++-- | /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(log n)/. 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
+ src/HaskellWorks/Data/Segment/Strict.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module HaskellWorks.Data.Segment.Strict where++import HaskellWorks.Data.FingerTree.Strict++-- | A closed segment. The lower bound should be less than or equal+-- to the higher bound.+data Segment k = Segment { low :: !k, high :: !k }+ deriving (Eq, Ord, Show)++-- | A segment in which the lower and upper bounds are equal.+point :: k -> Segment k+point k = Segment k k++instance (Monoid k) => Measured k (Segment k) where+ measure = low
+ src/HaskellWorks/Data/SegmentMap/Strict.hs view
@@ -0,0 +1,202 @@+-- {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+#if __GLASGOW_HASKELL__ >= 702+-- {-# LANGUAGE Safe #-}+#endif+#if __GLASGOW_HASKELL__ >= 710+{-# LANGUAGE AutoDeriveTypeable #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module : Data.SegmentMap.Strict+-- Copyright : (c) Arbor Networks 2017+-- License : BSD-style+-- Maintainer : mayhem@arbor.net+-- Stability : experimental+-- Portability : non-portable (MPTCs and functional dependencies)+--+-- Segment 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 Programmaxg/ 16:2 (2006) pp 197-217.+-- <http://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 map. 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 HaskellWorks.Data.SegmentMap.Strict+ ( -- * Segments+ Segment(..), point,+ -- * Segment maps+ SegmentMap(..),+ OrderedMap(..),+ delete,+ empty,+ fromList,+ insert,+ singleton,+ update,+ segmentMapToList,++ Item(..),+ cappedL,+ cappedM+ ) where++import HaskellWorks.Data.FingerTree.Strict (FingerTree, ViewL (..), ViewR (..), viewl, viewr, (<|), (><))+import HaskellWorks.Data.Item.Strict+import HaskellWorks.Data.Segment.Strict++import qualified HaskellWorks.Data.FingerTree.Strict as FT++import Control.Applicative ((<$>))+import Data.Foldable (Foldable (foldMap), foldl', toList)+import Data.Semigroup+import Data.Traversable (Traversable (traverse))++infixr 5 >*<++----------------------------------+-- 4.8 Application: segment trees+----------------------------------++-- | Map of closed segments, possibly with duplicates.+-- The 'Foldable' and 'Traversable' instances process the segments in+-- lexicographical order.++newtype OrderedMap k a = OrderedMap (FingerTree k (Item k a)) deriving Show++newtype SegmentMap k a = SegmentMap (OrderedMap (Max k) (Segment k, a)) deriving Show++-- ordered lexicographically by segment start++instance Functor (OrderedMap k) where+ fmap f (OrderedMap t) = OrderedMap (FT.unsafeFmap (fmap f) t)++instance Foldable (OrderedMap k) where+ foldMap f (OrderedMap t) = foldMap (foldMap f) t++instance Traversable (OrderedMap k) where+ traverse f (OrderedMap t) = OrderedMap <$> FT.unsafeTraverse (traverse f) t++instance Functor (SegmentMap k) where+ fmap f (SegmentMap t) = SegmentMap (fmap (fmap f) t)++-- instance Foldable (SegmentMap k) where+-- foldMap f (SegmentMap t) = foldMap (foldMap f) t++segmentMapToList :: SegmentMap k a -> [(Segment k, a)]+segmentMapToList (SegmentMap m) = toList m++-- instance Traversable (SegmentMap k) where+-- traverse f (SegmentMap t) =+-- SegmentMap <$> FT.unsafeTraverse (traverse f) t++-- | /O(1)/. The empty segment map.+empty :: (Ord k, Bounded k) => SegmentMap k a+empty = SegmentMap (OrderedMap FT.empty)++-- | /O(1)/. Segment map with a single entry.+singleton :: (Bounded k, Ord k) => Segment k -> a -> SegmentMap k a+singleton s@(Segment lo hi) a = SegmentMap $ OrderedMap $ FT.singleton $ Item (Max lo) (s, a)++delete :: forall k a. (Bounded k, Ord k, Enum k, Eq a, Show k, Show a)+ => Segment k+ -> SegmentMap k a+ -> SegmentMap k a+delete = flip update Nothing++insert :: forall k a. (Bounded k, Ord k, Enum k, Eq a, Show k, Show a)+ => Segment k+ -> a+ -> SegmentMap k a+ -> SegmentMap k a+insert s a = update s (Just a)++(>*<) :: (Ord k, Enum k, Bounded k, Eq a)+ => FingerTree (Max k) (Item (Max k) (Segment k, a))+ -> FingerTree (Max k) (Item (Max k) (Segment k, a))+ -> FingerTree (Max k) (Item (Max k) (Segment k, a))+(>*<) lt rt = case viewr lt of+ EmptyR -> rt+ treeL :> Item _ (Segment loL hiL, itemL) -> case viewl rt of+ EmptyL -> lt+ Item _ (Segment loR hiR, itemR) :< treeR ->+ if succ hiL >= loR && itemL == itemR+ then treeL >< FT.singleton (Item (Max loL) (Segment loL hiR, itemL)) >< treeR+ else lt >< rt++update :: forall k a. (Ord k, Enum k, Bounded k, Eq a, Show k, Show a)+ => Segment k+ -> Maybe a+ -> SegmentMap k a+ -> SegmentMap k a+update (Segment lo hi) _ m | lo > hi = m+update _ Nothing m = m+update s@(Segment lo hi) (Just x) (SegmentMap (OrderedMap t)) =+ SegmentMap $ OrderedMap (at >*< bbbb >*< cccc)+ where+ (fstPivotLt, fstPivotRt) = FT.split (>= Max lo) t+ (at, atSurplus) = cappedL lo fstPivotLt+ (zs, remainder) = FT.split (> Max hi) (atSurplus >*< fstPivotRt)+ e = maybe FT.Empty FT.singleton (FT.maybeLast zs >>= capM hi)+ rt = e >*< remainder+ bbbb = FT.singleton (Item (Max lo) (s, x))+ cccc = cappedM hi rt++cappedL :: (Enum k, Ord k, Bounded k, Show k)+ => k+ -> FingerTree (Max k) (Item (Max k) (Segment k, a))+ -> (FingerTree (Max k) (Item (Max k) (Segment k, a)), FingerTree (Max k) (Item (Max k) (Segment k, a)))+cappedL lo t = case viewr t of+ EmptyR -> (FT.empty, FT.empty)+ ltp :> item -> resolve ltp item+ where resolve ltp (Item _ (Segment lilo lihi, a))+ | lo <= lilo = (ltp , FT.empty)+ | lo < lihi = (ltp >< lPart, rPart )+ | lo <= lihi = (ltp >< lPart, FT.empty)+ | otherwise = (t , FT.empty)+ where lPart = FT.singleton (Item (Max lilo) (Segment lilo (pred lo), a))+ rPart = FT.singleton (Item (Max lo ) (Segment lo lihi , a))++cappedM :: (Enum k, Ord k, Bounded k, Show k, Show a)+ => k+ -> FingerTree (Max k) (Item (Max k) (Segment k, a))+ -> FingerTree (Max k) (Item (Max k) (Segment k, a))+cappedM hi t = case viewl t of+ EmptyL -> t+ n :< rtp -> maybe rtp (<| rtp) (capM hi n)++capM :: (Ord k, Enum k, Show k, Show a)+ => k+ -> Item (Max k) (Segment k, a)+ -> Maybe (Item (Max k) (Segment k, a))+capM lihi n@(Item _ (Segment rilo rihi, a))+ -- let !_ = trace ("lihi: " <> show lihi) lihi in+ -- let !_ = trace ("rilo: " <> show rilo) rilo in+ -- let !_ = trace ("rihi: " <> show rihi) rihi in+ -- let result = case () of+ | lihi < rilo = Just n+ | lihi < rihi = Just $ Item (Max (succ lihi)) (Segment (succ lihi) rihi, a)+ | otherwise = Nothing+ -- in+ -- let !_ = trace ("result: " <> show result) result in+ -- result++fromList :: (Ord v, Enum v, Eq a, Bounded v, Show v, Show a)+ => [(Segment v, a)]+ -> SegmentMap v a+fromList = foldl' (flip (uncurry insert)) empty
+ src/HaskellWorks/Data/SegmentSet/Strict.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+#if __GLASGOW_HASKELL__ >= 702+-- {-# LANGUAGE Safe #-}+#endif+#if __GLASGOW_HASKELL__ >= 710+{-# LANGUAGE AutoDeriveTypeable #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module : Data.SegmentSet.Strict+-- Copyright : (c) Arbor Networks 2017+-- License : BSD-style+-- Maintainer : mayhem@arbor.net+-- Stability : experimental+-- Portability : non-portable (MPTCs and functional dependencies)+--+-- SegmentSet provides an efficient implementation of a set of segments (a.k.a+-- intervals). Segments in the set are non-overlapping. Adjacent segments+-- are merged (i.e. (a .. b), (b + 1 .. c) -> (a .. c)).+--+-- Segment sets are 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 Programmaxg/ 16:2 (2006) pp 197-217.+-- <http://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 set. 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 HaskellWorks.Data.SegmentSet.Strict+ ( -- * Segments+ Segment(..), point,+ -- * Segment maps+ SegmentSet(..),+ OrderedMap(..),+ delete,+ empty,+ fromList,+ insert,+ singleton,+ update,+ segmentSetToList,++ Item(..),+ cappedL,+ cappedM+ ) where++import HaskellWorks.Data.FingerTree.Strict (FingerTree, Measured (..), ViewL (..), ViewR (..), viewl, viewr, (<|), (><))+import HaskellWorks.Data.Item.Strict+import HaskellWorks.Data.Segment.Strict++import qualified HaskellWorks.Data.FingerTree.Strict as FT++import Control.Applicative ((<$>))+import Data.Foldable (Foldable (foldMap), foldl', toList)+import Data.Semigroup+import Data.Traversable (Traversable (traverse))++{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}++infixr 5 >*<++----------------------------------+-- 4.8 Application: segment trees+----------------------------------++-- | Map of closed segments, possibly with duplicates.+-- The 'Foldable' and 'Traversable' instances process the segments in+-- lexicographical order.++newtype OrderedMap k a = OrderedMap (FingerTree k (Item k a)) deriving Show++newtype SegmentSet k = SegmentSet (OrderedMap (Max k) (Segment k)) deriving Show++-- ordered lexicographically by segment start++instance Functor (OrderedMap k) where+ fmap f (OrderedMap t) = OrderedMap (FT.unsafeFmap (fmap f) t)++instance Foldable (OrderedMap k) where+ foldMap f (OrderedMap t) = foldMap (foldMap f) t++instance Traversable (OrderedMap k) where+ traverse f (OrderedMap t) = OrderedMap <$> FT.unsafeTraverse (traverse f) t++-- instance Foldable (SegmentSet k) where+-- foldMap f (SegmentSet t) = foldMap (foldMap f) t++segmentSetToList :: SegmentSet k -> [Segment k]+segmentSetToList (SegmentSet m) = toList m++-- instance Traversable (SegmentSet k) where+-- traverse f (SegmentSet t) =+-- SegmentSet <$> FT.unsafeTraverse (traverse f) t++-- | /O(1)/. The empty segment set.+empty :: (Ord k, Bounded k) => SegmentSet k+empty = SegmentSet (OrderedMap FT.empty)++-- | /O(1)/. Segment set with a single entry.+singleton :: (Bounded k, Ord k) => Segment k -> SegmentSet k+singleton s@(Segment lo hi) = SegmentSet $ OrderedMap $ FT.singleton $ Item (Max lo) s++-- | /O(log(n))/. Remove a segment from the set.+-- Alias of update.+delete :: forall k a. (Bounded k, Ord k, Enum k, Show k)+ => Segment k+ -> SegmentSet k+ -> SegmentSet k+delete = flip update False++-- | /O(log(n))/. Insert a segment into the set.+-- Alias of update.+insert :: forall k a. (Bounded k, Ord k, Enum k, Show k)+ => Segment k+ -> SegmentSet k+ -> SegmentSet k+insert = flip update True++-- | Update a segment set. Prefer `insert` or `delete` in most cases.+update :: forall k a. (Ord k, Enum k, Bounded k, Show k)+ => Segment k+ -> Bool+ -> SegmentSet k+ -> SegmentSet k+update (Segment lo hi) _ m | lo > hi = m+update s@(Segment lo hi) b (SegmentSet (OrderedMap t)) =+ SegmentSet $ OrderedMap contents+ where+ contents = if b then at >*< bbbb >*< cccc else at >*< cccc+ (fstPivotLt, fstPivotRt) = FT.split (>= Max lo) t+ (at, atSurplus) = cappedL lo fstPivotLt+ (zs, remainder) = FT.split (> Max hi) (atSurplus >*< fstPivotRt)+ e = maybe FT.Empty FT.singleton (FT.maybeLast zs >>= capM hi)+ rt = e >< remainder+ cccc = cappedM hi rt+ bbbb = FT.singleton (Item (Max lo) s)++cappedL :: (Enum k, Ord k, Bounded k, Show k)+ => k+ -> FingerTree (Max k) (Item (Max k) (Segment k))+ -> (FingerTree (Max k) (Item (Max k) (Segment k)), FingerTree (Max k) (Item (Max k) (Segment k)))+cappedL lo t = case viewr t of+ EmptyR -> (FT.empty, FT.empty)+ ltp :> item -> resolve ltp item+ where resolve ltp (Item _ (Segment lilo lihi))+ | lo <= lilo = (ltp , FT.empty)+ | lo < lihi = (ltp >< lPart, rPart )+ | lo <= lihi = (ltp >< lPart, FT.empty)+ | otherwise = (t , FT.empty)+ where lPart = FT.singleton (Item (Max lilo) (Segment lilo (pred lo)))+ rPart = FT.singleton (Item (Max lo ) (Segment lo lihi ))++cappedM :: (Enum k, Ord k, Bounded k, Show k)+ => k+ -> FingerTree (Max k) (Item (Max k) (Segment k))+ -> FingerTree (Max k) (Item (Max k) (Segment k))+cappedM hi t = case viewl t of+ EmptyL -> t+ n :< rtp -> maybe rtp (<| rtp) (capM hi n)++capM :: (Ord k, Enum k, Show k)+ => k+ -> Item (Max k) (Segment k)+ -> Maybe (Item (Max k) (Segment k))+capM lihi n@(Item _ (Segment rilo rihi))+ | lihi < rilo = Just n+ | lihi < rihi = Just $ Item (Max (succ lihi)) (Segment (succ lihi) rihi)+ | otherwise = Nothing++fromList :: (Ord v, Enum v, Bounded v, Show v)+ => [Segment v]+ -> SegmentSet v+fromList = foldl' (flip insert) empty++--------------------------------------------------------------------------------+-- Private functions+--------------------------------------------------------------------------------++-- | /O(log(n))/. Merge two segment sets.+-- Private (bare) function to merge two segment sets.+-- Requires two guarantees from the caller:+-- 1) That the sets are non-overlapping, and+-- 2) That the left tree is "less" than the right tree. i.e. that the maximum+-- high in the left tree is less than the minimum low in the right tree.+-- If the two middle-most segments are adjacent:+-- (max (hi left) == succ (min (low right))+-- then those two segments will be merged.+merge :: (Ord k, Enum k, Bounded k)+ => FingerTree (Max k) (Item (Max k) (Segment k))+ -> FingerTree (Max k) (Item (Max k) (Segment k))+ -> FingerTree (Max k) (Item (Max k) (Segment k))+merge lt rt = case viewr lt of+ EmptyR -> rt+ treeL :> Item _ (Segment loL hiL) -> case viewl rt of+ EmptyL -> lt+ Item _ (Segment loR hiR) :< treeR ->+ if succ hiL >= loR+ then treeL >< FT.singleton (Item (Max loL) (Segment loL hiR)) >< treeR+ else lt >< rt++-- | Operator version of merge.+(>*<) :: (Ord k, Enum k, Bounded k)+ => FingerTree (Max k) (Item (Max k) (Segment k))+ -> FingerTree (Max k) (Item (Max k) (Segment k))+ -> FingerTree (Max k) (Item (Max k) (Segment k))+(>*<) = merge
+ test/HaskellWorks/Data/Gen.hs view
@@ -0,0 +1,41 @@+module HaskellWorks.Data.Gen+ ( genSegments+ , genIntSegment+ , genOrderedIntSegments+ ) where++import Data.List+import HaskellWorks.Data.Segment.Strict+import Hedgehog (MonadGen)++import qualified Hedgehog.Gen as G+import qualified Hedgehog.Range as R++pairs :: [a] -> [(a, a)]+pairs (a:b:rs) = (a, b):pairs rs+pairs _ = []++unsafeNub :: Eq a => [a] -> [a]+unsafeNub (a:b:bs) = if a == b then a:bs else a:unsafeNub (b:bs)+unsafeNub (a:as) = a:as+unsafeNub [] = []++genSegment :: MonadGen m => m (Segment Int)+genSegment = do+ lt <- G.int (R.linear 0 1000)+ rt <- G.int (R.linear lt 1000)+ return $ Segment lt rt++genSegments :: MonadGen m => Int -> Int -> Int -> m [Segment Int]+genSegments len minInt maxInt = G.list (R.linear 0 len) $ genIntSegment minInt maxInt++genIntSegment :: MonadGen m => Int -> Int -> m (Segment Int)+genIntSegment minInt maxInt = do+ a <- G.int (R.linear minInt maxInt)+ b <- G.int (R.linear minInt maxInt)+ return (Segment (a `min` b) (a `max` b))++genOrderedIntSegments :: MonadGen m => Int -> Int -> Int -> m [Segment Int]+genOrderedIntSegments n minInt maxInt = do+ as <- G.list (R.linear 0 (n * 2)) (G.int (R.linear minInt maxInt))+ return $ unsafeNub (uncurry Segment <$> pairs (sort as))
+ test/HaskellWorks/Data/SegmentMap/StrictSpec.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module HaskellWorks.Data.SegmentMap.StrictSpec+ ( spec+ ) where++import Data.Foldable++import Control.Monad.IO.Class+import Data.Semigroup+import HaskellWorks.Data.FingerTree.Strict (ViewL (..), ViewR (..), viewl, viewr, (<|), (><), (|>))+import HaskellWorks.Data.SegmentMap.Strict++import qualified HaskellWorks.Data.FingerTree.Strict as FT+import qualified HaskellWorks.Data.SegmentMap.Strict as S (fromList)+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import HaskellWorks.Hspec.Hedgehog+import Hedgehog+import Test.Hspec++{-# ANN module ("HLint: ignore Redundant do" :: String) #-}++fallbackTo :: Bool+fallbackTo = True++spec :: Spec+spec = describe "HaskellWorks.Data.SegmentMap.StrictSpec" $ do+ it "should convert SegmentMap to List" $ do+ let emptySM :: SegmentMap Int Int = empty+ segmentMapToList emptySM `shouldBe` []++ it "should convert List to SegmentMap" $ do+ let emptySM :: SegmentMap Int Int = empty+ let emptySM2 :: SegmentMap Int Int = S.fromList []+ segmentMapToList emptySM2 `shouldBe` segmentMapToList emptySM++ it "fromList with no overlap works" $ do+ let initial = fromList [(Segment 1 10, "1-10"), (Segment 11 20, "11-20")] :: SegmentMap Int String+ let expected = [(Segment 1 10, "1-10"), (Segment 11 20, "11-20")]+ segmentMapToList initial `shouldBe` expected++ it "insert with overlap works" $ do+ let initial = fromList [(Segment 1 10, "A"), (Segment 21 30, "C")] :: SegmentMap Int String+ let updated = insert (Segment 11 20) "B" initial+ let expected = [(Segment 1 10, "A"), (Segment 11 20, "B"), (Segment 21 30, "C")]+ segmentMapToList updated `shouldBe` expected++ it "insert with overlap works" $ do+ let initial = fromList [(Segment 1 10, "A"), (Segment 11 20, "C")] :: SegmentMap Int String+ let updated = insert (Segment 5 15) "B" initial+ let expected = [(Segment 1 4, "A"), (Segment 5 15, "B"), (Segment 16 20, "C")]+ segmentMapToList updated `shouldBe` expected++ it "fromList of two segments in order possibly overlapping" $ do+ require $ property $ do+ (Segment aLt aRt, Segment bLt bRt) <- forAll $ do+ aLt <- Gen.int (Range.linear 1 100)+ bRt <- Gen.int (Range.linear aLt 100)+ aRt <- Gen.int (Range.linear aLt bRt)+ bLt <- Gen.int (Range.linear aLt bRt)+ return (Segment aLt aRt, Segment bLt bRt)+ let initial = [(Segment aLt aRt, "A"), (Segment bLt bRt, "B")] :: [(Segment Int, String)]+ let actual = segmentMapToList (fromList initial)+ let aRt' = aRt `min` pred bLt+ case () of+ () | aLt == bRt -> actual === [(Segment aLt bRt , "B")]+ () | bLt <= aLt && bRt >= aRt -> actual === [(Segment bLt bRt , "B")]+ () | aRt >= bLt -> actual === [(Segment aLt aRt', "A"), (Segment bLt bRt, "B")]+ () | fallbackTo -> actual === [(Segment aLt aRt , "A"), (Segment bLt bRt, "B")]++ it "fromList [(Segment 1 1, \"A\"), (Segment 1 1, \"B\")]" $ do+ let initial = [(Segment 1 1, "A"), (Segment 1 1, "B")] :: [(Segment Int, String)]+ let actual = segmentMapToList (fromList initial)+ actual `shouldBe` [(Segment 1 1, "B")]++ it "fromList [(Segment 1 2, \"A\"), (Segment 1 1, \"B\")]" $ do+ let initial = [(Segment 1 2, "A"), (Segment 1 1, "B")] :: [(Segment Int, String)]+ let actual = segmentMapToList (fromList initial)+ actual `shouldBe` [(Segment 1 1, "B"), (Segment 2 2, "A")]++ it "fromList [(Segment 1 2, \"A\"), (Segment 2 2, \"B\")]" $ do+ let initial = [(Segment 1 2, "A"), (Segment 2 2, "B")] :: [(Segment Int, String)]+ let actual = segmentMapToList (fromList initial)+ actual `shouldBe` [(Segment 1 1, "A"), (Segment 2 2, "B")]++ it "fromList [(Segment 1 2, \"A\"), (Segment 1 2, \"B\")]" $ do+ let initial = [(Segment 1 2, "A"), (Segment 1 2, "B")] :: [(Segment Int, String)]+ let actual = segmentMapToList (fromList initial)+ actual `shouldBe` [(Segment 1 2, "B")]++ it "fromList [(Segment 1 3, \"A\"), (Segment 1 1, \"B\")]" $ do+ let initial = [(Segment 1 3, "A"), (Segment 1 1, "B")] :: [(Segment Int, String)]+ let actual = segmentMapToList (fromList initial)+ actual `shouldBe` [(Segment 1 1, "B"), (Segment 2 3, "A")]++ it "fromList [(Segment 1 3, \"A\"), (Segment 3 3, \"B\")]" $ do+ let initial = [(Segment 1 3, "A"), (Segment 3 3, "B")] :: [(Segment Int, String)]+ let actual = segmentMapToList (fromList initial)+ actual `shouldBe` [(Segment 1 2, "A"), (Segment 3 3, "B")]++ it "fromList [(Segment 1 3, \"A\"), (Segment 2 2, \"B\")]" $ do+ let initial = [(Segment 1 3, "A"), (Segment 2 2, "B")] :: [(Segment Int, String)]+ let actual = segmentMapToList (fromList initial)+ actual `shouldBe` [(Segment 1 1, "A"), (Segment 2 2, "B"), (Segment 3 3, "A")]++ it "fromList [(Segment 1 3, \"A\"), (Segment 0 1, \"B\")]" $ do+ let initial = [(Segment 1 3, "A"), (Segment 0 1, "B")] :: [(Segment Int, String)]+ let actual = segmentMapToList (fromList initial)+ actual `shouldBe` [(Segment 0 1, "B"), (Segment 2 3, "A")]++ it "fromList [(Segment 1 3, \"A\"), (Segment 3 4 \"B\")]" $ do+ let initial = [(Segment 1 3, "A"), (Segment 3 4, "B")] :: [(Segment Int, String)]+ let actual = segmentMapToList (fromList initial)+ actual `shouldBe` [(Segment 1 2, "A"), (Segment 3 4, "B")]++ it "fromList [(Segment 1 2, \"A\"), (Segment 2 7, \"B\")]" $ do+ let initial = [(Segment 1 2, "A"), (Segment 2 7, "B")] :: [(Segment Int, String)]+ let actual = segmentMapToList (fromList initial)+ actual `shouldBe` [(Segment 1 1, "A"), (Segment 2 7, "B")]++ describe "cappedL" $ do+ let original = FT.Single (Item (Max (11 :: Int)) (Segment {low = 11 :: Int, high = 20}, "A" :: String))+ it "left of" $ do+ cappedL 5 original `shouldBe` (FT.Empty, FT.Empty)+ it "overlapping" $ do+ cappedL 15 original `shouldBe` (FT.Single (Item (Max (11 :: Int)) (Segment {low = 11 :: Int, high = 14}, "A" :: String)), FT.Single (Item (Max 15) (Segment {low = 15, high = 20}, "A")))+ it "right of" $ do+ cappedL 25 original `shouldBe` (FT.Single (Item (Max (11 :: Int)) (Segment {low = 11 :: Int, high = 20}, "A" :: String)), FT.Empty)+ describe "cappedM" $ do+ let original = FT.Single (Item (Max (21 :: Int)) (Segment {low = 21 :: Int, high = 30}, "C" :: String))+ it "left of" $ do+ cappedM 15 original `shouldBe` FT.Single (Item (Max (21 :: Int)) (Segment {low = 21 :: Int, high = 30}, "C" :: String))+ it "overlapping" $ do+ cappedM 25 original `shouldBe` FT.Single (Item (Max (26 :: Int)) (Segment {low = 26 :: Int, high = 30}, "C" :: String))+ it "left of" $ do+ cappedM 35 original `shouldBe` FT.Empty++ it "should have require function that checks hedgehog properties" $ do+ require $ property $ do+ x <- forAll (Gen.int Range.constantBounded)+ x === x
+ test/HaskellWorks/Data/SegmentSet/Naive.hs view
@@ -0,0 +1,68 @@+module HaskellWorks.Data.SegmentSet.Naive+ ( empty+ , fromList+ , remove+ , toList+ , update+ , Segment(..)+ , SegmentSet(..)+ ) where++import Data.Foldable hiding (toList)+import Data.Maybe+import Debug.Trace++import HaskellWorks.Data.Segment.Strict++newtype SegmentSet a = SegmentSet [Segment a] deriving (Show, Eq)++empty :: SegmentSet a+empty = SegmentSet []++fromList :: (Ord a, Enum a) => [Segment a] -> SegmentSet a+fromList = foldr' update empty++toList :: SegmentSet a -> [Segment a]+toList (SegmentSet as) = as++update :: (Ord a, Enum a) => Segment a -> SegmentSet a -> SegmentSet a+update i (SegmentSet as) =+ let (ls, b1, b2, rs) = splitSegment i as+ i' = merge b1 i b2+ in SegmentSet $ ls ++ (i':rs)++remove :: (Ord a, Enum a) => Segment a -> SegmentSet a -> SegmentSet a+remove i (SegmentSet as) =+ let (ls, b1, b2, rs) = splitSegment i as+ b1s = maybe [] (minus i) b1+ b2s = maybe [] (minus i) b2+ in SegmentSet $ ls ++ b1s ++ b2s ++ rs++splitSegment :: (Ord a, Enum a) => Segment a -> [Segment a] -> ([Segment a], Maybe (Segment a), Maybe (Segment a), [Segment a])+splitSegment (Segment s e) as = (ls, b1, b2, rs)+ where (ls, xs ) = break (\(Segment x y) -> x >= s || y >= s) as+ (b1, xs') = unconsMergeable (Segment s e) xs+ (_ , rs') = break (\(Segment x y) -> x >= e || y >= e) xs'+ (b2, rs ) = unconsMergeable (Segment s e) rs'+ unconsMergeable ip ips = case uncons' ips of+ (Just b', rs'') | overlapsOrAdjacent ip b' -> (Just b', rs'')+ _ -> (Nothing, ips)++overlapsOrAdjacent :: (Ord a, Enum a) => Segment a -> Segment a -> Bool+overlapsOrAdjacent (Segment s1 e1) (Segment s2 e2) = if s1 <= s2 then succ e1 >= s2 else e2 >= s1++minus :: (Ord a, Enum a) => Segment a -> Segment a -> [Segment a]+minus (Segment s e) (Segment fs fe) =+ let as = if s <= fs then Nothing else Just (Segment fs (pred s))+ bs = if e >= fe then Nothing else Just (Segment (succ e) fe )+ in catMaybes [as, bs]++merge :: (Ord a, Enum a) => Maybe (Segment a) -> Segment a -> Maybe (Segment a) -> Segment a+merge (Just (Segment sb1 _ )) (Segment s e) (Just (Segment _ eb2)) = Segment (min sb1 s) (max e eb2)+merge Nothing (Segment s e) (Just (Segment sb2 eb2)) = Segment (min sb2 s) (max e eb2)+merge (Just (Segment sb1 eb2)) (Segment s e) Nothing = Segment (min sb1 s) (max e eb2)+merge _ i _ = i++uncons' :: [a] -> (Maybe a, [a])+uncons' [] = (Nothing, [])+uncons' (a:as) = (Just a , as)
+ test/HaskellWorks/Data/SegmentSet/NaiveSpec.hs view
@@ -0,0 +1,65 @@+module HaskellWorks.Data.SegmentSet.NaiveSpec where++import Data.List+import HaskellWorks.Data.SegmentSet.Naive++import Test.Hspec++{-# ANN module ("HLint: ignore Redundant do" :: String) #-}++rawIps :: [Segment Int]+rawIps = [Segment 12 20, Segment 1 10, Segment 220 300]++ips :: SegmentSet Int+ips = fromList rawIps++spec :: Spec+spec = describe "App.NaiveIntervalSpec" $ do+ it "should preserve empty" $ fromList (toList (empty :: SegmentSet Int)) `shouldBe` empty+ it "should insert one range" $ toList (update (Segment 11 20) empty) `shouldBe` ([Segment 11 20] :: [Segment Int])+ it "should not change if update is inclusive" $ update (Segment 12 18) ips `shouldBe` ips++ it "should join cross ranges" $ do+ toList (update (Segment 15 250) ips) `shouldBe` [Segment 1 10, Segment 12 300]+ toList (update (Segment 5 15) ips) `shouldBe` [Segment 1 20, Segment 220 300]++ it "should keep sorted list (fromList)" $+ toList (fromList (reverse rawIps)) `shouldBe` sortOn low rawIps++ it "should preserve sorting (update)" $+ let addon = Segment 50 70+ in toList (update addon ips) `shouldBe` sortOn low (addon:rawIps)++ it "should preserve sorring (delete)" $+ toList (remove (Segment 12 20) ips) `shouldBe` sortOn low (filter (\x -> low x /= 12) rawIps)++ it "should remove nothing from empty" $ remove (Segment 1 10) empty `shouldBe` (empty :: SegmentSet Int)++ it "should remove exact segment" $+ toList (remove (Segment 12 20) ips) `shouldBe` [Segment 1 10, Segment 220 300]++ it "should remove inner segment" $+ toList (remove (Segment 250 270) ips) `shouldBe`+ [Segment 1 10, Segment 12 20, Segment 220 249, Segment 271 300]++ it "should remove crossing segment" $+ toList (remove (Segment 5 15) ips) `shouldBe`+ [Segment 1 4, Segment 16 20, Segment 220 300]++ it "should remove everything" $+ remove (Segment 0 1000) ips `shouldBe` empty++ it "should remove leftmost" $ do+ toList (remove (Segment 1 10) ips) `shouldBe` [Segment 12 20, Segment 220 300]+ toList (remove (Segment 1 15) ips) `shouldBe` [Segment 16 20, Segment 220 300]+ toList (remove (Segment 0 15) ips) `shouldBe` [Segment 16 20, Segment 220 300]++ it "should remove rightmost" $ do+ toList (remove (Segment 220 300) ips) `shouldBe` [Segment 1 10, Segment 12 20]+ toList (remove (Segment 200 300) ips) `shouldBe` [Segment 1 10, Segment 12 20]+ toList (remove (Segment 18 300) ips) `shouldBe` [Segment 1 10, Segment 12 17]+ toList (remove (Segment 18 400) ips) `shouldBe` [Segment 1 10, Segment 12 17]++ it "should merge adjacent segments" $ do+ let segments = [Segment 1 1, Segment 2 2] :: [Segment Int]+ toList (fromList segments) `shouldBe` [Segment 1 2]
+ test/HaskellWorks/Data/SegmentSet/StrictSpec.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module HaskellWorks.Data.SegmentSet.StrictSpec+ ( spec+ ) where++import Data.Foldable+import Data.List (sortBy)++import Control.Monad.IO.Class+import Data.Semigroup+import HaskellWorks.Data.FingerTree.Strict (ViewL (..), ViewR (..), viewl, viewr, (<|), (><), (|>))+import HaskellWorks.Data.Gen+import HaskellWorks.Data.SegmentSet.Strict++import qualified HaskellWorks.Data.FingerTree.Strict as FT+import qualified HaskellWorks.Data.SegmentSet.Naive as N+import qualified HaskellWorks.Data.SegmentSet.Strict as S (fromList)+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import HaskellWorks.Hspec.Hedgehog+import Hedgehog+import Test.Hspec++{-# ANN module ("HLint: ignore Redundant do" :: String) #-}++fallbackTo :: Bool+fallbackTo = True++spec :: Spec+spec = describe "HaskellWorks.Data.SegmentSet.StrictSpec" $ do+ it "should convert SegmentSet to List" $ do+ let emptySM :: SegmentSet Int = empty+ segmentSetToList emptySM `shouldBe` []++ it "should convert List to SegmentSet" $ do+ let emptySM :: SegmentSet Int = empty+ let emptySM2 :: SegmentSet Int = S.fromList []+ segmentSetToList emptySM2 `shouldBe` segmentSetToList emptySM++ it "fromList with no overlap works" $ do+ let initial = fromList [Segment 1 10, Segment 11 20] :: SegmentSet Int+ let expected = [Segment 1 20]+ segmentSetToList initial `shouldBe` expected++ it "insert with overlap works" $ do+ let initial = fromList [Segment 1 10, Segment 21 30] :: SegmentSet Int+ let updated = insert (Segment 11 20) initial+ let expected = [Segment 1 30]+ segmentSetToList updated `shouldBe` expected++ it "insert with overlap works" $ do+ let initial = fromList [Segment 1 10, Segment 11 20] :: SegmentSet Int+ let updated = insert (Segment 5 15) initial+ let expected = [Segment 1 20]+ segmentSetToList updated `shouldBe` expected++ it "fromList of two segments in order possibly overlapping" $ do+ require $ property $ do+ (Segment aLt aRt, Segment bLt bRt) <- forAll $ do+ aLt <- Gen.int (Range.linear 1 100)+ bRt <- Gen.int (Range.linear aLt 100)+ aRt <- Gen.int (Range.linear aLt bRt)+ bLt <- Gen.int (Range.linear aLt bRt)+ return (Segment aLt aRt, Segment bLt bRt)+ let initial = [Segment aLt aRt, Segment bLt bRt] :: [Segment Int]+ let actual = segmentSetToList (fromList initial)+ let aRt' = aRt `min` pred bLt+ case () of+ () | aLt == bRt -> actual === [Segment aLt bRt]+ () | bLt <= aLt && bRt >= aRt -> actual === [Segment bLt bRt]+ () | succ aRt >= bLt -> actual === [Segment aLt bRt]+ () | fallbackTo -> actual === [Segment aLt aRt , Segment bLt bRt]++ it "toList of n segments should be ordered, non-overlapping" $ do+ require $ property $ do+ segments <- forAll $ genSegments 100 0 1000+ let sSet = fromList segments+ let lst = segmentSetToList sSet+ monotonicSegments lst === True++ it "deleting elements should produce a set with 'holes' in it" $ do+ require $ property $ do+ let (bot, top) = (0, 1000)+ let sSet = singleton $ Segment bot top+ deletions <- forAll $ genSegments 100 bot top+ let deletedSet = segmentSetToList $ foldr delete sSet deletions+ -- This is hacky. We're running the deletions through a Segment Set+ -- to get an ordered, non-overlapping, merged version. This makes it+ -- much easier to check the `inverse` property+ let orderedDeletions = segmentSetToList $ fromList deletions+ -- Check both directions of inversion.+ deletedSet === invert bot top orderedDeletions+ invert bot top deletedSet === orderedDeletions++ it "fromList [Segment 1 1, Segment 1 1]" $ do+ let initial = [Segment 1 1, Segment 1 1] :: [Segment Int]+ let actual = segmentSetToList (fromList initial)+ actual `shouldBe` [Segment 1 1]++ it "fromList [Segment 1 2, Segment 1 1]" $ do+ let initial = [Segment 1 2, Segment 1 1] :: [Segment Int]+ let actual = segmentSetToList (fromList initial)+ actual `shouldBe` [Segment 1 2]++ it "fromList [Segment 1 2, Segment 2 2]" $ do+ let initial = [Segment 1 2, Segment 2 2] :: [Segment Int]+ let actual = segmentSetToList (fromList initial)+ actual `shouldBe` [Segment 1 2]++ it "fromList [Segment 1 2, Segment 1 2]" $ do+ let initial = [Segment 1 2, Segment 1 2] :: [Segment Int]+ let actual = segmentSetToList (fromList initial)+ actual `shouldBe` [Segment 1 2]++ it "fromList [Segment 1 3, Segment 1 1]" $ do+ let initial = [Segment 1 3, Segment 1 1] :: [Segment Int]+ let actual = segmentSetToList (fromList initial)+ actual `shouldBe` [Segment 1 3]++ it "fromList [Segment 1 3, Segment 3 3]" $ do+ let initial = [Segment 1 3, Segment 3 3] :: [Segment Int]+ let actual = segmentSetToList (fromList initial)+ actual `shouldBe` [Segment 1 3]++ it "fromList [Segment 1 3, Segment 2 2]" $ do+ let initial = [Segment 1 3, Segment 2 2] :: [Segment Int]+ let actual = segmentSetToList (fromList initial)+ actual `shouldBe` [Segment 1 3]++ it "fromList [Segment 1 3, Segment 0 1]" $ do+ let initial = [Segment 1 3, Segment 0 1] :: [Segment Int]+ let actual = segmentSetToList (fromList initial)+ actual `shouldBe` [Segment 0 3]++ it "fromList [Segment 1 3, Segment 3 4]" $ do+ let initial = [Segment 1 4] :: [Segment Int]+ let actual = segmentSetToList (fromList initial)+ actual `shouldBe` [Segment 1 4]++ it "fromList [Segment 1 2, Segment 2 7]" $ do+ let initial = [Segment 1 7] :: [Segment Int]+ let actual = segmentSetToList (fromList initial)+ actual `shouldBe` [Segment 1 7]++ it "fromList (delete (Segment 1 1) [Segment 1 1])" $ do+ let initial = [Segment 1 1] :: [Segment Int]+ let actual = segmentSetToList (delete (Segment 1 1) (fromList initial))+ actual `shouldBe` []++ it "fromList (delete (Segment 1 3) [Segment 2 4])" $ do+ let initial = [Segment 2 4] :: [Segment Int]+ let actual = segmentSetToList (delete (Segment 1 3) (fromList initial))+ actual `shouldBe` [Segment 4 4]++ it "fromList (delete (Segment 3 5) [Segment 2 4])" $ do+ let initial = [Segment 2 4] :: [Segment Int]+ let actual = segmentSetToList (delete (Segment 3 5) (fromList initial))+ actual `shouldBe` [Segment 2 2]++ it "fromList (delete (Segment 3 5) [Segment 2 4])" $ do+ let initial = [Segment 2 4] :: [Segment Int]+ let actual = segmentSetToList (delete (Segment 3 3) (fromList initial))+ actual `shouldBe` [Segment 2 2, Segment 4 4]++ describe "cappedL" $ do+ let original = FT.Single (Item (Max (11 :: Int)) (Segment 11 20))+ it "left of" $ do+ cappedL 5 original `shouldBe` (FT.Empty, FT.Empty)+ it "overlapping" $ do+ cappedL 15 original `shouldBe` (FT.Single (Item (Max (11 :: Int)) (Segment 11 14)), FT.Single (Item (Max 15) (Segment 15 20)))+ it "right of" $ do+ cappedL 25 original `shouldBe` (FT.Single (Item (Max 11) (Segment 11 20)), FT.Empty)+ describe "cappedM" $ do+ let original = FT.Single (Item (Max (21 :: Int)) (Segment 21 30))+ it "left of" $ do+ cappedM 15 original `shouldBe` FT.Single (Item (Max (21 :: Int)) (Segment 21 30))+ it "overlapping" $ do+ cappedM 25 original `shouldBe` FT.Single (Item (Max (26 :: Int)) (Segment 26 30))+ it "left of" $ do+ cappedM 35 original `shouldBe` FT.Empty++ it "should behave just live the naive version" $ do+ require $ property $ do+ segments <- forAll (genOrderedIntSegments 100 1 100)+ segmentSetToList (fromList segments) === N.toList (N.fromList segments)++-- Takes a min and max bound and a list of segments, and produces the inverse+-- i.e. gives you segments where the holes are+-- Assumes the input list is ordered and non-overlapping, and that all elements+-- fall within (minB, maxB) inclusive.+invert :: (Enum k, Eq k) => k -> k -> [Segment k] -> [Segment k]+invert minB maxB [] = [Segment minB maxB]+invert minB maxB (s:ss)+ | minB == low s && maxB == high s = []+ | minB == low s = theRest+ | maxB == high s = [next]+ | otherwise = next : theRest+ where+ next = Segment minB (pred $ low s)+ theRest = invert (succ $ high s) maxB ss++monotonicSegments :: Ord k => [Segment k] -> Bool+monotonicSegments (x1:x2:xs) = high x1 < low x2 && monotonicSegments (x2:xs)+monotonicSegments [x1] = True+monotonicSegments [] = True
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}