module Data.Semiring.Numeric
( Bottleneck(..)
, Division(..)
, Łukasiewicz(..)
, Viterbi(..)
, Log(..)
, PosFrac(..)
, PosInt(..)
) where
import Data.Coerce
import Data.Semiring
import GHC.Generics
import Data.Typeable (Typeable)
import Foreign.Storable (Storable)
type WrapBinary f a = (a -> a -> a) -> f a -> f a -> f a
newtype Bottleneck a = Bottleneck
{ getBottleneck :: a
} deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num
,Enum, Typeable, Storable, Fractional, Real, RealFrac
,Functor, Foldable, Traversable)
instance (Bounded a, Ord a) => Semiring (Bottleneck a) where
(<+>) = (coerce :: WrapBinary Bottleneck a) max
(<.>) = (coerce :: WrapBinary Bottleneck a) min
zero = Bottleneck minBound
one = Bottleneck maxBound
instance (Bounded a, Ord a) => DetectableZero (Bottleneck a)
newtype Division a = Division
{ getDivision :: a
} deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num
,Enum, Typeable, Storable, Fractional, Real, RealFrac
,Functor, Foldable, Traversable,DetectableZero)
instance (Integral a, Semiring a) => Semiring (Division a) where
(<+>) = (coerce :: WrapBinary Division a) gcd
(<.>) = (coerce :: WrapBinary Division a) lcm
zero = Division zero
one = Division one
newtype Łukasiewicz a = Łukasiewicz
{ getŁukasiewicz :: a
} deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num
,Enum, Typeable, Storable, Fractional, Real, RealFrac
,Functor, Foldable, Traversable)
instance (Ord a, Num a) => Semiring (Łukasiewicz a) where
(<+>) = (coerce :: WrapBinary Łukasiewicz a) max
(<.>) = (coerce :: WrapBinary Łukasiewicz a) (\x y -> max 0 (x + y 1))
zero = Łukasiewicz 0
one = Łukasiewicz 1
instance (Ord a, Num a) => DetectableZero (Łukasiewicz a)
newtype Viterbi a = Viterbi
{ getViterbi :: a
} deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num
,Enum, Typeable, Storable, Fractional, Real, RealFrac
,Functor, Foldable, Traversable,DetectableZero)
instance (Ord a, Semiring a) => Semiring (Viterbi a) where
(<+>) = (coerce :: WrapBinary Viterbi a) max
(<.>) = (coerce :: WrapBinary Viterbi a) (<.>)
zero = Viterbi zero
one = Viterbi one
newtype Log a = Log
{ getLog :: a
} deriving (Eq, Ord, Read, Show, Generic, Generic1, Typeable, Functor
,Foldable)
instance (Floating a, HasPositiveInfinity a) => Semiring (Log a) where
zero = Log positiveInfinity
one = Log 0
(<.>) = (coerce :: WrapBinary Log a) (+)
Log x <+> Log y
= Log ((log (exp (x) + exp (y))))
instance (Floating a, HasPositiveInfinity a) => DetectableZero (Log a) where
isZero (Log x) = isPositiveInfinity x
newtype PosFrac a = PosFrac
{ getPosFrac :: a
} deriving (Eq, Ord, Read, Show, Generic, Generic1, Num
,Enum, Typeable, Storable, Fractional, Real, RealFrac
,Functor, Foldable, Traversable)
instance (Bounded a, Semiring a) => Bounded (PosFrac a) where
minBound = PosFrac zero
maxBound = PosFrac maxBound
instance Semiring a => Semiring (PosFrac a) where
(<+>) = (coerce :: WrapBinary PosFrac a) (<+>)
(<.>) = (coerce :: WrapBinary PosFrac a) (<.>)
zero = PosFrac zero
one = PosFrac one
instance (Eq a, Semiring a) => DetectableZero (PosFrac a)
instance (Ord a, Fractional a, Semiring a, HasPositiveInfinity a) =>
StarSemiring (PosFrac a) where
star (PosFrac n)
| n < 1 = PosFrac (1 / (1 n))
| otherwise = PosFrac positiveInfinity
newtype PosInt a = PosInt
{ getPosInt :: a
} deriving (Eq, Ord, Read, Show, Generic, Generic1, Num
,Enum, Typeable, Storable, Fractional, Real, RealFrac
,Functor, Foldable, Traversable)
instance (Bounded a, Semiring a) => Bounded (PosInt a) where
minBound = PosInt zero
maxBound = PosInt maxBound
instance Semiring a => Semiring (PosInt a) where
(<+>) = (coerce :: WrapBinary PosInt a) (<+>)
(<.>) = (coerce :: WrapBinary PosInt a) (<.>)
zero = PosInt zero
one = PosInt one
instance (Eq a, Semiring a) => DetectableZero (PosInt a)
instance (Eq a, Semiring a, HasPositiveInfinity a) =>
StarSemiring (PosInt a) where
star (PosInt n) | n == zero = PosInt one
star _ = PosInt positiveInfinity