{- 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