packages feed

hw-fingertree (empty) → 0.1.0.0

raw patch · 7 files changed

+1693/−0 lines, 7 filesdep +HUnitdep +QuickCheckdep +basesetup-changed

Dependencies added: HUnit, QuickCheck, base, deepseq, test-framework, test-framework-hunit, test-framework-quickcheck2

Files

+ HaskellWorks/Data/FingerTree.hs view
@@ -0,0 +1,870 @@+{-# 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 (+#if TESTING+    FingerTree(..), Digit(..), Node(..), deep, node2, node3,+#else+    FingerTree,+#endif+    Measured(..),+    -- * Construction+    empty, singleton,+    (<|), (|>), (><),+    fromList,+    -- * Deconstruction+    null,+    ViewL(..), ViewR(..), viewl, viewr,+    split, takeUntil, dropUntil,+    -- * Transformation+    reverse,+    fmap', fmapWithPos, unsafeFmap,+    traverse', traverseWithPos, unsafeTraverse+    -- * Example+    -- $example+    ) where++import           Prelude             hiding (null, reverse)++import           Control.Applicative (Applicative (pure, (<*>)), (<$>))+import           Control.DeepSeq+import           Data.Foldable       (Foldable (foldMap), toList)+import           Data.Monoid+import           GHC.Generics        (Generic)++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, Generic, NFData)++-- | 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, Generic, NFData)++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, Generic, NFData)++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, Generic, NFData)++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 (+#if TESTING+    Show,+#endif+    Generic, NFData)++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"++{- $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".++-}
+ HaskellWorks/Data/IntervalMap/FingerTree.hs view
@@ -0,0 +1,220 @@+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DeriveAnyClass        #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# 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)+--+-- 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 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.IntervalMap.FingerTree (+    -- * Intervals+    Interval(..), point,+    -- * Interval maps+    IntervalMap(..), empty, singleton, insert, union,+    -- * Searching+    search, intersections, dominators+    ) where++import           HaskellWorks.Data.FingerTree (FingerTree, Measured (..),+                                               ViewL (..), (<|), (><))+import qualified HaskellWorks.Data.FingerTree as FT++import           Control.Applicative          ((<$>))+import           Control.DeepSeq+import           Data.Foldable                (Foldable (foldMap))+import           Data.Monoid+import           Data.Traversable             (Traversable (traverse))+import           GHC.Generics++----------------------------------+-- 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, Generic, NFData)++-- | An interval in which the lower and upper bounds are equal.+point :: v -> Interval v+point v = Interval v v++data Node v a = Node (Interval v) a deriving (Generic, NFData)++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 deriving (Generic, NFData)++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))+    deriving (Generic, NFData)+-- 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")]+-}
+ HaskellWorks/Data/PriorityQueue/FingerTree.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.FingerTree (+    PQueue,+    -- * Construction+    empty,+    singleton,+    union,+    insert,+    add,+    fromList,+    -- * Deconstruction+    null,+    minView,+    minViewWithKey+    ) where++import qualified HaskellWorks.Data.FingerTree as FT+import HaskellWorks.Data.FingerTree (FingerTree, (<|), (|>), (><), ViewL(..), Measured(..))++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
+ LICENSE view
@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2017, +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 the copyright holder nor the names of its+  contributors may be used to endorse or promote products derived from+  this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE 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 HOLDER 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hw-fingertree.cabal view
@@ -0,0 +1,54 @@+Name:           hw-fingertree+Version:        0.1.0.0+Cabal-Version:  >= 1.8+Copyright:      (c) 2006 Ross Paterson, Ralf Hinze+License:        BSD3+License-File:   LICENSE+Maintainer:     Ross Paterson <R.Paterson@city.ac.uk>+bug-reports:    http://hub.darcs.net/ross/fingertree/issues+Category:       Data Structures+Synopsis:       Generic finger-tree structure, with example instances+Description:+                A general sequence representation with arbitrary+                annotations, for use as a base for implementations of+                various collection types, with examples, as described+                in section 4 of+                .+                 * Ralf Hinze and Ross Paterson,+                   \"Finger trees: a simple general-purpose data structure\",+                   /Journal of Functional Programming/ 16:2 (2006) pp 197-217.+                   <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++Source-Repository head+  Type: git+  Location: https://github.com/haskell-works/hw-fingertree++Library+  Build-Depends:  base < 6+                , deepseq+  Extensions:   MultiParamTypeClasses+                FunctionalDependencies+                FlexibleInstances+                UndecidableInstances+  Exposed-Modules:+                HaskellWorks.Data.FingerTree+                HaskellWorks.Data.IntervalMap.FingerTree+                HaskellWorks.Data.PriorityQueue.FingerTree++Test-suite ft-properties+  type: exitcode-stdio-1.0+  main-is: tests/ft-properties.hs+  cpp-options: -DTESTING+  build-depends:+                base >= 4.2 && < 6,+                deepseq,+                HUnit,+                QuickCheck,+                test-framework,+                test-framework-hunit,+                test-framework-quickcheck2
+ tests/ft-properties.hs view
@@ -0,0 +1,337 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- QuickCheck properties for Data.FingerTree++module Main where++import HaskellWorks.Data.FingerTree    -- needs to be compiled with -DTESTING for use here++import Test.Framework+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2+import Test.HUnit (Assertion, (@?=))+import Test.QuickCheck hiding ((><))+import Test.QuickCheck.Poly++import Prelude hiding (null, reverse, foldl, foldl1, foldr, foldr1, all)+import qualified Prelude++import Control.Applicative (Applicative(..))+import Control.Monad (ap)+import Data.Foldable (Foldable(foldMap, foldl, foldr), toList, all)+import Data.Functor ((<$>))+import Data.Traversable (traverse)+import Data.List (inits)+import Data.Monoid (Monoid(..))++main :: IO ()+main = defaultMainWithOpts+    [ testProperty "foldr" prop_foldr+    , testProperty "foldl" prop_foldl+    , testProperty "(==)" prop_equals+    , testProperty "compare" prop_compare+    , testProperty "mappend" prop_mappend+    , testCase "empty" test_empty+    , testProperty "singleton" prop_singleton+    , testProperty "(<|)" prop_cons+    , testProperty "(|>)" prop_snoc+    , testProperty "(><)" prop_append+    , testProperty "fromList" prop_fromList+    , testProperty "null" prop_null+    , testProperty "viewl" prop_viewl+    , testProperty "viewr" prop_viewr+    , testProperty "split" prop_split+    , testProperty "takeUntil" prop_takeUntil+    , testProperty "dropUntil" prop_dropUntil+    , testProperty "reverse" prop_reverse+    , testProperty "fmap'" prop_fmap'+    -- , testProperty "fmapWithPos" prop_fmapWithPos -- (slow)+    , testProperty "traverse'" prop_traverse'+    -- , testProperty "traverseWithPos" prop_traverseWithPos -- (slow)+    ] runner_opts+  where+    runner_opts = mempty { ropt_test_options = Just test_opts }+    test_opts = mempty {+          topt_maximum_generated_tests = Just 500+        , topt_maximum_unsuitable_generated_tests = Just 500+        }++{--------------------------------------------------------------------+  The general plan is to compare each function with a list equivalent.+  Each operation should produce a valid tree representing the same+  sequence as produced by its list counterpart on corresponding inputs.+  (The list versions are often lazier, but these properties ignore+  strictness.)+--------------------------------------------------------------------}++-- utilities for partial conversions++infix 4 ~=++(~=) :: Eq a => Maybe a -> a -> Bool+(~=) = maybe (const False) (==)++-- Partial conversion of an output sequence to a list.+toList' :: (Eq a, Measured [a] a, Valid a) => Seq a -> Maybe [a]+toList' xs+  | valid xs = Just (toList xs)+  | otherwise = Nothing++toListPair' ::+    (Eq a, Measured [a] a, Valid a, Eq b, Measured [b] b, Valid b) =>+        (Seq a, Seq b) -> Maybe ([a], [b])+toListPair' (xs, ys) = (,) <$> toList' xs <*> toList' ys++-- instances++prop_foldr :: Seq A -> Bool+prop_foldr xs =+    foldr f z xs == Prelude.foldr f z (toList xs)+  where+    f = (:)+    z = []++prop_foldl :: Seq A -> Bool+prop_foldl xs =+    foldl f z xs == Prelude.foldl f z (toList xs)+  where+    f = flip (:)+    z = []++prop_equals :: Seq OrdA -> Seq OrdA -> Bool+prop_equals xs ys =+    (xs == ys) == (toList xs == toList ys)++prop_compare :: Seq OrdA -> Seq OrdA -> Bool+prop_compare xs ys =+    compare xs ys == compare (toList xs) (toList ys)++prop_mappend :: Seq A -> Seq A -> Bool+prop_mappend xs ys =+    toList' (mappend xs ys) ~= toList xs ++ toList ys++-- * Construction++test_empty :: Assertion+test_empty =+    toList' (empty :: Seq A) @?= Just []++prop_singleton :: A -> Bool+prop_singleton x =+    toList' (singleton x) ~= [x]++prop_cons :: A -> Seq A -> Bool+prop_cons x xs =+    toList' (x <| xs) ~= x : toList xs++prop_snoc :: Seq A -> A -> Bool+prop_snoc xs x =+    toList' (xs |> x) ~= toList xs ++ [x]++prop_append :: Seq A -> Seq A -> Bool+prop_append xs ys =+    toList' (xs >< ys) ~= toList xs ++ toList ys++prop_fromList :: [A] -> Bool+prop_fromList xs =+    toList' (fromList xs) ~= xs++-- * Deconstruction++prop_null :: Seq A -> Bool+prop_null xs =+    null xs == Prelude.null (toList xs)++prop_viewl :: Seq A -> Bool+prop_viewl xs =+    case viewl xs of+    EmptyL ->   Prelude.null (toList xs)+    x :< xs' -> valid xs' && toList xs == x : toList xs'++prop_viewr :: Seq A -> Bool+prop_viewr xs =+    case viewr xs of+    EmptyR ->   Prelude.null (toList xs)+    xs' :> x -> valid xs' && toList xs == toList xs' ++ [x]++prop_split :: Int -> Seq A -> Bool+prop_split n xs =+    toListPair' (split p xs) ~= Prelude.splitAt n (toList xs)+  where p ys = Prelude.length ys > n++prop_takeUntil :: Int -> Seq A -> Bool+prop_takeUntil n xs =+    toList' (takeUntil p xs) ~= Prelude.take n (toList xs)+  where p ys = Prelude.length ys > n++prop_dropUntil :: Int -> Seq A -> Bool+prop_dropUntil n xs =+    toList' (dropUntil p xs) ~= Prelude.drop n (toList xs)+  where p ys = Prelude.length ys > n++-- * Transformation++prop_reverse :: Seq A -> Bool+prop_reverse xs =+    toList' (reverse xs) ~= Prelude.reverse (toList xs)++prop_fmap' :: Seq A -> Bool+prop_fmap' xs =+    toList' (fmap' f xs) ~= map f (toList xs)+  where f = Just++prop_fmapWithPos :: Seq A -> Bool+prop_fmapWithPos xs =+    toList' (fmapWithPos f xs) ~= zipWith f (inits xs_list) xs_list+  where+    f = (,)+    xs_list = toList xs++prop_traverse' :: Seq A -> Bool+prop_traverse' xs =+    toList' (evalM (traverse' f xs)) ~= evalM (traverse f (toList xs))+  where+    f x = do+        n <- step+        return (n, x)++prop_traverseWithPos :: Seq A -> Bool+prop_traverseWithPos xs =+    toList' (evalM (traverseWithPos f xs)) ~= evalM (traverse (uncurry f) (zip (inits xs_list) xs_list))+  where+    f xs y = do+        n <- step+        return (xs, n, y)+    xs_list = toList xs++{- untested:+traverseWithPos+-}++------------------------------------------------------------------------+-- QuickCheck+------------------------------------------------------------------------++instance (Arbitrary a, Measured v a) => Arbitrary (FingerTree v a) where+    arbitrary = sized arb+      where+        arb :: (Arbitrary a, Measured v a) => Int -> Gen (FingerTree v a)+        arb 0 = return Empty+        arb 1 = Single <$> arbitrary+        arb n = deep <$> arbitrary <*> arb (n `div` 2) <*> arbitrary++    shrink (Deep _ (One a) Empty (One b)) = [Single a, Single b]+    shrink (Deep _ pr m sf) =+        [deep pr' m sf | pr' <- shrink pr] +++        [deep pr m' sf | m' <- shrink m] +++        [deep pr m sf' | sf' <- shrink sf]+    shrink (Single x) = map Single (shrink x)+    shrink Empty = []++instance (Arbitrary a, Measured v a) => Arbitrary (Node v a) where+    arbitrary = oneof [+        node2 <$> arbitrary <*> arbitrary,+        node3 <$> arbitrary <*> arbitrary <*> arbitrary]++    shrink (Node2 _ a b) =+        [node2 a' b | a' <- shrink a] +++        [node2 a b' | b' <- shrink b]+    shrink (Node3 _ a b c) =+        [node2 a b, node2 a c, node2 b c] +++        [node3 a' b c | a' <- shrink a] +++        [node3 a b' c | b' <- shrink b] +++        [node3 a b c' | c' <- shrink c]++instance Arbitrary a => Arbitrary (Digit a) where+    arbitrary = oneof [+        One <$> arbitrary,+        Two <$> arbitrary <*> arbitrary,+        Three <$> arbitrary <*> arbitrary <*> arbitrary,+        Four <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary]++    shrink (One a) = map One (shrink a)+    shrink (Two a b) = [One a, One b]+    shrink (Three a b c) = [Two a b, Two a c, Two b c]+    shrink (Four a b c d) = [Three a b c, Three a b d, Three a c d, Three b c d]++------------------------------------------------------------------------+-- Valid trees+------------------------------------------------------------------------++class Valid a where+    valid :: a -> Bool++instance (Measured v a, Eq v, Valid a) => Valid (FingerTree v a) where+    valid Empty = True+    valid (Single x) = valid x+    valid (Deep s pr m sf) =+        s == measure pr `mappend` measure m `mappend` measure sf &&+        valid pr && valid m && valid sf++instance (Measured v a, Eq v, Valid a) => Valid (Node v a) where+    valid node = measure node == foldMap measure node && all valid node++instance Valid a => Valid (Digit a) where+    valid = all valid++instance Valid A where+    valid = const True++instance Valid (a,b) where+    valid = const True++instance Valid (a,b,c) where+    valid = const True++instance Valid (Maybe a) where+    valid = const True++instance Valid [a] where+    valid = const True++------------------------------------------------------------------------+-- Use list of elements as the measure+------------------------------------------------------------------------++type Seq a = FingerTree [a] a++instance Measured [A] A where+    measure x = [x]++instance Measured [OrdA] OrdA where+    measure x = [x]++instance Measured [Maybe a] (Maybe a) where+    measure x = [x]++instance Measured [(a, b)] (a, b) where+    measure x = [x]++instance Measured [(a, b, c)] (a, b, c) where+    measure x = [x]++------------------------------------------------------------------------+-- Simple counting monad+------------------------------------------------------------------------++newtype M a = M (Int -> (Int, a))++runM :: M a -> Int -> (Int, a)+runM (M m) = m++evalM :: M a -> a+evalM m = snd (runM m 0)++instance Monad M where+    return x = M $ \ n -> (n, x)+    M u >>= f = M $ \ m -> let (n, x) = u m in runM (f x) n++instance Functor M where+    fmap f (M u) = M $ \ m -> let (n, x) = u m in (n, f x)++instance Applicative M where+    pure = return+    (<*>) = ap++step :: M Int+step = M $ \ n -> (n+1, n)