diff --git a/HaskellWorks/Data/FingerTree.hs b/HaskellWorks/Data/FingerTree.hs new file mode 100644 --- /dev/null +++ b/HaskellWorks/Data/FingerTree.hs @@ -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. +-- +-- +-- 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". + +-} diff --git a/HaskellWorks/Data/IntervalMap/FingerTree.hs b/HaskellWorks/Data/IntervalMap/FingerTree.hs new file mode 100644 --- /dev/null +++ b/HaskellWorks/Data/IntervalMap/FingerTree.hs @@ -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. +-- +-- +-- 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")] +-} diff --git a/HaskellWorks/Data/PriorityQueue/FingerTree.hs b/HaskellWorks/Data/PriorityQueue/FingerTree.hs new file mode 100644 --- /dev/null +++ b/HaskellWorks/Data/PriorityQueue/FingerTree.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.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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. 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.cabal b/hw-fingertree.cabal new file mode 100644 --- /dev/null +++ b/hw-fingertree.cabal @@ -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 +bug-reports: http://hub.darcs.net/ross/fingertree/issues +Category: Data Structures +Synopsis: Generic finger-tree structure, with example instances +Description: + A general sequence representation with arbitrary + annotations, for use as a base for implementations of + various collection types, with examples, as described + in section 4 of + . + * Ralf Hinze and Ross Paterson, + \"Finger trees: a simple general-purpose data structure\", + /Journal of Functional Programming/ 16:2 (2006) pp 197-217. + + . + For a tuned sequence type, see @Data.Sequence@ in the + @containers@ package, which is a specialization of + this structure. +Build-Type: Simple + +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 diff --git a/tests/ft-properties.hs b/tests/ft-properties.hs new file mode 100644 --- /dev/null +++ b/tests/ft-properties.hs @@ -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)