diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# hw-fingertree-strict diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hw-fingertree-strict.cabal b/hw-fingertree-strict.cabal new file mode 100644 --- /dev/null +++ b/hw-fingertree-strict.cabal @@ -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. + + . + 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 diff --git a/src/HaskellWorks/Data/FingerTree/Strict.hs b/src/HaskellWorks/Data/FingerTree/Strict.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/FingerTree/Strict.hs @@ -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. +-- +-- +-- 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". + +-} diff --git a/src/HaskellWorks/Data/IntervalMap/Strict.hs b/src/HaskellWorks/Data/IntervalMap/Strict.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/IntervalMap/Strict.hs @@ -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. +-- +-- +-- 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")] +-} diff --git a/src/HaskellWorks/Data/Item/Strict.hs b/src/HaskellWorks/Data/Item/Strict.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Item/Strict.hs @@ -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 diff --git a/src/HaskellWorks/Data/PriorityQueue/Strict.hs b/src/HaskellWorks/Data/PriorityQueue/Strict.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/PriorityQueue/Strict.hs @@ -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. +-- +-- +-- 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 diff --git a/src/HaskellWorks/Data/Segment/Strict.hs b/src/HaskellWorks/Data/Segment/Strict.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Segment/Strict.hs @@ -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 diff --git a/src/HaskellWorks/Data/SegmentMap/Strict.hs b/src/HaskellWorks/Data/SegmentMap/Strict.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/SegmentMap/Strict.hs @@ -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. +-- +-- +-- 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 diff --git a/src/HaskellWorks/Data/SegmentSet/Strict.hs b/src/HaskellWorks/Data/SegmentSet/Strict.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/SegmentSet/Strict.hs @@ -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. +-- +-- +-- 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 diff --git a/test/HaskellWorks/Data/Gen.hs b/test/HaskellWorks/Data/Gen.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Gen.hs @@ -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)) diff --git a/test/HaskellWorks/Data/SegmentMap/StrictSpec.hs b/test/HaskellWorks/Data/SegmentMap/StrictSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/SegmentMap/StrictSpec.hs @@ -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 diff --git a/test/HaskellWorks/Data/SegmentSet/Naive.hs b/test/HaskellWorks/Data/SegmentSet/Naive.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/SegmentSet/Naive.hs @@ -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) diff --git a/test/HaskellWorks/Data/SegmentSet/NaiveSpec.hs b/test/HaskellWorks/Data/SegmentSet/NaiveSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/SegmentSet/NaiveSpec.hs @@ -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] diff --git a/test/HaskellWorks/Data/SegmentSet/StrictSpec.hs b/test/HaskellWorks/Data/SegmentSet/StrictSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/SegmentSet/StrictSpec.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}