module Data.Semiring
(
Semiring(..)
, StarSemiring(..)
, HasPositiveInfinity(..)
, HasNegativeInfinity(..)
, DetectableZero(..)
, Add(..)
, Mul(..)
, add
, mul
, Max(..)
, Min(..)
) where
import Data.Functor.Identity (Identity (..))
import Data.Complex (Complex)
import Data.Fixed (Fixed, HasResolution)
import Data.Ratio (Ratio)
import Numeric.Natural (Natural)
import Data.Int (Int16, Int32, Int64, Int8)
import Data.Word (Word16, Word32, Word64, Word8)
import Foreign.C.Types (CChar, CClock, CDouble, CFloat, CInt,
CIntMax, CIntPtr, CLLong, CLong,
CPtrdiff, CSChar, CSUSeconds, CShort,
CSigAtomic, CSize, CTime, CUChar, CUInt,
CUIntMax, CUIntPtr, CULLong, CULong,
CUSeconds, CUShort, CWchar)
import Foreign.Ptr (IntPtr, WordPtr)
import System.Posix.Types (CCc, CDev, CGid, CIno, CMode, CNlink,
COff, CPid, CRLim, CSpeed, CSsize,
CTcflag, CUid, Fd)
import Data.Semigroup hiding (Max (..), Min (..))
import Data.Coerce (coerce)
import GHC.Generics (Generic, Generic1)
import Data.Typeable (Typeable)
import Foreign.Storable (Storable)
import Data.Semiring.TH
class Semiring a where
zero
:: a
one
:: a
infixl 7 <.>
(<.>) :: a -> a -> a
infixl 6 <+>
(<+>) :: a -> a -> a
default zero :: Num a => a
default one :: Num a => a
default (<+>) :: Num a => a -> a -> a
default (<.>) :: Num a => a -> a -> a
zero = 0
one = 1
(<+>) = (+)
(<.>) = (*)
class Semiring a =>
StarSemiring a where
star :: a -> a
plus :: a -> a
star x = one <+> plus x
plus x = x <.> star x
class Semiring a => DetectableZero a where
isZero :: a -> Bool
default isZero :: Eq a => a -> Bool
isZero = (zero==)
class HasPositiveInfinity a where
positiveInfinity :: a
default positiveInfinity :: RealFloat a => a
positiveInfinity = 1/0
isPositiveInfinity :: a -> Bool
default isPositiveInfinity :: RealFloat a => a -> Bool
isPositiveInfinity x = isInfinite x && x > 0
class HasNegativeInfinity a where
negativeInfinity :: a
default negativeInfinity :: RealFloat a => a
negativeInfinity = negate (1/0)
isNegativeInfinity :: a -> Bool
default isNegativeInfinity :: RealFloat a => a -> Bool
isNegativeInfinity x = isInfinite x && x < 0
instance HasPositiveInfinity Double
instance HasNegativeInfinity Double
instance HasPositiveInfinity Float
instance HasNegativeInfinity Float
instance HasPositiveInfinity CDouble
instance HasNegativeInfinity CDouble
instance HasPositiveInfinity CFloat
instance HasNegativeInfinity CFloat
instance Semiring Bool where
one = True
zero = False
(<+>) = (||)
(<.>) = (&&)
instance StarSemiring Bool where
star _ = True
plus = id
instance DetectableZero Bool
instance Semiring () where
one = ()
zero = ()
_ <+> _ = ()
_ <.> _ = ()
instance DetectableZero ()
instance StarSemiring () where
star _ = ()
plus _ = ()
instance Semiring a =>
Semiring [a] where
one = [one]
zero = []
[] <+> ys = ys
xs <+> [] = xs
(x:xs) <+> (y:ys) = (x <+> y) : (xs <+> ys)
[] <.> _ = []
_ <.> [] = []
(x:xs) <.> (y:ys) =
(x <.> y) : (map (x <.>) ys <+> map (<.> y) xs <+> (xs <.> ys))
instance Semiring a => DetectableZero [a] where
isZero = null
type WrapBinary f a = (a -> a -> a) -> f a -> f a -> f a
newtype Add a = Add
{ getAdd :: a
} deriving (Eq,Ord,Read,Show,Bounded,Generic,Generic1,Num,Enum,Typeable
,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable
,Semiring,StarSemiring,DetectableZero)
newtype Mul a = Mul
{ getMul :: a
} deriving (Eq,Ord,Read,Show,Bounded,Generic,Generic1,Num,Enum,Typeable
,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable
,Semiring,StarSemiring,DetectableZero)
instance Semiring a =>
Semigroup (Add a) where
(<>) = (coerce :: WrapBinary Add a) (<+>)
instance Semiring a =>
Semigroup (Mul a) where
(<>) = (coerce :: WrapBinary Mul a) (<.>)
instance Semiring a =>
Monoid (Add a) where
mempty = Add zero
mappend = (<>)
instance Semiring a =>
Monoid (Mul a) where
mempty = Mul one
mappend = (<>)
add
:: (Foldable f, Semiring a)
=> f a -> a
add = getAdd . foldMap Add
mul
:: (Foldable f, Semiring a)
=> f a -> a
mul = getMul . foldMap Mul
newtype Min a = Min
{ getMin :: a
} deriving (Eq,Ord,Read,Show,Bounded,Generic,Generic1,Num,Enum,Typeable
,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable)
newtype Max a = Max
{ getMax :: a
} deriving (Eq,Ord,Read,Show,Bounded,Generic,Generic1,Num,Enum,Typeable
,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable)
instance Ord a =>
Semigroup (Max a) where
(<>) = (coerce :: WrapBinary Max a) max
instance Ord a =>
Semigroup (Min a) where
(<>) = (coerce :: WrapBinary Min a) min
instance (Ord a, HasNegativeInfinity a) =>
Monoid (Max a) where
mempty = Max negativeInfinity
mappend = (<>)
instance (Ord a, HasPositiveInfinity a) =>
Monoid (Min a) where
mempty = Min positiveInfinity
mappend = (<>)
instance (Semiring a, Ord a, HasNegativeInfinity a) =>
Semiring (Max a) where
(<+>) = mappend
zero = mempty
(<.>) = (coerce :: WrapBinary Max a) (<+>)
one = Max zero
instance (Semiring a, Ord a, HasPositiveInfinity a) =>
Semiring (Min a) where
(<+>) = mappend
zero = mempty
(<.>) = (coerce :: WrapBinary Min a) (<+>)
one = Min zero
instance (Semiring a, Ord a, HasPositiveInfinity a, HasNegativeInfinity a) =>
StarSemiring (Max a) where
star (Max x)
| x > zero = Max positiveInfinity
| otherwise = Max zero
instance (Semiring a, Ord a, HasPositiveInfinity a, HasNegativeInfinity a) =>
StarSemiring (Min a) where
star (Min x)
| x < zero = Min negativeInfinity
| otherwise = Min zero
instance (Semiring a, Ord a, HasPositiveInfinity a) => DetectableZero (Min a) where
isZero (Min x) = isPositiveInfinity x
instance (Semiring a, Ord a, HasNegativeInfinity a) => DetectableZero (Max a) where
isZero (Max x) = isNegativeInfinity x
instance Semiring b =>
Semiring (a -> b) where
zero = const zero
one = const one
(f <+> g) x = f x <+> g x
(f <.> g) x = f x <.> g x
instance StarSemiring b =>
StarSemiring (a -> b) where
star f x = star (f x)
plus f x = plus (f x)
instance Monoid a =>
Semiring (Endo a) where
zero = Endo mempty
Endo f <+> Endo g = Endo (f `mappend` g)
one = mempty
(<.>) = mappend
instance (Monoid a, Eq a) =>
StarSemiring (Endo a) where
star (Endo f) = Endo converge
where
converge x = go x
where
go inp =
mappend
x
(if inp == next
then inp
else go next)
where
next = mappend x (f inp)
instance (Enum a, Bounded a, Eq a, Monoid a) => DetectableZero (Endo a) where
isZero (Endo f) = all (mempty==) (map f [minBound..maxBound])
instance Semiring Any where
(<+>) = coerce (||)
zero = Any False
(<.>) = coerce (&&)
one = Any True
instance StarSemiring Any where
star _ = Any True
plus = id
instance Semiring All where
(<+>) = coerce (||)
zero = All False
(<.>) = coerce (&&)
one = All True
instance StarSemiring All where
star _ = All True
plus = id
instance DetectableZero Any
instance DetectableZero All
instance Semiring Int
instance Semiring Int8
instance Semiring Int16
instance Semiring Int32
instance Semiring Int64
instance Semiring Integer
instance Semiring Word
instance Semiring Word8
instance Semiring Word16
instance Semiring Word32
instance Semiring Word64
instance Semiring Float
instance Semiring Double
instance Semiring CUIntMax
instance Semiring CIntMax
instance Semiring CUIntPtr
instance Semiring CIntPtr
instance Semiring CSUSeconds
instance Semiring CUSeconds
instance Semiring CTime
instance Semiring CClock
instance Semiring CSigAtomic
instance Semiring CWchar
instance Semiring CSize
instance Semiring CPtrdiff
instance Semiring CDouble
instance Semiring CFloat
instance Semiring CULLong
instance Semiring CLLong
instance Semiring CULong
instance Semiring CLong
instance Semiring CUInt
instance Semiring CInt
instance Semiring CUShort
instance Semiring CShort
instance Semiring CUChar
instance Semiring CSChar
instance Semiring CChar
instance Semiring IntPtr
instance Semiring WordPtr
instance Semiring Fd
instance Semiring CRLim
instance Semiring CTcflag
instance Semiring CSpeed
instance Semiring CCc
instance Semiring CUid
instance Semiring CNlink
instance Semiring CGid
instance Semiring CSsize
instance Semiring CPid
instance Semiring COff
instance Semiring CMode
instance Semiring CIno
instance Semiring CDev
instance Semiring Natural
instance Integral a => Semiring (Ratio a)
deriving instance Semiring a => Semiring (Product a)
deriving instance Semiring a => Semiring (Sum a)
instance RealFloat a => Semiring (Complex a)
instance HasResolution a => Semiring (Fixed a)
deriving instance Semiring a => Semiring (Identity a)
instance DetectableZero Int
instance DetectableZero Int8
instance DetectableZero Int16
instance DetectableZero Int32
instance DetectableZero Int64
instance DetectableZero Integer
instance DetectableZero Word
instance DetectableZero Word8
instance DetectableZero Word16
instance DetectableZero Word32
instance DetectableZero Word64
instance DetectableZero Float
instance DetectableZero Double
instance DetectableZero CUIntMax
instance DetectableZero CIntMax
instance DetectableZero CUIntPtr
instance DetectableZero CIntPtr
instance DetectableZero CSUSeconds
instance DetectableZero CUSeconds
instance DetectableZero CTime
instance DetectableZero CClock
instance DetectableZero CSigAtomic
instance DetectableZero CWchar
instance DetectableZero CSize
instance DetectableZero CPtrdiff
instance DetectableZero CDouble
instance DetectableZero CFloat
instance DetectableZero CULLong
instance DetectableZero CLLong
instance DetectableZero CULong
instance DetectableZero CLong
instance DetectableZero CUInt
instance DetectableZero CInt
instance DetectableZero CUShort
instance DetectableZero CShort
instance DetectableZero CUChar
instance DetectableZero CSChar
instance DetectableZero CChar
instance DetectableZero IntPtr
instance DetectableZero WordPtr
instance DetectableZero Fd
instance DetectableZero CRLim
instance DetectableZero CTcflag
instance DetectableZero CSpeed
instance DetectableZero CCc
instance DetectableZero CUid
instance DetectableZero CNlink
instance DetectableZero CGid
instance DetectableZero CSsize
instance DetectableZero CPid
instance DetectableZero COff
instance DetectableZero CMode
instance DetectableZero CIno
instance DetectableZero CDev
instance DetectableZero Natural
instance Integral a => DetectableZero (Ratio a)
deriving instance DetectableZero a => DetectableZero (Product a)
deriving instance DetectableZero a => DetectableZero (Sum a)
instance RealFloat a => DetectableZero (Complex a)
instance HasResolution a => DetectableZero (Fixed a)
deriving instance DetectableZero a => DetectableZero (Identity a)
$(traverse semiringIns [2..9])
$(traverse starIns [2..9])
$(traverse zeroIns [2..9])