{-
Copyright 2013-2019 Mario Blazevic
License: BSD3 (see BSD3-LICENSE.txt file)
-}
-- | This module defines the 'OverlappingGCDMonoid' => 'Monus' subclass of the 'Monoid' class.
--
-- @since 1.0
{-# LANGUAGE Haskell2010, FlexibleInstances, Trustworthy #-}
module Data.Monoid.Monus (
Monus(..), OverlappingGCDMonoid(..)
)
where
import Data.Monoid -- (Monoid, Dual(..), Sum(..), Product(..))
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Lazy as LazyByteString
import qualified Data.Text as Text
import qualified Data.Text.Lazy as LazyText
import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import qualified Data.Map as Map
import qualified Data.Sequence as Sequence
import qualified Data.Set as Set
import Data.Sequence (ViewL((:<)), (|>))
import qualified Data.Vector as Vector
import Numeric.Natural (Natural)
import Data.Semigroup.Cancellative
import Data.Monoid.Null (MonoidNull(null))
import Prelude hiding (null)
-- | Class of Abelian monoids with monus. The monus operation '<\>' is a synonym for both 'stripPrefixOverlap' and
-- 'stripSuffixOverlap', which must be equivalent as '<>' is both associative and commutative:
--
-- > (<\>) = flip stripPrefixOverlap
-- > (<\>) = flip stripSuffixOverlap
--
-- @since 1.0
class (Commutative m, Monoid m, OverlappingGCDMonoid m) => Monus m where
(<\>) :: m -> m -> m
infix 5 <\>
-- | Class of monoids for which the greatest overlap can be found between any two values, such that
--
-- > a == a' <> overlap a b
-- > b == overlap a b <> b'
--
-- The methods must satisfy the following laws:
--
-- > stripOverlap a b == (stripSuffixOverlap b a, overlap a b, stripPrefixOverlap a b)
-- > stripSuffixOverlap b a <> overlap a b == a
-- > overlap a b <> stripPrefixOverlap a b == b
--
-- The result of @overlap a b@ must be the largest prefix of @b@ and suffix of @a@, in the sense that it is contained
-- in any other value @x@ that satifies the property @(x `isPrefixOf` b) && (x `isSuffixOf` a)@:
--
-- > (x `isPrefixOf` overlap a b) && (x `isSuffixOf` overlap a b)
--
-- and it must be unique so it's not contained in any other value @y@ that satisfies the same property @(y
-- `isPrefixOf` b) && (y `isSuffixOf` a)@:
--
-- > not ((y `isPrefixOf` overlap a b) && (y `isSuffixOf` overlap a b) && y /= overlap a b)
--
-- @since 1.0
class (Monoid m, LeftReductive m, RightReductive m) => OverlappingGCDMonoid m where
stripPrefixOverlap :: m -> m -> m
stripSuffixOverlap :: m -> m -> m
overlap :: m -> m -> m
stripOverlap :: m -> m -> (m, m, m)
stripPrefixOverlap a b = b'
where (_, _, b') = stripOverlap a b
stripSuffixOverlap a b = b'
where (b', _, _) = stripOverlap b a
overlap a b = o
where (_, o, _) = stripOverlap a b
{-# MINIMAL stripOverlap #-}
-- Unit instances
-- | /O(1)/
instance Monus () where
() <\> () = ()
-- | /O(1)/
instance OverlappingGCDMonoid () where
overlap () () = ()
stripOverlap () () = ((), (), ())
stripPrefixOverlap () () = ()
stripSuffixOverlap () () = ()
-- Dual instances
instance Monus a => Monus (Dual a) where
Dual a <\> Dual b = Dual (a <\> b)
instance OverlappingGCDMonoid a => OverlappingGCDMonoid (Dual a) where
overlap (Dual a) (Dual b) = Dual (overlap b a)
stripOverlap (Dual a) (Dual b) = (Dual s, Dual o, Dual p)
where (p, o, s) = stripOverlap b a
stripPrefixOverlap (Dual a) (Dual b) = Dual (stripSuffixOverlap a b)
stripSuffixOverlap (Dual a) (Dual b) = Dual (stripPrefixOverlap a b)
-- Sum instances
-- | /O(1)/
instance Monus (Sum Natural) where
Sum a <\> Sum b
| a > b = Sum (a - b)
| otherwise = Sum 0
-- | /O(1)/
instance OverlappingGCDMonoid (Sum Natural) where
overlap (Sum a) (Sum b) = Sum (min a b)
stripOverlap (Sum a) (Sum b) = (Sum $ a - c, Sum c, Sum $ b - c)
where c = min a b
stripPrefixOverlap = flip (<\>)
stripSuffixOverlap = flip (<\>)
-- Product instances
-- | /O(1)/
instance Monus (Product Natural) where
Product 0 <\> Product 0 = Product 1
Product a <\> Product b = Product (a `div` Prelude.gcd a b)
-- | /O(1)/
instance OverlappingGCDMonoid (Product Natural) where
overlap (Product a) (Product b) = Product (gcd a b)
stripOverlap (Product 0) (Product 0) = (Product 1, Product 0, Product 1)
stripOverlap (Product a) (Product b) = (Product $ div a c, Product c, Product $ div b c)
where c = gcd a b
stripPrefixOverlap = flip (<\>)
stripSuffixOverlap = flip (<\>)
-- Pair instances
instance (Monus a, Monus b) => Monus (a, b) where
(a1, b1) <\> (a2, b2) = (a1 <\> a2, b1 <\> b2)
instance (OverlappingGCDMonoid a, OverlappingGCDMonoid b) => OverlappingGCDMonoid (a, b) where
overlap (a1, b1) (a2, b2) = (overlap a1 a2, overlap b1 b2)
stripOverlap (a1, b1) (a2, b2) = ((ap, bp), (ao, bo), (as, bs))
where (ap, ao, as) = stripOverlap a1 a2
(bp, bo, bs) = stripOverlap b1 b2
stripPrefixOverlap (a1, b1) (a2, b2) = (stripPrefixOverlap a1 a2, stripPrefixOverlap b1 b2)
stripSuffixOverlap (a1, b1) (a2, b2) = (stripSuffixOverlap a1 a2, stripSuffixOverlap b1 b2)
-- Triple instances
instance (Monus a, Monus b, Monus c) => Monus (a, b, c) where
(a1, b1, c1) <\> (a2, b2, c2) = (a1 <\> a2, b1 <\> b2, c1 <\> c2)
instance (OverlappingGCDMonoid a, OverlappingGCDMonoid b, OverlappingGCDMonoid c) =>
OverlappingGCDMonoid (a, b, c) where
overlap (a1, b1, c1) (a2, b2, c2) = (overlap a1 a2, overlap b1 b2, overlap c1 c2)
stripOverlap (a1, b1, c1) (a2, b2, c2) = ((ap, bp, cp), (ao, bo, co), (as, bs, cs))
where (ap, ao, as) = stripOverlap a1 a2
(bp, bo, bs) = stripOverlap b1 b2
(cp, co, cs) = stripOverlap c1 c2
stripPrefixOverlap (a1, b1, c1) (a2, b2, c2) = (stripPrefixOverlap a1 a2, stripPrefixOverlap b1 b2, stripPrefixOverlap c1 c2)
stripSuffixOverlap (a1, b1, c1) (a2, b2, c2) = (stripSuffixOverlap a1 a2, stripSuffixOverlap b1 b2, stripSuffixOverlap c1 c2)
-- Quadruple instances
instance (Monus a, Monus b, Monus c, Monus d) => Monus (a, b, c, d) where
(a1, b1, c1, d1) <\> (a2, b2, c2, d2) = (a1 <\> a2, b1 <\> b2, c1 <\> c2, d1 <\> d2)
instance (OverlappingGCDMonoid a, OverlappingGCDMonoid b, OverlappingGCDMonoid c, OverlappingGCDMonoid d) =>
OverlappingGCDMonoid (a, b, c, d) where
overlap (a1, b1, c1, d1) (a2, b2, c2, d2) = (overlap a1 a2, overlap b1 b2, overlap c1 c2, overlap d1 d2)
stripOverlap (a1, b1, c1, d1) (a2, b2, c2, d2) = ((ap, bp, cp, dp), (ao, bo, co, dm), (as, bs, cs, ds))
where (ap, ao, as) = stripOverlap a1 a2
(bp, bo, bs) = stripOverlap b1 b2
(cp, co, cs) = stripOverlap c1 c2
(dp, dm, ds) = stripOverlap d1 d2
stripPrefixOverlap (a1, b1, c1, d1) (a2, b2, c2, d2) =
(stripPrefixOverlap a1 a2, stripPrefixOverlap b1 b2, stripPrefixOverlap c1 c2, stripPrefixOverlap d1 d2)
stripSuffixOverlap (a1, b1, c1, d1) (a2, b2, c2, d2) =
(stripSuffixOverlap a1 a2, stripSuffixOverlap b1 b2, stripSuffixOverlap c1 c2, stripSuffixOverlap d1 d2)
-- Maybe instances
instance (Monus a, MonoidNull a) => Monus (Maybe a) where
Just a <\> Just b = Just (a <\> b)
Nothing <\> _ = Nothing
x <\> Nothing = x
instance (OverlappingGCDMonoid a, MonoidNull a) => OverlappingGCDMonoid (Maybe a) where
overlap (Just a) (Just b) = Just (overlap a b)
overlap _ _ = Nothing
stripOverlap (Just a) (Just b) = (Just a', Just o, Just b')
where (a', o, b') = stripOverlap a b
stripOverlap a b = (a, Nothing, b)
stripPrefixOverlap (Just a) (Just b)
| null b' = Nothing
| otherwise = Just b'
where b' = stripPrefixOverlap a b
stripPrefixOverlap Nothing x = x
stripPrefixOverlap _ Nothing = Nothing
stripSuffixOverlap (Just a) (Just b)
| null b' = Nothing
| otherwise = Just b'
where b' = stripSuffixOverlap a b
stripSuffixOverlap Nothing x = x
stripSuffixOverlap _ Nothing = Nothing
-- Set instances
-- | /O(m*log(n/m + 1)), m <= n/
instance Ord a => Monus (Set.Set a) where
(<\>) = (Set.\\)
-- | /O(m*log(n/m + 1)), m <= n/
instance Ord a => OverlappingGCDMonoid (Set.Set a) where
overlap = Set.intersection
stripOverlap a b = (Set.difference a b, Set.intersection a b, Set.difference b a)
stripPrefixOverlap a b = b <\> a
stripSuffixOverlap a b = b <\> a
-- IntSet instances
-- | /O(m+n)/
instance Monus IntSet.IntSet where
(<\>) = (IntSet.\\)
-- | /O(m+n)/
instance OverlappingGCDMonoid IntSet.IntSet where
overlap = IntSet.intersection
stripOverlap a b = (IntSet.difference a b, IntSet.intersection a b, IntSet.difference b a)
stripPrefixOverlap a b = b <\> a
stripSuffixOverlap a b = b <\> a
-- Map instances
-- | /O(m+n)/
instance (Ord k, Eq v) => OverlappingGCDMonoid (Map.Map k v) where
overlap = Map.intersection
stripOverlap a b = (stripPrefixOverlap b a, overlap a b, stripSuffixOverlap a b)
stripPrefixOverlap = flip Map.difference
stripSuffixOverlap a b = Map.differenceWith (\x y-> if x == y then Nothing else Just x) b a
-- IntMap instances
-- | /O(m+n)/
instance Eq a => OverlappingGCDMonoid (IntMap.IntMap a) where
overlap = IntMap.intersection
stripOverlap a b = (stripPrefixOverlap b a, overlap a b, stripSuffixOverlap a b)
stripPrefixOverlap = flip IntMap.difference
stripSuffixOverlap a b = IntMap.differenceWith (\x y-> if x == y then Nothing else Just x) b a
-- List instances
-- | /O(m*n)/
instance Eq a => OverlappingGCDMonoid [a] where
overlap a b = go a
where go x | x `isPrefixOf` b = x
| otherwise = go (tail x)
stripOverlap a b = go [] a
where go p o | Just s <- stripPrefix o b = (reverse p, o, s)
| x:xs <- o = go (x:p) xs
| otherwise = error "impossible"
stripPrefixOverlap a b = go a
where go x | Just s <- stripPrefix x b = s
| otherwise = go (tail x)
-- Seq instances
-- | /O(min(m,n)^2)/
instance Eq a => OverlappingGCDMonoid (Sequence.Seq a) where
overlap a b = go (Sequence.drop (Sequence.length a - Sequence.length b) a)
where go x | x `isPrefixOf` b = x
| _ :< x' <- Sequence.viewl x = go x'
| otherwise = error "impossible"
stripOverlap a b = uncurry go (Sequence.splitAt (Sequence.length a - Sequence.length b) a)
where go p o | Just s <- stripPrefix o b = (p, o, s)
| x :< xs <- Sequence.viewl o = go (p |> x) xs
| otherwise = error "impossible"
-- Vector instances
-- | /O(min(m,n)^2)/
instance Eq a => OverlappingGCDMonoid (Vector.Vector a) where
stripOverlap a b = go (max alen blen)
where alen = Vector.length a
blen = Vector.length b
go i | as == bp = (ap, as, bs)
| otherwise = go (pred i)
where (ap, as) = Vector.splitAt (alen - i) a
(bp, bs) = Vector.splitAt i b
-- ByteString instances
-- | /O(min(m,n)^2)/
instance OverlappingGCDMonoid ByteString.ByteString where
stripOverlap a b = go (max alen blen)
where alen = ByteString.length a
blen = ByteString.length b
go i | as == bp = (ap, as, bs)
| otherwise = go (pred i)
where (ap, as) = ByteString.splitAt (alen - i) a
(bp, bs) = ByteString.splitAt i b
-- Lazy ByteString instances
-- | /O(m*n)/
instance OverlappingGCDMonoid LazyByteString.ByteString where
stripOverlap a b = go (max alen blen)
where alen = LazyByteString.length a
blen = LazyByteString.length b
go i | as == bp = (ap, as, bs)
| otherwise = go (pred i)
where (ap, as) = LazyByteString.splitAt (alen - i) a
(bp, bs) = LazyByteString.splitAt i b
-- Text instances
-- | /O(min(m,n)^2)/
instance OverlappingGCDMonoid Text.Text where
stripOverlap a b
| Text.null b = (a, b, b)
| otherwise = go (Text.breakOnAll (Text.take 1 b) a)
where go [] = (a, mempty, b)
go ((ap, as):breaks)
| Just bs <- Text.stripPrefix as b = (ap, as, bs)
| otherwise = go breaks
-- Lazy Text instances
-- | /O(m*n)/
instance OverlappingGCDMonoid LazyText.Text where
stripOverlap a b
| LazyText.null b = (a, b, b)
| otherwise = go (LazyText.breakOnAll (LazyText.take 1 b) a)
where go [] = (a, mempty, b)
go ((ap, as):breaks)
| Just bs <- LazyText.stripPrefix as b = (ap, as, bs)
| otherwise = go breaks