{-
Copyright 2013-2019 Mario Blazevic
License: BSD3 (see BSD3-LICENSE.txt file)
-}
-- | This module defines the 'GCDMonoid' subclass of the 'Monoid' class.
--
-- The 'GCDMonoid' subclass adds the 'gcd' operation which takes two monoidal arguments and finds their greatest
-- common divisor, or (more generally) the greatest monoid that can be extracted with the '</>' operation from both.
--
-- The 'GCDMonoid' class is for Abelian, /i.e./, 'Commutative' monoids. Since most practical monoids in Haskell are not
-- Abelian, there are also its three symmetric superclasses:
--
-- * 'LeftGCDMonoid'
--
-- * 'RightGCDMonoid'
--
-- * 'OverlappingGCDMonoid'
{-# LANGUAGE Haskell2010, FlexibleInstances, Trustworthy #-}
module Data.Monoid.GCD (
GCDMonoid(..),
LeftGCDMonoid(..), RightGCDMonoid(..), OverlappingGCDMonoid(..)
)
where
import qualified Prelude
import Data.Monoid -- (Monoid, Dual(..), Sum(..), Product(..))
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Unsafe as ByteString
import qualified Data.ByteString.Lazy as LazyByteString
import qualified Data.Text as Text
import qualified Data.Text.Internal as Internal
import qualified Data.Text.Internal.Lazy as LazyInternal
import Data.Text.Unsafe (lengthWord16, reverseIter)
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((:<)), ViewR((:>)), (<|), (|>))
import qualified Data.Vector as Vector
import Numeric.Natural (Natural)
import Data.Semigroup.Cancellative
import Data.Monoid.Monus
import Prelude hiding (gcd)
-- | Class of Abelian monoids that allow the greatest common divisor to be found for any two given values. The
-- operations must satisfy the following laws:
--
-- > gcd a b == commonPrefix a b == commonSuffix a b
-- > Just a' = a </> p && Just b' = b </> p
-- > where p = gcd a b
--
-- If a 'GCDMonoid' happens to also be 'Cancellative', it should additionally satisfy the following laws:
--
-- > gcd (a <> b) (a <> c) == a <> gcd b c
-- > gcd (a <> c) (b <> c) == gcd a b <> c
class (Monoid m, Commutative m, Reductive m, LeftGCDMonoid m, RightGCDMonoid m, OverlappingGCDMonoid m) => GCDMonoid m where
gcd :: m -> m -> m
-- | Class of monoids capable of finding the equivalent of greatest common divisor on the left side of two monoidal
-- values. The following laws must be respected:
--
-- > stripCommonPrefix a b == (p, a', b')
-- > where p = commonPrefix a b
-- > Just a' = stripPrefix p a
-- > Just b' = stripPrefix p b
-- > p == commonPrefix a b && p <> a' == a && p <> b' == b
-- > where (p, a', b') = stripCommonPrefix a b
--
-- Furthermore, 'commonPrefix' must return the unique greatest common prefix that contains, as its prefix, any other
-- prefix @x@ of both values:
--
-- > not (x `isPrefixOf` a && x `isPrefixOf` b) || x `isPrefixOf` commonPrefix a b
--
-- and it cannot itself be a suffix of any other common prefix @y@ of both values:
--
-- > not (y `isPrefixOf` a && y `isPrefixOf` b && commonPrefix a b `isSuffixOf` y)
class (Monoid m, LeftReductive m) => LeftGCDMonoid m where
commonPrefix :: m -> m -> m
stripCommonPrefix :: m -> m -> (m, m, m)
commonPrefix x y = p
where (p, _, _) = stripCommonPrefix x y
stripCommonPrefix x y = (p, x', y')
where p = commonPrefix x y
Just x' = stripPrefix p x
Just y' = stripPrefix p y
{-# MINIMAL commonPrefix | stripCommonPrefix #-}
-- | Class of monoids capable of finding the equivalent of greatest common divisor on the right side of two monoidal
-- values. The following laws must be respected:
--
-- > stripCommonSuffix a b == (a', b', s)
-- > where s = commonSuffix a b
-- > Just a' = stripSuffix p a
-- > Just b' = stripSuffix p b
-- > s == commonSuffix a b && a' <> s == a && b' <> s == b
-- > where (a', b', s) = stripCommonSuffix a b
--
-- Furthermore, 'commonSuffix' must return the unique greatest common suffix that contains, as its suffix, any other
-- suffix @x@ of both values:
--
-- > not (x `isSuffixOf` a && x `isSuffixOf` b) || x `isSuffixOf` commonSuffix a b
--
-- and it cannot itself be a prefix of any other common suffix @y@ of both values:
--
-- > not (y `isSuffixOf` a && y `isSuffixOf` b && commonSuffix a b `isPrefixOf` y)
class (Monoid m, RightReductive m) => RightGCDMonoid m where
commonSuffix :: m -> m -> m
stripCommonSuffix :: m -> m -> (m, m, m)
commonSuffix x y = s
where (_, _, s) = stripCommonSuffix x y
stripCommonSuffix x y = (x', y', s)
where s = commonSuffix x y
Just x' = stripSuffix s x
Just y' = stripSuffix s y
{-# MINIMAL commonSuffix | stripCommonSuffix #-}
-- Unit instances
-- | /O(1)/
instance GCDMonoid () where
gcd () () = ()
-- | /O(1)/
instance LeftGCDMonoid () where
commonPrefix () () = ()
-- | /O(1)/
instance RightGCDMonoid () where
commonSuffix () () = ()
-- Dual instances
instance GCDMonoid a => GCDMonoid (Dual a) where
gcd (Dual a) (Dual b) = Dual (gcd a b)
instance LeftGCDMonoid a => RightGCDMonoid (Dual a) where
commonSuffix (Dual a) (Dual b) = Dual (commonPrefix a b)
instance RightGCDMonoid a => LeftGCDMonoid (Dual a) where
commonPrefix (Dual a) (Dual b) = Dual (commonSuffix a b)
-- Sum instances
-- | /O(1)/
instance GCDMonoid (Sum Natural) where
gcd (Sum a) (Sum b) = Sum (min a b)
-- | /O(1)/
instance LeftGCDMonoid (Sum Natural) where
commonPrefix a b = gcd a b
-- | /O(1)/
instance RightGCDMonoid (Sum Natural) where
commonSuffix a b = gcd a b
-- Product instances
-- | /O(1)/
instance GCDMonoid (Product Natural) where
gcd (Product a) (Product b) = Product (Prelude.gcd a b)
-- | /O(1)/
instance LeftGCDMonoid (Product Natural) where
commonPrefix a b = gcd a b
-- | /O(1)/
instance RightGCDMonoid (Product Natural) where
commonSuffix a b = gcd a b
-- Pair instances
instance (GCDMonoid a, GCDMonoid b) => GCDMonoid (a, b) where
gcd (a, b) (c, d) = (gcd a c, gcd b d)
instance (LeftGCDMonoid a, LeftGCDMonoid b) => LeftGCDMonoid (a, b) where
commonPrefix (a, b) (c, d) = (commonPrefix a c, commonPrefix b d)
instance (RightGCDMonoid a, RightGCDMonoid b) => RightGCDMonoid (a, b) where
commonSuffix (a, b) (c, d) = (commonSuffix a c, commonSuffix b d)
-- Triple instances
instance (GCDMonoid a, GCDMonoid b, GCDMonoid c) => GCDMonoid (a, b, c) where
gcd (a1, b1, c1) (a2, b2, c2) = (gcd a1 a2, gcd b1 b2, gcd c1 c2)
instance (LeftGCDMonoid a, LeftGCDMonoid b, LeftGCDMonoid c) => LeftGCDMonoid (a, b, c) where
commonPrefix (a1, b1, c1) (a2, b2, c2) = (commonPrefix a1 a2, commonPrefix b1 b2, commonPrefix c1 c2)
instance (RightGCDMonoid a, RightGCDMonoid b, RightGCDMonoid c) => RightGCDMonoid (a, b, c) where
commonSuffix (a1, b1, c1) (a2, b2, c2) = (commonSuffix a1 a2, commonSuffix b1 b2, commonSuffix c1 c2)
-- Quadruple instances
instance (GCDMonoid a, GCDMonoid b, GCDMonoid c, GCDMonoid d) => GCDMonoid (a, b, c, d) where
gcd (a1, b1, c1, d1) (a2, b2, c2, d2) = (gcd a1 a2, gcd b1 b2, gcd c1 c2, gcd d1 d2)
instance (LeftGCDMonoid a, LeftGCDMonoid b, LeftGCDMonoid c, LeftGCDMonoid d) => LeftGCDMonoid (a, b, c, d) where
commonPrefix (a1, b1, c1, d1) (a2, b2, c2, d2) =
(commonPrefix a1 a2, commonPrefix b1 b2, commonPrefix c1 c2, commonPrefix d1 d2)
instance (RightGCDMonoid a, RightGCDMonoid b, RightGCDMonoid c, RightGCDMonoid d) => RightGCDMonoid (a, b, c, d) where
commonSuffix (a1, b1, c1, d1) (a2, b2, c2, d2) =
(commonSuffix a1 a2, commonSuffix b1 b2, commonSuffix c1 c2, commonSuffix d1 d2)
-- Maybe instances
instance LeftGCDMonoid x => LeftGCDMonoid (Maybe x) where
commonPrefix (Just x) (Just y) = Just (commonPrefix x y)
commonPrefix _ _ = Nothing
stripCommonPrefix (Just x) (Just y) = (Just p, Just x', Just y')
where (p, x', y') = stripCommonPrefix x y
stripCommonPrefix x y = (Nothing, x, y)
instance RightGCDMonoid x => RightGCDMonoid (Maybe x) where
commonSuffix (Just x) (Just y) = Just (commonSuffix x y)
commonSuffix _ _ = Nothing
stripCommonSuffix (Just x) (Just y) = (Just x', Just y', Just s)
where (x', y', s) = stripCommonSuffix x y
stripCommonSuffix x y = (x, y, Nothing)
-- Set instances
-- | /O(m*log(n\/m + 1)), m <= n/
instance Ord a => LeftGCDMonoid (Set.Set a) where
commonPrefix = Set.intersection
-- | /O(m*log(n\/m + 1)), m <= n/
instance Ord a => RightGCDMonoid (Set.Set a) where
commonSuffix = Set.intersection
-- | /O(m*log(n\/m + 1)), m <= n/
instance Ord a => GCDMonoid (Set.Set a) where
gcd = Set.intersection
-- IntSet instances
-- | /O(m+n)/
instance LeftGCDMonoid IntSet.IntSet where
commonPrefix = IntSet.intersection
-- | /O(m+n)/
instance RightGCDMonoid IntSet.IntSet where
commonSuffix = IntSet.intersection
-- | /O(m+n)/
instance GCDMonoid IntSet.IntSet where
gcd = IntSet.intersection
-- Map instances
-- | /O(m+n)/
instance (Ord k, Eq a) => LeftGCDMonoid (Map.Map k a) where
commonPrefix = Map.mergeWithKey (\_ a b -> if a == b then Just a else Nothing) (const Map.empty) (const Map.empty)
-- IntMap instances
-- | /O(m+n)/
instance Eq a => LeftGCDMonoid (IntMap.IntMap a) where
commonPrefix = IntMap.mergeWithKey (\_ a b -> if a == b then Just a else Nothing)
(const IntMap.empty) (const IntMap.empty)
-- List instances
-- | /O(prefixLength)/
instance Eq x => LeftGCDMonoid [x] where
commonPrefix (x:xs) (y:ys) | x == y = x : commonPrefix xs ys
commonPrefix _ _ = []
stripCommonPrefix x0 y0 = strip' id x0 y0
where strip' f (x:xs) (y:ys) | x == y = strip' (f . (x :)) xs ys
strip' f x y = (f [], x, y)
-- | @since 1.0
-- /O(m+n)/
instance Eq x => RightGCDMonoid [x] where
stripCommonSuffix x0 y0 = go1 x0 y0
where go1 (_:xs) (_:ys) = go1 xs ys
go1 [] [] = go2 id id id x0 y0
go1 [] ys = go2 id yp id x0 yr
where (yp, yr) = splitAtLengthOf id ys y0
go1 xs [] = go2 xp id id xr y0
where (xp, xr) = splitAtLengthOf id xs x0
go2 xp yp cs [] [] = (xp [], yp [], cs [])
go2 xp yp cs (x:xs) (y:ys)
| x == y = go2 xp yp (cs . (x:)) xs ys
| otherwise = go2 (xp . cs . (x:)) (yp . cs . (y:)) id xs ys
go2 _ _ _ _ _ = error "impossible"
splitAtLengthOf yp (_:xs) (y:ys) = splitAtLengthOf (yp . (y:)) xs ys
splitAtLengthOf yp [] ys = (yp, ys)
splitAtLengthOf _ _ _ = error "impossible"
-- Seq instances
-- | /O(prefixLength)/
instance Eq a => LeftGCDMonoid (Sequence.Seq a) where
stripCommonPrefix = findCommonPrefix Sequence.empty
where findCommonPrefix prefix a b = case (Sequence.viewl a, Sequence.viewl b)
of (a1:<a', b1:<b') | a1 == b1 -> findCommonPrefix (prefix |> a1) a' b'
_ -> (prefix, a, b)
-- | /O(suffixLength)/
instance Eq a => RightGCDMonoid (Sequence.Seq a) where
stripCommonSuffix = findCommonSuffix Sequence.empty
where findCommonSuffix suffix a b = case (Sequence.viewr a, Sequence.viewr b)
of (a':>a1, b':>b1) | a1 == b1 -> findCommonSuffix (a1 <| suffix) a' b'
_ -> (a, b, suffix)
-- Vector instances
-- | /O(prefixLength)/
instance Eq a => LeftGCDMonoid (Vector.Vector a) where
stripCommonPrefix x y = (xp, xs, Vector.drop maxPrefixLength y)
where maxPrefixLength = prefixLength 0 (Vector.length x `min` Vector.length y)
prefixLength n len | n < len && x Vector.! n == y Vector.! n = prefixLength (succ n) len
prefixLength n _ = n
(xp, xs) = Vector.splitAt maxPrefixLength x
-- | /O(suffixLength)/
instance Eq a => RightGCDMonoid (Vector.Vector a) where
stripCommonSuffix x y = findSuffix (Vector.length x - 1) (Vector.length y - 1)
where findSuffix m n | m >= 0 && n >= 0 && x Vector.! m == y Vector.! n =
findSuffix (pred m) (pred n)
findSuffix m n = (Vector.take (succ m) x, yp, ys)
where (yp, ys) = Vector.splitAt (succ n) y
-- ByteString instances
-- | /O(prefixLength)/
instance LeftGCDMonoid ByteString.ByteString where
stripCommonPrefix x y = (xp, xs, ByteString.unsafeDrop maxPrefixLength y)
where maxPrefixLength = prefixLength 0 (ByteString.length x `min` ByteString.length y)
prefixLength n len | n < len,
ByteString.unsafeIndex x n == ByteString.unsafeIndex y n =
prefixLength (succ n) len
| otherwise = n
(xp, xs) = ByteString.splitAt maxPrefixLength x
-- | /O(suffixLength)/
instance RightGCDMonoid ByteString.ByteString where
stripCommonSuffix x y = findSuffix (ByteString.length x - 1) (ByteString.length y - 1)
where findSuffix m n | m >= 0, n >= 0,
ByteString.unsafeIndex x m == ByteString.unsafeIndex y n =
findSuffix (pred m) (pred n)
| otherwise = let (yp, ys) = ByteString.splitAt (succ n) y
in (ByteString.unsafeTake (succ m) x, yp, ys)
-- Lazy ByteString instances
-- | /O(prefixLength)/
instance LeftGCDMonoid LazyByteString.ByteString where
stripCommonPrefix x y = (xp, xs, LazyByteString.drop maxPrefixLength y)
where maxPrefixLength = prefixLength 0 (LazyByteString.length x `min` LazyByteString.length y)
prefixLength n len | n < len && LazyByteString.index x n == LazyByteString.index y n =
prefixLength (succ n) len
prefixLength n _ = n
(xp, xs) = LazyByteString.splitAt maxPrefixLength x
-- | /O(suffixLength)/
instance RightGCDMonoid LazyByteString.ByteString where
stripCommonSuffix x y = findSuffix (LazyByteString.length x - 1) (LazyByteString.length y - 1)
where findSuffix m n | m >= 0 && n >= 0 && LazyByteString.index x m == LazyByteString.index y n =
findSuffix (pred m) (pred n)
findSuffix m n = (LazyByteString.take (succ m) x, yp, ys)
where (yp, ys) = LazyByteString.splitAt (succ n) y
-- Text instances
-- | /O(prefixLength)/
instance LeftGCDMonoid Text.Text where
stripCommonPrefix x y = maybe (Text.empty, x, y) id (Text.commonPrefixes x y)
-- | @since 1.0
-- /O(suffixLength)/
instance RightGCDMonoid Text.Text where
stripCommonSuffix x@(Internal.Text xarr xoff xlen) y@(Internal.Text yarr yoff ylen) = go (pred xlen) (pred ylen)
where go i j | i >= 0 && j >= 0 && xc == yc = go (i+xd) (j+yd)
| otherwise = (Internal.text xarr xoff (succ i),
Internal.text yarr yoff (succ j),
Internal.text xarr (xoff+i+1) (xlen-i-1))
where (xc, xd) = reverseIter x i
(yc, yd) = reverseIter y j
-- Lazy Text instances
-- | /O(prefixLength)/
instance LeftGCDMonoid LazyText.Text where
stripCommonPrefix x y = maybe (LazyText.empty, x, y) id (LazyText.commonPrefixes x y)
-- | @since 1.0
-- /O(m+n)/
instance RightGCDMonoid LazyText.Text where
stripCommonSuffix x0 y0
| x0len < y0len = go id y0p id x0 y0s
| x0len > y0len = go x0p id id x0s y0
| otherwise = go id id id x0 y0
where (y0p, y0s) = splitWord16 id (y0len - x0len) y0
(x0p, x0s) = splitWord16 id (x0len - y0len) x0
x0len = lazyLengthWord16 x0
y0len = lazyLengthWord16 y0
lazyLengthWord16 = LazyText.foldlChunks addLength 0
addLength n x = n + lengthWord16 x
splitWord16 xp 0 x = (xp, x)
splitWord16 xp n (LazyInternal.Chunk x@(Internal.Text arr off len) xs)
| n < len = (xp . LazyInternal.chunk (Internal.Text arr off n),
LazyInternal.chunk (Internal.Text arr (off+n) (len-n)) xs)
| otherwise = splitWord16 (xp . LazyInternal.chunk x) (n - len) xs
splitWord16 _ _ LazyInternal.Empty = error "impossible"
go xp yp cs LazyInternal.Empty LazyInternal.Empty = (xp mempty, yp mempty, cs mempty)
go xp yp cs (LazyInternal.Chunk x@(Internal.Text xarr xoff xlen) xs)
(LazyInternal.Chunk y@(Internal.Text yarr yoff ylen) ys)
| xlen < ylen = go xp yp cs (LazyInternal.Chunk x xs)
(LazyInternal.Chunk (Internal.Text yarr yoff xlen) $
LazyInternal.Chunk (Internal.Text yarr (yoff+xlen) (ylen-xlen)) ys)
| xlen > ylen = go xp yp cs (LazyInternal.Chunk (Internal.Text xarr xoff ylen) $
LazyInternal.Chunk (Internal.Text xarr (xoff+ylen) (xlen-ylen)) xs)
(LazyInternal.Chunk y ys)
| x == y = go xp yp (cs . LazyInternal.chunk x) xs ys
| (x1p, y1p, c1s) <- stripCommonSuffix x y =
go (xp . cs . LazyInternal.chunk x1p) (yp . cs . LazyInternal.chunk y1p) (LazyInternal.chunk c1s) xs ys
go _ _ _ _ _ = error "impossible"