diff --git a/Data/FingerTree.hs b/Data/FingerTree.hs --- a/Data/FingerTree.hs +++ b/Data/FingerTree.hs @@ -50,21 +50,36 @@ fromList, -- * Deconstruction null, - ViewL(..), ViewR(..), viewl, viewr, + -- ** Examining the ends + ViewL(..), viewl, + ViewR(..), viewr, + -- ** Search + SearchResult(..), search, + -- ** Splitting + -- | These functions are special cases of 'search'. split, takeUntil, dropUntil, -- * Transformation reverse, - fmap', fmapWithPos, unsafeFmap, - traverse', traverseWithPos, unsafeTraverse + -- ** Maps + fmap', fmapWithPos, fmapWithContext, unsafeFmap, + -- ** Traversals + traverse', traverseWithPos, traverseWithContext, unsafeTraverse, -- * Example -- $example ) where import Prelude hiding (null, reverse) - +#if MIN_VERSION_base(4,8,0) +import qualified Prelude (null) +#else import Control.Applicative (Applicative(pure, (<*>)), (<$>)) import Data.Monoid -import Data.Foldable (Foldable(foldMap), toList) +import Data.Foldable (Foldable(foldMap)) +#endif +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup +#endif +import Data.Foldable (toList) infixr 5 >< infixr 5 <|, :< @@ -83,18 +98,25 @@ -- and the rightmost element deriving (Eq, Ord, Show, Read) -instance Functor s => Functor (ViewL s) where +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 +instance (Functor s) => Functor (ViewR s) where fmap _ EmptyR = EmptyR fmap f (xs :> x) = fmap f xs :> f x +#if MIN_VERSION_base(4,9,0) +instance (Measured v a) => Semigroup (FingerTree v a) where + (<>) = (><) +#endif + -- | 'empty' and '><'. -instance Measured v a => Monoid (FingerTree v a) where +instance (Measured v a) => Monoid (FingerTree v a) where mempty = empty +#if !(MIN_VERSION_base(4,11,0)) mappend = (><) +#endif -- Explicit Digit type (Exercise 1) @@ -168,7 +190,8 @@ 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 +deep pr m sf = + Deep ((measure pr `mappend` measure 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 @@ -176,25 +199,32 @@ measure (Single x) = measure x measure (Deep v _ _ _) = v +-- | Elements from left to right. 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 +#if MIN_VERSION_base(4,8,0) + null Empty = True + null _ = False +#endif + +instance (Eq a) => Eq (FingerTree v a) where xs == ys = toList xs == toList ys -instance Ord a => Ord (FingerTree v a) where +-- | Lexicographical order from left to right. +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 +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. +-- | Like 'fmap', but with constraints on the element types. fmap' :: (Measured v1 a1, Measured v2 a2) => (a1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2 fmap' = mapTree @@ -233,7 +263,7 @@ (mapWPDigit f vm sf) where vpr = v `mappend` measure pr - vm = vpr `mappendVal` m + vm = vpr `mappend` measure m mapWPNode :: (Measured v1 a1, Measured v2 a2) => (v1 -> a1 -> a2) -> v1 -> Node v1 a1 -> Node v2 a2 @@ -260,6 +290,64 @@ vab = va `mappend` measure b vabc = vab `mappend` measure c +-- | Map all elements of the tree with a function that also takes the +-- measure of the prefix to the left and of the suffix to the right of +-- the element. +fmapWithContext :: (Measured v1 a1, Measured v2 a2) => + (v1 -> a1 -> v1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2 +fmapWithContext f t = mapWCTree f mempty t mempty + +mapWCTree :: (Measured v1 a1, Measured v2 a2) => + (v1 -> a1 -> v1 -> a2) -> v1 -> FingerTree v1 a1 -> v1 -> FingerTree v2 a2 +mapWCTree _ _ Empty _ = Empty +mapWCTree f vl (Single x) vr = Single (f vl x vr) +mapWCTree f vl (Deep _ pr m sf) vr = + deep (mapWCDigit f vl pr vmsr) + (mapWCTree (mapWCNode f) vlp m vsr) + (mapWCDigit f vlpm sf vr) + where + vlp = vl `mappend` measure pr + vlpm = vlp `mappend` vm + vmsr = vm `mappend` vsr + vsr = measure sf `mappend` vr + vm = measure m + +mapWCNode :: (Measured v1 a1, Measured v2 a2) => + (v1 -> a1 -> v1 -> a2) -> v1 -> Node v1 a1 -> v1 -> Node v2 a2 +mapWCNode f vl (Node2 _ a b) vr = node2 (f vl a vb) (f va b vr) + where + va = vl `mappend` measure a + vb = measure b `mappend` vr +mapWCNode f vl (Node3 _ a b c) vr = node3 (f vl a vbc) (f va b vc) (f vab c vr) + where + va = vl `mappend` measure a + vab = va `mappend` measure b + vbc = measure b `mappend` vc + vc = measure c `mappend` vr + +mapWCDigit :: + (Measured v a) => (v -> a -> v -> b) -> v -> Digit a -> v -> Digit b +mapWCDigit f vl (One a) vr = One (f vl a vr) +mapWCDigit f vl (Two a b) vr = Two (f vl a vb) (f va b vr) + where + va = vl `mappend` measure a + vb = measure b `mappend` vr +mapWCDigit f vl (Three a b c) vr = Three (f vl a vbc) (f va b vc) (f vab c vr) + where + va = vl `mappend` measure a + vab = va `mappend` measure b + vbc = measure b `mappend` vc + vc = measure c `mappend` vr +mapWCDigit f vl (Four a b c d) vr = + Four (f vl a vbcd) (f va b vcd) (f vab c vd) (f vabc d vr) + where + va = vl `mappend` measure a + vab = va `mappend` measure b + vabc = vab `mappend` measure c + vbcd = measure b `mappend` vcd + vcd = measure c `mappend` vd + vd = measure d `mappend` vr + -- | Like 'fmap', but safe only if the function preserves the measure. unsafeFmap :: (a -> b) -> FingerTree v a -> FingerTree v b unsafeFmap _ Empty = Empty @@ -271,7 +359,7 @@ 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. +-- | Like 'traverse', but with constraints on the element types. traverse' :: (Measured v1 a1, Measured v2 a2, Applicative f) => (a1 -> f a2) -> FingerTree v1 a1 -> f (FingerTree v2 a2) traverse' = traverseTree @@ -294,8 +382,8 @@ 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. +-- | Traverse the tree from left to right 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 @@ -308,7 +396,7 @@ deep <$> traverseWPDigit f v pr <*> traverseWPTree (traverseWPNode f) vpr m <*> traverseWPDigit f vm sf where vpr = v `mappend` measure pr - vm = vpr `mappendVal` m + vm = vpr `mappend` measure m traverseWPNode :: (Measured v1 a1, Measured v2 a2, Applicative f) => (v1 -> a1 -> f a2) -> v1 -> Node v1 a1 -> f (Node v2 a2) @@ -336,6 +424,64 @@ vab = va `mappend` measure b vabc = vab `mappend` measure c +-- | Traverse the tree from left to right with a function that also +-- takes the measure of the prefix to the left and the measure of the +-- suffix to the right of the element. +traverseWithContext :: (Measured v1 a1, Measured v2 a2, Applicative f) => + (v1 -> a1 -> v1 -> f a2) -> FingerTree v1 a1 -> f (FingerTree v2 a2) +traverseWithContext f t = traverseWCTree f mempty t mempty + +traverseWCTree :: (Measured v1 a1, Measured v2 a2, Applicative f) => + (v1 -> a1 -> v1 -> f a2) -> v1 -> FingerTree v1 a1 -> v1 -> f (FingerTree v2 a2) +traverseWCTree _ _ Empty _ = pure Empty +traverseWCTree f vl (Single x) vr = Single <$> f vl x vr +traverseWCTree f vl (Deep _ pr m sf) vr = + deep <$> traverseWCDigit f vl pr vmsr <*> traverseWCTree (traverseWCNode f) vlp m vsr <*> traverseWCDigit f vlpm sf vr + where + vlp = vl `mappend` measure pr + vlpm = vlp `mappend` vm + vmsr = vm `mappend` vsr + vsr = measure sf `mappend` vr + vm = measure m + +traverseWCNode :: (Measured v1 a1, Measured v2 a2, Applicative f) => + (v1 -> a1 -> v1 -> f a2) -> v1 -> Node v1 a1 -> v1 -> f (Node v2 a2) +traverseWCNode f vl (Node2 _ a b) vr = node2 <$> f vl a vb <*> f va b vr + where + va = vl `mappend` measure a + vb = measure a `mappend` vr +traverseWCNode f vl (Node3 _ a b c) vr = + node3 <$> f vl a vbc <*> f va b vc <*> f vab c vr + where + va = vl `mappend` measure a + vab = va `mappend` measure b + vc = measure c `mappend` vr + vbc = measure b `mappend` vc + +traverseWCDigit :: (Measured v a, Applicative f) => + (v -> a -> v -> f b) -> v -> Digit a -> v -> f (Digit b) +traverseWCDigit f vl (One a) vr = One <$> f vl a vr +traverseWCDigit f vl (Two a b) vr = Two <$> f vl a vb <*> f va b vr + where + va = vl `mappend` measure a + vb = measure a `mappend` vr +traverseWCDigit f vl (Three a b c) vr = + Three <$> f vl a vbc <*> f va b vc <*> f vab c vr + where + va = vl `mappend` measure a + vab = va `mappend` measure b + vc = measure c `mappend` vr + vbc = measure b `mappend` vc +traverseWCDigit f vl (Four a b c d) vr = + Four <$> f vl a vbcd <*> f va b vcd <*> f vab c vd <*> f vabc d vr + where + va = vl `mappend` measure a + vab = va `mappend` measure b + vabc = vab `mappend` measure c + vd = measure d `mappend` vr + vcd = measure c `mappend` vd + vbcd = measure b `mappend` vcd + -- | Like 'traverse', but safe only if the function preserves the measure. unsafeTraverse :: (Applicative f) => (a -> f b) -> FingerTree v a -> f (FingerTree v b) @@ -362,6 +508,7 @@ singleton = Single -- | /O(n)/. Create a sequence from a finite list of elements. +-- The opposite operation 'toList' is supplied by the 'Foldable' instance. fromList :: (Measured v a) => [a] -> FingerTree v a fromList = foldr (<|) Empty @@ -398,7 +545,7 @@ snocDigit (Four _ _ _ _) _ = illegal_argument "snocDigit" -- | /O(1)/. Is this the empty sequence? -null :: (Measured v a) => FingerTree v a -> Bool +null :: FingerTree v a -> Bool null Empty = True null _ = False @@ -436,7 +583,7 @@ 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) + m' :> a -> Deep (measure pr `mappend` measure m) pr m' (nodeToDigit a) rheadDigit :: Digit a -> a rheadDigit (One a) = a @@ -698,8 +845,144 @@ -- 4.4 Splitting ---------------- +-- | A result of 'search', attempting to find a point where a predicate +-- on splits of the sequence changes from 'False' to 'True'. +data SearchResult v a + = Position (FingerTree v a) a (FingerTree v a) + -- ^ A tree opened at a particular element: the prefix to the + -- left, the element, and the suffix to the right. + | OnLeft + -- ^ A position to the left of the sequence, indicating that the + -- predicate is 'True' at both ends. + | OnRight + -- ^ A position to the right of the sequence, indicating that the + -- predicate is 'False' at both ends. + | Nowhere + -- ^ No position in the tree, returned if the predicate is 'True' + -- at the left end and 'False' at the right end. This will not + -- occur if the predicate in monotonic on the tree. + deriving (Eq, Ord, Show) + +-- | /O(log(min(i,n-i)))/. Search a sequence for a point where a predicate +-- on splits of the sequence changes from 'False' to 'True'. +-- +-- The argument @p@ is a relation between the measures of the two +-- sequences that could be appended together to form the sequence @t@. +-- If the relation is 'False' at the leftmost split and 'True' at the +-- rightmost split, i.e. +-- +-- @not (p 'mempty' ('measure' t)) && p ('measure' t) 'mempty'@ +-- +-- then there must exist an element @x@ in the sequence such that @p@ +-- is 'False' for the split immediately before @x@ and 'True' for the +-- split just after it: +-- +-- <> +-- +-- In this situation, @'search' p t@ returns such an element @x@ and the +-- pieces @l@ and @r@ of the sequence to its left and right respectively. +-- That is, it returns @'Position' l x r@ such that +-- +-- * @l >< (x <| r) = t@ +-- +-- * @not (p (measure l) (measure (x <| r))@ +-- +-- * @p (measure (l |> x)) (measure r)@ +-- +-- For predictable results, one should ensure that there is only one such +-- point, i.e. that the predicate is /monotonic/ on @t@. +search :: (Measured v a) => + (v -> v -> Bool) -> FingerTree v a -> SearchResult v a +search p t + | p_left && p_right = OnLeft + | not p_left && p_right = case searchTree p mempty t mempty of + Split l x r -> Position l x r + | not p_left && not p_right = OnRight + | otherwise = Nowhere + where + p_left = p mempty vt + p_right = p vt mempty + vt = measure t + +-- isSplit :: (Measured v a) => (v -> v -> Bool) -> v -> a -> v -> Bool +-- isSplit p vl x vr = not (p vl (v `mappend` vr)) && p (vl `mappend` v) vr +-- where v = measure x +-- +-- property: +-- isSplit p vl t vr => +-- let Split l x r = search t in +-- isSplit p (vl `mappend` measure l) x (measure r `mappend` vr) + +searchTree :: (Measured v a) => + (v -> v -> Bool) -> v -> FingerTree v a -> v -> Split (FingerTree v a) a +searchTree _ _ Empty _ = illegal_argument "searchTree" +searchTree _ _ (Single x) _ = Split Empty x Empty +searchTree p vl (Deep _ pr m sf) vr + | p vlp vmsr = let Split l x r = searchDigit p vl pr vmsr + in Split (maybe Empty digitToTree l) x (deepL r m sf) + | p vlpm vsr = let Split ml xs mr = searchTree p vlp m vsr + Split l x r = searchNode p (vlp `mappend` measure ml) xs (measure mr `mappend` vsr) + in Split (deepR pr ml l) x (deepL r mr sf) + | otherwise = let Split l x r = searchDigit p vm sf vr + in Split (deepR pr m l) x (maybe Empty digitToTree r) + where + vlp = vl `mappend` measure pr + vlpm = vlp `mappend` vm + vmsr = vm `mappend` vsr + vsr = measure sf `mappend` vr + vm = measure m + +searchNode :: (Measured v a) => + (v -> v -> Bool) -> v -> Node v a -> v -> Split (Maybe (Digit a)) a +searchNode p vl (Node2 _ a b) vr + | p va vb = Split Nothing a (Just (One b)) + | otherwise = Split (Just (One a)) b Nothing + where + va = vl `mappend` measure a + vb = measure b `mappend` vr +searchNode p vl (Node3 _ a b c) vr + | p va vbc = Split Nothing a (Just (Two b c)) + | p vab vc = Split (Just (One a)) b (Just (One c)) + | otherwise = Split (Just (Two a b)) c Nothing + where + va = vl `mappend` measure a + vab = va `mappend` measure b + vc = measure c `mappend` vr + vbc = measure b `mappend` vc + +searchDigit :: (Measured v a) => + (v -> v -> Bool) -> v -> Digit a -> v -> Split (Maybe (Digit a)) a +searchDigit _ vl (One a) vr = vl `seq` vr `seq` Split Nothing a Nothing +searchDigit p vl (Two a b) vr + | p va vb = Split Nothing a (Just (One b)) + | otherwise = Split (Just (One a)) b Nothing + where + va = vl `mappend` measure a + vb = measure b `mappend` vr +searchDigit p vl (Three a b c) vr + | p va vbc = Split Nothing a (Just (Two b c)) + | p vab vc = Split (Just (One a)) b (Just (One c)) + | otherwise = Split (Just (Two a b)) c Nothing + where + va = vl `mappend` measure a + vab = va `mappend` measure b + vbc = measure b `mappend` vc + vc = measure c `mappend` vr +searchDigit p vl (Four a b c d) vr + | p va vbcd = Split Nothing a (Just (Three b c d)) + | p vab vcd = Split (Just (One a)) b (Just (Two c d)) + | p vabc vd = Split (Just (Two a b)) c (Just (One d)) + | otherwise = Split (Just (Three a b c)) d Nothing + where + va = vl `mappend` measure a + vab = va `mappend` measure b + vabc = vab `mappend` measure c + vbcd = measure b `mappend` vcd + vcd = measure c `mappend` vd + vd = measure d `mappend` vr + -- | /O(log(min(i,n-i)))/. Split a sequence at a point where the predicate --- on the accumulated measure changes from 'False' to 'True'. +-- on the accumulated measure of the prefix 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/. @@ -738,18 +1021,13 @@ | 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 + Split l x r = splitNode p (vpr `mappend` measure 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 + vm = vpr `mappend` measure m deepL :: (Measured v a) => Maybe (Digit a) -> FingerTree v (Node v a) -> Digit a -> FingerTree v a @@ -761,8 +1039,8 @@ 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 :: (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 @@ -776,8 +1054,8 @@ 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 :: (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)) diff --git a/Data/IntervalMap/FingerTree.hs b/Data/IntervalMap/FingerTree.hs --- a/Data/IntervalMap/FingerTree.hs +++ b/Data/IntervalMap/FingerTree.hs @@ -35,7 +35,7 @@ module Data.IntervalMap.FingerTree ( -- * Intervals - Interval(..), point, + Interval(..), low, high, point, -- * Interval maps IntervalMap, empty, singleton, insert, union, -- * Searching @@ -45,25 +45,43 @@ import qualified Data.FingerTree as FT import Data.FingerTree (FingerTree, Measured(..), ViewL(..), (<|), (><)) +import Prelude hiding (null) +#if MIN_VERSION_base(4,8,0) +import qualified Prelude (null) +#else import Control.Applicative ((<$>)) -import Data.Traversable (Traversable(traverse)) import Data.Foldable (Foldable(foldMap)) import Data.Monoid +import Data.Traversable (Traversable(traverse)) +#endif +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup +#endif +import Data.Foldable (toList) ---------------------------------- -- 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 } +-- to the upper bound. +data Interval v = Interval v v -- ^ Lower and upper bounds of the interval. deriving (Eq, Ord, Show) +-- | Lower bound of the interval +low :: Interval v -> v +low (Interval lo _) = lo + +-- | Upper bound of the interval +high :: Interval v -> v +high (Interval _ hi) = hi + -- | 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 (Eq, Ord, Show) instance Functor (Node v) where fmap f (Node i x) = Node i (f x) @@ -77,19 +95,28 @@ -- rightmost interval (including largest lower bound) and largest upper bound. data IntInterval v = NoInterval | IntInterval (Interval v) v +#if MIN_VERSION_base(4,9,0) +instance Ord v => Semigroup (IntInterval v) where + (<>) = intervalUnion +#endif + 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) +#if !(MIN_VERSION_base(4,11,0)) + mappend = intervalUnion +#endif +intervalUnion :: Ord v => IntInterval v -> IntInterval v -> IntInterval v +NoInterval `intervalUnion` i = i +i `intervalUnion` NoInterval = i +IntInterval _ hi1 `intervalUnion` 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 @@ -97,17 +124,48 @@ instance Functor (IntervalMap v) where fmap f (IntervalMap t) = IntervalMap (FT.unsafeFmap (fmap f) t) +-- | Values in lexicographical order of intervals. instance Foldable (IntervalMap v) where foldMap f (IntervalMap t) = foldMap (foldMap f) t +#if MIN_VERSION_base(4,8,0) + null (IntervalMap t) = Prelude.null t +#endif +-- | Traverse the intervals in lexicographical order. instance Traversable (IntervalMap v) where traverse f (IntervalMap t) = IntervalMap <$> FT.unsafeTraverse (traverse f) t +instance (Eq v, Eq a) => Eq (IntervalMap v a) where + IntervalMap xs == IntervalMap ys = toList xs == toList ys + +-- | Lexicographical ordering +instance (Ord v, Ord a) => Ord (IntervalMap v a) where + compare (IntervalMap xs) (IntervalMap ys) = compare (toList xs) (toList ys) + +instance (Show v, Show a) => Show (IntervalMap v a) where + showsPrec p (IntervalMap ns) + | Prelude.null ns = showString "empty" + | otherwise = + showParen (p > 0) (showIntervals (toList ns)) + where + showIntervals [] = showString "empty" + showIntervals (Node i x:ixs) = + showString "insert " . shows i . showChar ' ' . shows x . + showString " $ " . showIntervals ixs + +#if MIN_VERSION_base(4,9,0) +-- | 'union'. +instance (Ord v) => Semigroup (IntervalMap v a) where + (<>) = union +#endif + -- | 'empty' and 'union'. instance (Ord v) => Monoid (IntervalMap v a) where mempty = empty +#if !(MIN_VERSION_base(4,11,0)) mappend = union +#endif -- | /O(1)/. The empty interval map. empty :: (Ord v) => IntervalMap v a diff --git a/Data/PriorityQueue/FingerTree.hs b/Data/PriorityQueue/FingerTree.hs --- a/Data/PriorityQueue/FingerTree.hs +++ b/Data/PriorityQueue/FingerTree.hs @@ -57,10 +57,18 @@ import qualified Data.FingerTree as FT import Data.FingerTree (FingerTree, (<|), (|>), (><), ViewL(..), Measured(..)) -import Control.Arrow ((***)) +import Prelude hiding (null) +#if MIN_VERSION_base(4,8,0) +import qualified Prelude (null) +#else import Data.Foldable (Foldable(foldMap)) import Data.Monoid -import Prelude hiding (null) +#endif +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup +#endif +import Control.Arrow ((***)) +import Data.List (unfoldr) data Entry k v = Entry k v @@ -72,14 +80,24 @@ data Prio k v = NoPrio | Prio k v +#if MIN_VERSION_base(4,9,0) +instance Ord k => Semigroup (Prio k v) where + (<>) = unionPrio +#endif + 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 + mempty = NoPrio +#if !(MIN_VERSION_base(4,11,0)) + mappend = unionPrio +#endif +unionPrio :: Ord k => Prio k v -> Prio k v -> Prio k v +x `unionPrio` NoPrio = x +NoPrio `unionPrio` y = y +x@(Prio kx _) `unionPrio` 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 @@ -89,15 +107,39 @@ instance Ord k => Functor (PQueue k) where fmap f (PQueue xs) = PQueue (FT.fmap' (fmap f) xs) +-- | In ascending order of keys. 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' +#if MIN_VERSION_base(4,8,0) + null (PQueue q) = Prelude.null q +#endif +#if MIN_VERSION_base(4,9,0) +instance Ord k => Semigroup (PQueue k v) where + (<>) = union +#endif + +-- | 'empty' and 'union' instance Ord k => Monoid (PQueue k v) where mempty = empty +#if !(MIN_VERSION_base(4,11,0)) mappend = union +#endif +instance (Ord k, Eq v) => Eq (PQueue k v) where + xs == ys = assocs xs == assocs ys + +-- | Lexicographical ordering +instance (Ord k, Ord v) => Ord (PQueue k v) where + compare xs ys = compare (assocs xs) (assocs ys) + +-- | In ascending key order +instance (Ord k, Show k, Show v) => Show (PQueue k v) where + showsPrec p xs = showParen (p > 10) $ + showString "fromList " . shows (assocs xs) + -- | /O(1)/. The empty priority queue. empty :: Ord k => PQueue k v empty = PQueue FT.empty @@ -168,7 +210,7 @@ -- minViewWithKey :: Ord k => PQueue k v -> Maybe ((k, v), PQueue k v) minViewWithKey (PQueue q) - | FT.null q = Nothing + | Prelude.null q = Nothing | otherwise = Just ((k, v), case FT.viewl r of _ :< r' -> PQueue (l >< r') _ -> error "can't happen") @@ -179,3 +221,7 @@ below :: Ord k => k -> Prio k v -> Bool below _ NoPrio = False below k (Prio k' _) = k' <= k + +-- | /O(n)/. Key-value pairs in ascending key order. +assocs :: Ord k => PQueue k v -> [(k, v)] +assocs = unfoldr minViewWithKey diff --git a/changelog b/changelog new file mode 100644 --- /dev/null +++ b/changelog @@ -0,0 +1,33 @@ +-*-change-log-*- + +0.1.2.0 Ross Paterson Oct 2017 + * Removed constraint on the type of null + * Added versions of fmap and traverse passing the measures of both sides + * Added new search function, a symmetrical generalization of split + * Added Eq, Ord and Show instances for IntervalMap and PriorityQueue + * Made low and high into separate functions + * Updated for Monoid, Foldable, Traversable in Prelude + * Made compatible with Semigroup/Monoid proposal + +0.1.1.0 Ross Paterson Jun 2015 + * Added Safe for GHC >= 7.2 + * Added AutoDeriveTypeable for GHC >= 7.10 + +0.1.0.2 Ross Paterson Mar 2015 + * Cabal file updates + +0.1.0.1 Ross Paterson Feb 2015 + * fix warnings + +0.1.0.0 Ross Paterson Jun 2013 + * Added Monoid instance for IntervalMap + * Removed unnecessary Measured v a constraints on Eq, Ord, and Show instances + +0.0.1.1 Ross Paterson Sep 2012 + * Cabal file updates + +0.0.1.0 Ross Paterson Jul 2009 + * Added Data.IntervalMap.FingerTree and Data.PriorityQueue.FingerTree + +0.0 Ross Paterson May 2007 + * Initial revision diff --git a/fingertree.cabal b/fingertree.cabal --- a/fingertree.cabal +++ b/fingertree.cabal @@ -1,6 +1,6 @@ Name: fingertree -Version: 0.1.1.0 -Cabal-Version: >= 1.8 +Version: 0.1.2.0 +Cabal-Version: >= 1.18 Copyright: (c) 2006 Ross Paterson, Ralf Hinze License: BSD3 License-File: LICENSE @@ -23,6 +23,10 @@ @containers@ package, which is a specialization of this structure. Build-Type: Simple +Extra-Source-Files: + changelog +Extra-Doc-Files: + images/search.svg Source-Repository head Type: darcs @@ -30,7 +34,9 @@ Library Build-Depends: base < 6 - Extensions: MultiParamTypeClasses + Default-Language: Haskell2010 + Other-Extensions: + MultiParamTypeClasses FunctionalDependencies FlexibleInstances UndecidableInstances @@ -43,6 +49,7 @@ type: exitcode-stdio-1.0 main-is: tests/ft-properties.hs cpp-options: -DTESTING + default-language: Haskell2010 build-depends: base >= 4.2 && < 6, HUnit, diff --git a/images/search.svg b/images/search.svg new file mode 100644 --- /dev/null +++ b/images/search.svg @@ -0,0 +1,53 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + l + x + r + measure l + measure (x <| r) + measure (l |> x) + measure r + + + + + + p + False + True + + +