fingertree-0.1.0.0/0000755000000000000000000000000012154672401012170 5ustar0000000000000000fingertree-0.1.0.0/Setup.hs0000644000000000000000000000005612154672401013625 0ustar0000000000000000import Distribution.Simple main = defaultMain fingertree-0.1.0.0/LICENSE0000644000000000000000000000311312154672401013173 0ustar0000000000000000The Glasgow Haskell Compiler License Copyright 2006, The University Court of the University of Glasgow. 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 name of the University 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 UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE 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 UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE 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. fingertree-0.1.0.0/fingertree.cabal0000644000000000000000000000344412154672401015313 0ustar0000000000000000Name: 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 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: darcs Location: http://code.haskell.org/~ross/fingertree Library Build-Depends: base < 6 Extensions: MultiParamTypeClasses FunctionalDependencies FlexibleInstances UndecidableInstances Exposed-Modules: Data.FingerTree Data.IntervalMap.FingerTree 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, HUnit, QuickCheck, test-framework, test-framework-hunit, test-framework-quickcheck2 fingertree-0.1.0.0/Data/0000755000000000000000000000000012154672401013041 5ustar0000000000000000fingertree-0.1.0.0/Data/FingerTree.hs0000644000000000000000000007672512154672401015450 0ustar0000000000000000{-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Data.FingerTree -- Copyright : (c) Ross Paterson, Ralf Hinze 2006 -- License : BSD-style -- Maintainer : ross@soi.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 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 Data.Monoid import Data.Foldable (Foldable(foldMap), toList) infixr 5 >< infixr 5 <|, :< infixl 5 |>, :> -- | View of the left end of a sequence. data ViewL s a = EmptyL -- ^ empty sequence | a :< s a -- ^ leftmost element and the rest of the sequence deriving (Eq, Ord, Show, Read) -- | View of the right end of a sequence. data ViewR s a = EmptyR -- ^ empty sequence | s a :> a -- ^ the sequence minus the rightmost element, -- and the rightmost element deriving (Eq, Ord, Show, Read) instance Functor s => Functor (ViewL s) where fmap _ EmptyL = EmptyL fmap f (x :< xs) = f x :< fmap f xs instance Functor s => Functor (ViewR s) where fmap _ EmptyR = EmptyR fmap f (xs :> x) = fmap f xs :> f x -- | 'empty' and '><'. instance Measured v a => Monoid (FingerTree v a) where mempty = empty mappend = (><) -- Explicit Digit type (Exercise 1) data Digit a = One a | Two a a | Three a a a | Four a a a a deriving Show instance Foldable Digit where foldMap f (One a) = f a foldMap f (Two a b) = f a `mappend` f b foldMap f (Three a b c) = f a `mappend` f b `mappend` f c foldMap f (Four a b c d) = f a `mappend` f b `mappend` f c `mappend` f d ------------------- -- 4.1 Measurements ------------------- -- | Things that can be measured. class (Monoid v) => Measured v a | a -> v where measure :: a -> v instance (Measured v a) => Measured v (Digit a) where measure = foldMap measure --------------------------- -- 4.2 Caching measurements --------------------------- data Node v a = Node2 !v a a | Node3 !v a a a deriving Show instance Foldable (Node v) where foldMap f (Node2 _ a b) = f a `mappend` f b foldMap f (Node3 _ a b c) = f a `mappend` f b `mappend` f c node2 :: (Measured v a) => a -> a -> Node v a node2 a b = Node2 (measure a `mappend` measure b) a b node3 :: (Measured v a) => a -> a -> a -> Node v a node3 a b c = Node3 (measure a `mappend` measure b `mappend` measure c) a b c instance (Monoid v) => Measured v (Node v a) where measure (Node2 v _ _) = v measure (Node3 v _ _ _) = v nodeToDigit :: Node v a -> Digit a nodeToDigit (Node2 _ a b) = Two a b nodeToDigit (Node3 _ a b c) = Three a b c -- | A representation of a sequence of values of type @a@, allowing -- access to the ends in constant time, and append and split in time -- logarithmic in the size of the smaller piece. -- -- The collection is also parameterized by a measure type @v@, which -- is used to specify a position in the sequence for the 'split' operation. -- The types of the operations enforce the constraint @'Measured' v a@, -- which also implies that the type @v@ is determined by @a@. -- -- A variety of abstract data types can be implemented by using different -- element types and measurements. data FingerTree v a = Empty | Single a | Deep !v !(Digit a) (FingerTree v (Node v a)) !(Digit a) #if TESTING deriving Show #endif 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". -} fingertree-0.1.0.0/Data/IntervalMap/0000755000000000000000000000000012154672401015263 5ustar0000000000000000fingertree-0.1.0.0/Data/IntervalMap/FingerTree.hs0000644000000000000000000001501012154672401017646 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module : Data.PriorityQueue.FingerTree -- Copyright : (c) Ross Paterson 2008 -- License : BSD-style -- Maintainer : ross@soi.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 Data.IntervalMap.FingerTree ( -- * Intervals Interval(..), point, -- * Interval maps IntervalMap, empty, singleton, insert, union, -- * Searching search, intersections, dominators ) where import qualified Data.FingerTree as FT import Data.FingerTree (FingerTree, Measured(..), ViewL(..), (<|), (><)) import Control.Applicative ((<$>)) import Data.Traversable (Traversable(traverse)) import Data.Foldable (Foldable(foldMap)) import Data.Monoid ---------------------------------- -- 4.8 Application: interval trees ---------------------------------- -- | A closed interval. The lower bound should be less than or equal -- to the higher bound. data Interval v = Interval { low :: v, high :: v } deriving (Eq, Ord, Show) -- | An interval in which the lower and upper bounds are equal. point :: v -> Interval v point v = Interval v v data Node v a = Node (Interval v) a instance Functor (Node v) where fmap f (Node i x) = Node i (f x) instance Foldable (Node v) where foldMap f (Node _ x) = f x instance Traversable (Node v) where traverse f (Node i x) = Node i <$> f x -- rightmost interval (including largest lower bound) and largest upper bound. data IntInterval v = NoInterval | IntInterval (Interval v) v instance Ord v => Monoid (IntInterval v) where mempty = NoInterval NoInterval `mappend` i = i i `mappend` NoInterval = i IntInterval _ hi1 `mappend` IntInterval int2 hi2 = IntInterval int2 (max hi1 hi2) instance (Ord v) => Measured (IntInterval v) (Node v a) where measure (Node i _) = IntInterval i (high i) -- | Map of closed intervals, possibly with duplicates. -- The 'Foldable' and 'Traversable' instances process the intervals in -- lexicographical order. newtype IntervalMap v a = IntervalMap (FingerTree (IntInterval v) (Node v a)) -- ordered lexicographically by interval instance Functor (IntervalMap v) where fmap f (IntervalMap t) = IntervalMap (FT.unsafeFmap (fmap f) t) instance Foldable (IntervalMap v) where foldMap f (IntervalMap t) = foldMap (foldMap f) t instance Traversable (IntervalMap v) where traverse f (IntervalMap t) = IntervalMap <$> FT.unsafeTraverse (traverse f) t -- | 'empty' and 'union'. instance (Ord v) => Monoid (IntervalMap v a) where mempty = empty mappend = union -- | /O(1)/. The empty interval map. empty :: (Ord v) => IntervalMap v a empty = IntervalMap FT.empty -- | /O(1)/. Interval map with a single entry. singleton :: (Ord v) => Interval v -> a -> IntervalMap v a singleton i x = IntervalMap (FT.singleton (Node i x)) -- | /O(log n)/. Insert an interval into a map. -- The map may contain duplicate intervals; the new entry will be inserted -- before any existing entries for the same interval. insert :: (Ord v) => Interval v -> a -> IntervalMap v a -> IntervalMap v a insert (Interval lo hi) x 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 -- | /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 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 -- | /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 greater :: (Ord v) => v -> IntInterval v -> Bool greater k (IntInterval i _) = low i > k 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")] fingertree-0.1.0.0/Data/PriorityQueue/0000755000000000000000000000000012154672401015667 5ustar0000000000000000fingertree-0.1.0.0/Data/PriorityQueue/FingerTree.hs0000644000000000000000000001326212154672401020261 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module : Data.PriorityQueue.FingerTree -- Copyright : (c) Ross Paterson 2008 -- License : BSD-style -- Maintainer : ross@soi.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 Data.PriorityQueue.FingerTree ( PQueue, -- * Construction empty, singleton, union, insert, add, fromList, -- * Deconstruction null, minView, minViewWithKey ) where import qualified Data.FingerTree as FT import Data.FingerTree (FingerTree, (<|), (|>), (><), ViewL(..), Measured(measure)) import Control.Arrow ((***)) import Data.Foldable (Foldable(foldMap)) import Data.Monoid import Data.List (unfoldr) import Prelude hiding (null) data Entry k v = Entry { key :: k, value :: 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 fingertree-0.1.0.0/tests/0000755000000000000000000000000012154672401013332 5ustar0000000000000000fingertree-0.1.0.0/tests/ft-properties.hs0000644000000000000000000002233612154672401016477 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- QuickCheck properties for Data.FingerTree module Main where import 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(..), 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)