{-# LANGUAGE CPP          #-}
{-# LANGUAGE TypeFamilies #-}

-- 'Option' will be removed in 'ghc-9.2'.
{-# OPTIONS_GHC -Wno-deprecations #-}

module Data.Semigroup.Abelian
    ( AbelianSemigroup
    , FreeAbelianSemigroup
    , toNonEmpty
    , fromNonEmpty
    ) where

import           Data.IntSet (IntSet)
import           Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NE
import           Data.Map (Map)
import qualified Data.Map as Map
import           Data.Set (Set)
import           Data.Semigroup
                    ( All
                    , Any
                    , Dual
                    , Max
                    , Min
#if __GLASGOW_HASKELL__ < 902
                    , Option
#endif
                    , Product
                    , Sum
                    )
import           Data.Void (Void)
import           Numeric.Natural (Natural)

import           Data.Algebra.Free
                    ( AlgebraType
                    , AlgebraType0
                    , FreeAlgebra (..)
                    )

-- | Class of commutative monoids, e.g. with additional law:
-- @
--  a <> b = b <> a
-- @
--
class Semigroup m => AbelianSemigroup m

instance AbelianSemigroup Void

instance AbelianSemigroup ()

instance AbelianSemigroup All

instance AbelianSemigroup Any

instance AbelianSemigroup a => AbelianSemigroup (Dual a)

instance Ord a => AbelianSemigroup (Max a)

instance Ord a => AbelianSemigroup (Min a)

instance AbelianSemigroup a => AbelianSemigroup (Maybe a)
#if __GLASGOW_HASKELL__ < 902
instance AbelianSemigroup a => AbelianSemigroup (Option a)
#endif

instance Num a => AbelianSemigroup (Product a)

instance Num a => AbelianSemigroup (Sum a)

instance Ord a => AbelianSemigroup (Set a)

instance AbelianSemigroup IntSet

-- | Free abelian semigroup is isomorphic to a non empty map with keys @a@ and
-- values positive natural numbers.
--
-- It is a monad on the full subcategory which satisfies the `Ord` constraint,
-- but base does not allow to define a functor \/ applicative \/ monad
-- instances which are constraint by a class.
--
newtype FreeAbelianSemigroup a = FreeAbelianSemigroup (Map a Natural)
    deriving (Eq (FreeAbelianSemigroup a)
Eq (FreeAbelianSemigroup a)
-> (FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Ordering)
-> (FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool)
-> (FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool)
-> (FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool)
-> (FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool)
-> (FreeAbelianSemigroup a
    -> FreeAbelianSemigroup a -> FreeAbelianSemigroup a)
-> (FreeAbelianSemigroup a
    -> FreeAbelianSemigroup a -> FreeAbelianSemigroup a)
-> Ord (FreeAbelianSemigroup a)
FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool
FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Ordering
FreeAbelianSemigroup a
-> FreeAbelianSemigroup a -> FreeAbelianSemigroup a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (FreeAbelianSemigroup a)
forall a.
Ord a =>
FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool
forall a.
Ord a =>
FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Ordering
forall a.
Ord a =>
FreeAbelianSemigroup a
-> FreeAbelianSemigroup a -> FreeAbelianSemigroup a
$ccompare :: forall a.
Ord a =>
FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Ordering
compare :: FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Ordering
$c< :: forall a.
Ord a =>
FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool
< :: FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool
$c<= :: forall a.
Ord a =>
FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool
<= :: FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool
$c> :: forall a.
Ord a =>
FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool
> :: FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool
$c>= :: forall a.
Ord a =>
FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool
>= :: FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool
$cmax :: forall a.
Ord a =>
FreeAbelianSemigroup a
-> FreeAbelianSemigroup a -> FreeAbelianSemigroup a
max :: FreeAbelianSemigroup a
-> FreeAbelianSemigroup a -> FreeAbelianSemigroup a
$cmin :: forall a.
Ord a =>
FreeAbelianSemigroup a
-> FreeAbelianSemigroup a -> FreeAbelianSemigroup a
min :: FreeAbelianSemigroup a
-> FreeAbelianSemigroup a -> FreeAbelianSemigroup a
Ord, FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool
(FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool)
-> (FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool)
-> Eq (FreeAbelianSemigroup a)
forall a.
Eq a =>
FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a.
Eq a =>
FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool
== :: FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool
$c/= :: forall a.
Eq a =>
FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool
/= :: FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool
Eq, Int -> FreeAbelianSemigroup a -> ShowS
[FreeAbelianSemigroup a] -> ShowS
FreeAbelianSemigroup a -> String
(Int -> FreeAbelianSemigroup a -> ShowS)
-> (FreeAbelianSemigroup a -> String)
-> ([FreeAbelianSemigroup a] -> ShowS)
-> Show (FreeAbelianSemigroup a)
forall a. Show a => Int -> FreeAbelianSemigroup a -> ShowS
forall a. Show a => [FreeAbelianSemigroup a] -> ShowS
forall a. Show a => FreeAbelianSemigroup a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> FreeAbelianSemigroup a -> ShowS
showsPrec :: Int -> FreeAbelianSemigroup a -> ShowS
$cshow :: forall a. Show a => FreeAbelianSemigroup a -> String
show :: FreeAbelianSemigroup a -> String
$cshowList :: forall a. Show a => [FreeAbelianSemigroup a] -> ShowS
showList :: [FreeAbelianSemigroup a] -> ShowS
Show)

toNonEmpty :: FreeAbelianSemigroup a -> NonEmpty (a, Natural)
toNonEmpty :: forall a. FreeAbelianSemigroup a -> NonEmpty (a, Natural)
toNonEmpty (FreeAbelianSemigroup Map a Natural
as) = [(a, Natural)] -> NonEmpty (a, Natural)
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList ([(a, Natural)] -> NonEmpty (a, Natural))
-> (Map a Natural -> [(a, Natural)])
-> Map a Natural
-> NonEmpty (a, Natural)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map a Natural -> [(a, Natural)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map a Natural -> NonEmpty (a, Natural))
-> Map a Natural -> NonEmpty (a, Natural)
forall a b. (a -> b) -> a -> b
$ Map a Natural
as

-- | Smart constructor which creates `FreeAbelianSemigroup` from a non empty
-- list of pairs @(a, n) :: (a, Natural)@ where @n > 0@.
--
fromNonEmpty :: Ord a => NonEmpty (a, Natural) -> Maybe (FreeAbelianSemigroup a)
fromNonEmpty :: forall a.
Ord a =>
NonEmpty (a, Natural) -> Maybe (FreeAbelianSemigroup a)
fromNonEmpty = ([(a, Natural)] -> FreeAbelianSemigroup a)
-> Maybe [(a, Natural)] -> Maybe (FreeAbelianSemigroup a)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map a Natural -> FreeAbelianSemigroup a
forall a. Map a Natural -> FreeAbelianSemigroup a
FreeAbelianSemigroup (Map a Natural -> FreeAbelianSemigroup a)
-> ([(a, Natural)] -> Map a Natural)
-> [(a, Natural)]
-> FreeAbelianSemigroup a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(a, Natural)] -> Map a Natural
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList) (Maybe [(a, Natural)] -> Maybe (FreeAbelianSemigroup a))
-> (NonEmpty (a, Natural) -> Maybe [(a, Natural)])
-> NonEmpty (a, Natural)
-> Maybe (FreeAbelianSemigroup a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(a, Natural)] -> Maybe [(a, Natural)]
forall {b} {a}. (Eq b, Num b) => [(a, b)] -> Maybe [(a, b)]
go ([(a, Natural)] -> Maybe [(a, Natural)])
-> (NonEmpty (a, Natural) -> [(a, Natural)])
-> NonEmpty (a, Natural)
-> Maybe [(a, Natural)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (a, Natural) -> [(a, Natural)]
forall a. NonEmpty a -> [a]
NE.toList
    where
    go :: [(a, b)] -> Maybe [(a, b)]
go []            = [(a, b)] -> Maybe [(a, b)]
forall a. a -> Maybe a
Just []
    go ((a
a, b
n) : [(a, b)]
as) | b
n b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
0    = Maybe [(a, b)]
forall a. Maybe a
Nothing
                     | Bool
otherwise = ((a
a, b
n) (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
:) ([(a, b)] -> [(a, b)]) -> Maybe [(a, b)] -> Maybe [(a, b)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(a, b)] -> Maybe [(a, b)]
go [(a, b)]
as

instance Ord a => Semigroup (FreeAbelianSemigroup a) where
    (FreeAbelianSemigroup Map a Natural
a) <> :: FreeAbelianSemigroup a
-> FreeAbelianSemigroup a -> FreeAbelianSemigroup a
<> (FreeAbelianSemigroup Map a Natural
b) = Map a Natural -> FreeAbelianSemigroup a
forall a. Map a Natural -> FreeAbelianSemigroup a
FreeAbelianSemigroup (Map a Natural -> FreeAbelianSemigroup a)
-> Map a Natural -> FreeAbelianSemigroup a
forall a b. (a -> b) -> a -> b
$ (Natural -> Natural -> Natural)
-> Map a Natural -> Map a Natural -> Map a Natural
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
(+) Map a Natural
a Map a Natural
b

instance Ord a => AbelianSemigroup (FreeAbelianSemigroup a)

type instance AlgebraType0 FreeAbelianSemigroup a = Ord a
type instance AlgebraType  FreeAbelianSemigroup a = (Ord a, AbelianSemigroup a)

instance FreeAlgebra FreeAbelianSemigroup where
    returnFree :: forall a. a -> FreeAbelianSemigroup a
returnFree a
a = Map a Natural -> FreeAbelianSemigroup a
forall a. Map a Natural -> FreeAbelianSemigroup a
FreeAbelianSemigroup (Map a Natural -> FreeAbelianSemigroup a)
-> Map a Natural -> FreeAbelianSemigroup a
forall a b. (a -> b) -> a -> b
$ a -> Natural -> Map a Natural
forall k a. k -> a -> Map k a
Map.singleton a
a Natural
1

    foldMapFree :: forall d a.
(AlgebraType FreeAbelianSemigroup d,
 AlgebraType0 FreeAbelianSemigroup a) =>
(a -> d) -> FreeAbelianSemigroup a -> d
foldMapFree a -> d
f (FreeAbelianSemigroup Map a Natural
as)
                 = (a -> d) -> NonEmpty a -> d
forall d a.
(AlgebraType NonEmpty d, AlgebraType0 NonEmpty a) =>
(a -> d) -> NonEmpty a -> d
forall (m :: * -> *) d a.
(FreeAlgebra m, AlgebraType m d, AlgebraType0 m a) =>
(a -> d) -> m a -> d
foldMapFree a -> d
f (Map a Natural -> NonEmpty a
forall a. Map a Natural -> NonEmpty a
toNonEmpty_ Map a Natural
as)
      where
        replicate_ :: a -> Natural -> [a]                                     
        replicate_ :: forall a. a -> Natural -> [a]
replicate_ a
_ Natural
n | Natural
n Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
<= Natural
0 = String -> [a]
forall a. HasCallStack => String -> a
error String
"foldMapFree @FreeAbelianSemigroup: impossible"
        replicate_ a
a Natural
1 = [a
a]                                                   
        replicate_ a
a Natural
n = a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a -> Natural -> [a]
forall a. a -> Natural -> [a]
replicate_ a
a (Natural
n Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1)                             

        toNonEmpty_ :: Map a Natural -> NonEmpty a
        toNonEmpty_ :: forall a. Map a Natural -> NonEmpty a
toNonEmpty_ = [a] -> NonEmpty a
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList ([a] -> NonEmpty a)
-> (Map a Natural -> [a]) -> Map a Natural -> NonEmpty a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, Natural) -> [a]) -> [(a, Natural)] -> [a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((a -> Natural -> [a]) -> (a, Natural) -> [a]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> Natural -> [a]
forall a. a -> Natural -> [a]
replicate_) ([(a, Natural)] -> [a])
-> (Map a Natural -> [(a, Natural)]) -> Map a Natural -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map a Natural -> [(a, Natural)]
forall k a. Map k a -> [(k, a)]
Map.toList