semirings-0.6/0000755000000000000000000000000007346545000011550 5ustar0000000000000000semirings-0.6/CHANGELOG.md0000755000000000000000000001252307346545000013367 0ustar00000000000000000.6: [2021-01-07] ----------------- * Remove hashable flag (only necessary was unordered-containers flag) * Drop redundant `Eq` constraint on default definition of `coprime` * Document (lack of guaranteed) rounding behaviour of quotRem * Fix totally broken Ord instance for Tropical * Stop depending on integer-gmp 0.5.4: [2020.07.13] ------------------- * Drop support for GHCs prior to 7.10 * Add default quotRem implementation * Expose Data.Semiring.Generic.gfromNatural 0.5.3: [2020.02.18] ------------------- * Fix non-terminating GenericSemiring instances * Fix incorrect implementation of gtimes' for product types in GSemiring * Implement GcdDomain.divide explicitly * Remove redundant imports * Disambiguate all haddock identifiers 0.5.2: [2019.11.01] ------------------- * Add `gcdExt` function * Bump upper bound on base * Add GcdDomain/Euclidean instances for `Mod2` * Add GcdDomain/Euclidean instances for {Int|Word}{8|16|32|64} * Mention `RebindableSyntax` in haddocks rev: b4334fe06635f106b1f08bac127c1ae259cddae6 0.5.1: [2019.09.13] ------------------- * Bump upper bound on containers to 0.7 * Bump upper bound on hashable to 1.4 * Remove redundant constraints from WrappedFractional instances * Add lower bound on semigroups rev: 7e6f5e312bec5495ce9390664578bfb09d6e3eb9 0.5: [2019.09.05] ----------------- * Add `Field` typeclass, instances, and functions. * Add `Euclidean` and `GcdDomain` instances for `()`, `CDouble`, `CFloat`, and `Complex`. * Add `Ring` and `Bits` instances for `WrappedFractional` and `WrappedIntegral`. * Add `fromInteger` and `fromIntegral` functions for `Ring`. rev: eb2617d93d354085fe5b706a145108d090dbc027 0.4.2: [2019.06.06] ------------------- * Add `GcdDomain` and `Euclidean` typeclasses. * Add `Mod2`, the integers modulo 2, along with its Semiring/Ring/Star instances. rev: b5af2fa403c68a66a3282b2a452b9be1c98e3fd6 0.4.1: [2019.05.04] ------------------- * Remove unlawful and useless `Ring` instance for `GHC.Natural.Natural`. * Correct behaviour/docs of Data.Semiring.(^) rev: d6c42aeea602499e32081e84974910d0fe955db6 0.4: [2019.05.01] ----------------- * Remove unlawful instances of `Ring` (thanks to @Bodigrim for noticing these) * Add `fromNatural` to `Semiring` typeclass (thanks @Bodigrim) * Remove Semiring/Ring instances for [] and Vector. (thanks @Bodigrim) These instances are better served by a dedicated polynomial package, which @Bodigrim has made at http://hackage.haskell.org/package/poly. * Add isZero/isOne predicates. rev: 1285d3e42242db310083fbf78d2e611bccecc63a 0.3.1.2: [2019.04.02] --------------------- * Fix build error on windows caused by providing instances to POSIX types. Thanks to @Bodigrim and @CarlEdman for reporting this. rev: 13d4b3920912f8030b5d47777fb57b6e0dd15c10 0.3.1.1: [2019.01.12] --------------------- * Fix build error caused by disabling building with containers. rev: 5f02279613bfcd20c2e9d68f01d669e563540ced 0.3.1.0: [2019.01.12] --------------------- * Add Data.Semiring.Tropical * Fix build problem on GHC 7.4 caused by introduction of IntSetOf/IntMapOf * Make sure there are no warnings when building with -Wall, for any GHC rev: 68c604250e2cf5688b3c641fd40b66fe7e1d45bf 0.3.0.0: [2019.01.01] --------------------- * Rename the test suite to make `stack` happy. * Clarified documentation. See #26. * Simplify implementation of `^`. See #24. * Add 'GenericSemiring', a newtype wrapper meant to be used with `-XDerivingVia`, helping avoid '-XDefaultSignatures'. * Add newtypes for `IntSet` and `IntMap`. * Remove `Semiring` and `Ring` instances for `Product` and `Sum`. * Make `sum` and `product` more efficient for base>=4.7 rev: d7d47c3db82a8e85330bb138169b9783eb346f38 0.2.1.1: [2018.10.01] --------------------- * Fixed build on GHC-7.4 * Provide `Semiring` and `Ring` for an arbitrary `Num` via `WrappedNum` newtype. * Make note of `Semiring` semantics for `Vector` and `[]` in the documentation. * Require build script to ensure `semirings` builds with GHC-8.4.3 and GHC-8.6.1 * Fixed unlawful behaviour of `[]` `Semiring` instance. * Improve performance of `^`. rev: e9b85d8aa6a238d07a061402f0ba365190eee7aa 0.2.1.0: [2018.09.26] --------------------- * Removed use of DefaultSignatures * Removed free semiring rev: 68e97e82280a50c374f50500a73222a5432cc45e 0.2.0.1: [2018.07.28] --------------------- * Add instances for `Op`, `Equivalence`, `Comparison`, and `Predicate` from Data.Functor.Contravariant (upcoming base 4.12.0.0) * docfix for (prod -> product, prod' -> product') change that occured in version 0.2.0.0. rev: 60869059d2959676877c9661427814b2bafd5d97 0.2.0.0: [2018.07.23] --------------------- * Fixed the `Semiring` instances of `Set`, `HashSet`, `Vector`, `Storable Vector`, `Unboxed Vector`. * Removed the `Semiring` instances of `Seq`, `Alt`, `Endo`. * Added comprehensive test suite that tests all `Semiring` instances defined in Data.Semiring * Added Free semiring (Data.Semiring.Free) * Added newtypes: `Add`, `Mul` * Bounds for containers: [0.3,0.6] -> [0.5.4,0.6.0.9] * Add semiring instance for `Proxy` * names changed: (prod -> product, prod' -> product') * sum' and product' now use foldl' instead of foldr' rev: b985dcf37b919facc2dfbec66ea923ca5427c9f6 0.1.2: [2018.05.04] ------------------- * `semirings` now builds back to GHC-7.4.1. * many doc fixes. 0.1.1: [2018.04.20] ------------------- * Remove unused `coerce-util` dependency. 0.1.0: ------ * Initial version. semirings-0.6/Data/0000755000000000000000000000000007346545000012421 5ustar0000000000000000semirings-0.6/Data/Euclidean.hs0000644000000000000000000003150707346545000014654 0ustar0000000000000000-- | -- Module: Data.Euclidean -- Copyright: (c) 2019 Andrew Lelechenko -- Licence: BSD3 -- Maintainer: Andrew Lelechenko -- {-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-} #if MIN_VERSION_base(4,12,0) {-# LANGUAGE DerivingVia #-} {-# LANGUAGE StandaloneDeriving #-} #else {-# LANGUAGE TemplateHaskell #-} #endif module Data.Euclidean ( Euclidean(..) , Field , GcdDomain(..) , WrappedIntegral(..) , WrappedFractional(..) , gcdExt ) where import Prelude hiding (quotRem, quot, rem, divMod, div, mod, gcd, lcm, negate, (*), Int, Word) import qualified Prelude as P import Control.Exception (throw, ArithException(..)) import Data.Bits (Bits) import Data.Complex (Complex(..)) import Data.Int (Int, Int8, Int16, Int32, Int64) import Data.Maybe (isJust) import Data.Ratio (Ratio) import Data.Semiring (Semiring(..), Ring(..), (*), minus, isZero, Mod2) import Data.Word (Word, Word8, Word16, Word32, Word64) import Foreign.C.Types (CFloat, CDouble) #if !MIN_VERSION_base(4,12,0) import Language.Haskell.TH.Syntax (Q, Dec, Type) #endif import Numeric.Natural --------------------------------------------------------------------- -- Classes --------------------------------------------------------------------- -- | 'GcdDomain' represents a -- . -- This is a domain, where GCD can be defined, -- but which does not necessarily allow a well-behaved -- division with remainder (as in 'Euclidean' domains). -- -- For example, there is no way to define 'rem' over -- polynomials with integer coefficients such that -- remainder is always "smaller" than divisor. However, -- 'gcd' is still definable, just not by means of -- Euclidean algorithm. -- -- All methods of 'GcdDomain' have default implementations -- in terms of 'Euclidean'. So most of the time -- it is enough to write: -- -- > instance GcdDomain Foo -- > instance Euclidean Foo where -- > quotRem = ... -- > degree = ... class Semiring a => GcdDomain a where -- | Division without remainder. -- -- prop> \x y -> (x * y) `divide` y == Just x -- prop> \x y -> maybe True (\z -> x == z * y) (x `divide` y) divide :: a -> a -> Maybe a default divide :: (Eq a, Euclidean a) => a -> a -> Maybe a divide x y = let (q, r) = quotRem x y in if isZero r then Just q else Nothing -- | Greatest common divisor. Must satisfy -- -- prop> \x y -> isJust (x `divide` gcd x y) && isJust (y `divide` gcd x y) -- prop> \x y z -> isJust (gcd (x * z) (y * z) `divide` z) gcd :: a -> a -> a default gcd :: (Eq a, Euclidean a) => a -> a -> a gcd a b | isZero b = a | otherwise = gcd b (a `rem` b) -- | Lowest common multiple. Must satisfy -- -- prop> \x y -> isJust (lcm x y `divide` x) && isJust (lcm x y `divide` y) -- prop> \x y z -> isNothing (z `divide` x) || isNothing (z `divide` y) || isJust (z `divide` lcm x y) lcm :: a -> a -> a default lcm :: Eq a => a -> a -> a lcm a b | isZero a || isZero b = zero | otherwise = case a `divide` gcd a b of Nothing -> error "lcm: violated gcd invariant" Just c -> c * b -- | Test whether two arguments are -- . -- Must match its default definition: -- -- prop> \x y -> coprime x y == isJust (1 `divide` gcd x y) coprime :: a -> a -> Bool default coprime :: a -> a -> Bool coprime x y = isJust (one `divide` gcd x y) infixl 7 `divide` -- | Informally speaking, 'Euclidean' is a superclass of 'Integral', -- lacking 'toInteger', which allows to define division with remainder -- for a wider range of types, e. g., complex integers -- and polynomials with rational coefficients. -- -- 'Euclidean' represents a -- -- endowed by a given Euclidean function 'degree'. -- -- No particular rounding behaviour is expected of 'quotRem'. E. g., -- it is not guaranteed to truncate towards zero or towards negative -- infinity (cf. 'P.divMod'), and remainders are not guaranteed to be non-negative. -- For a faithful representation of residue classes one can use -- package instead. class GcdDomain a => Euclidean a where {-# MINIMAL (quotRem | quot, rem), degree #-} -- | Division with remainder. -- -- prop> \x y -> y == 0 || let (q, r) = x `quotRem` y in x == q * y + r quotRem :: a -> a -> (a, a) quotRem x y = (quot x y, rem x y) -- | Division. Must match its default definition: -- -- prop> \x y -> quot x y == fst (quotRem x y) quot :: a -> a -> a quot x y = fst (quotRem x y) -- | Remainder. Must match its default definition: -- -- prop> \x y -> rem x y == snd (quotRem x y) rem :: a -> a -> a rem x y = snd (quotRem x y) -- | Euclidean (aka degree, valuation, gauge, norm) function on @a@. Usually @'fromIntegral' '.' 'abs'@. -- -- 'degree' is rarely used by itself. Its purpose -- is to provide an evidence of soundness of 'quotRem' -- by testing the following property: -- -- prop> \x y -> y == 0 || let (q, r) = x `quotRem` y in (r == 0 || degree r < degree y) degree :: a -> Natural infixl 7 `quot` infixl 7 `rem` coprimeIntegral :: Integral a => a -> a -> Bool coprimeIntegral x y = (odd x || odd y) && P.gcd x y == 1 -- | Execute the extended Euclidean algorithm. -- For elements @a@ and @b@, compute their greatest common divisor @g@ -- and the coefficient @s@ satisfying @as + bt = g@ for some @t@. gcdExt :: (Eq a, Euclidean a, Ring a) => a -> a -> (a, a) gcdExt = go one zero where go s s' r r' | r' == zero = (r, s) | otherwise = case quotRem r r' of (q, r'') -> go s' (minus s (times q s')) r' r'' {-# INLINABLE gcdExt #-} -- | 'Field' represents a -- , -- a ring with a multiplicative inverse for any non-zero element. class (Euclidean a, Ring a) => Field a --------------------------------------------------------------------- -- Instances --------------------------------------------------------------------- instance GcdDomain () where divide = const $ const (Just ()) gcd = const $ const () lcm = const $ const () coprime = const $ const True instance Euclidean () where degree = const 0 quotRem = const $ const ((), ()) quot = const $ const () rem = const $ const () instance Field () instance GcdDomain Mod2 where instance Euclidean Mod2 where degree = const 0 quotRem x y | isZero y = throw DivideByZero | otherwise = (x, zero) instance Field Mod2 -- | Wrapper around 'Integral' with 'GcdDomain' -- and 'Euclidean' instances. newtype WrappedIntegral a = WrapIntegral { unwrapIntegral :: a } deriving (Eq, Ord, Show, Num, Integral, Real, Enum, Bits) instance Num a => Semiring (WrappedIntegral a) where plus = (P.+) zero = 0 times = (P.*) one = 1 fromNatural = P.fromIntegral instance Num a => Ring (WrappedIntegral a) where negate = P.negate instance Integral a => GcdDomain (WrappedIntegral a) where divide x y = case x `P.quotRem` y of (q, 0) -> Just q; _ -> Nothing gcd = P.gcd lcm = P.lcm coprime = coprimeIntegral instance Integral a => Euclidean (WrappedIntegral a) where degree = P.fromIntegral . abs . unwrapIntegral quotRem = P.quotRem quot = P.quot rem = P.rem -- | Wrapper around 'Fractional' -- with trivial 'GcdDomain' -- and 'Euclidean' instances. newtype WrappedFractional a = WrapFractional { unwrapFractional :: a } deriving (Eq, Ord, Show, Num, Fractional) instance Num a => Semiring (WrappedFractional a) where plus = (P.+) zero = 0 times = (P.*) one = 1 fromNatural = P.fromIntegral instance Num a => Ring (WrappedFractional a) where negate = P.negate instance Fractional a => GcdDomain (WrappedFractional a) where divide x y = Just (x / y) gcd = const $ const 1 lcm = const $ const 1 coprime = const $ const True instance Fractional a => Euclidean (WrappedFractional a) where degree = const 0 quotRem x y = (x / y, 0) quot = (/) rem = const $ const 0 instance Fractional a => Field (WrappedFractional a) instance Integral a => GcdDomain (Ratio a) where divide x y = Just (x / y) gcd = const $ const 1 lcm = const $ const 1 coprime = const $ const True instance Integral a => Euclidean (Ratio a) where degree = const 0 quotRem x y = (x / y, 0) quot = (/) rem = const $ const 0 instance Integral a => Field (Ratio a) instance GcdDomain Float where divide x y = Just (x / y) gcd = const $ const 1 lcm = const $ const 1 coprime = const $ const True instance Euclidean Float where degree = const 0 quotRem x y = (x / y, 0) quot = (/) rem = const $ const 0 instance Field Float instance GcdDomain Double where divide x y = Just (x / y) gcd = const $ const 1 lcm = const $ const 1 coprime = const $ const True instance Euclidean Double where degree = const 0 quotRem x y = (x / y, 0) quot = (/) rem = const $ const 0 instance Field Double instance GcdDomain CFloat where divide x y = Just (x / y) gcd = const $ const 1 lcm = const $ const 1 coprime = const $ const True instance Euclidean CFloat where degree = const 0 quotRem x y = (x / y, 0) quot = (/) rem = const $ const 0 instance Field CFloat instance GcdDomain CDouble where divide x y = Just (x / y) gcd = const $ const 1 lcm = const $ const 1 coprime = const $ const True instance Euclidean CDouble where degree = const 0 quotRem x y = (x / y, 0) quot = (/) rem = const $ const 0 instance Field CDouble conjQuotAbs :: Field a => Complex a -> Complex a conjQuotAbs (x :+ y) = x `quot` norm :+ (negate y) `quot` norm where norm = (x `times` x) `plus` (y `times` y) instance Field a => GcdDomain (Complex a) where divide x y = Just (x `times` conjQuotAbs y) gcd = const $ const one lcm = const $ const one coprime = const $ const True instance Field a => Euclidean (Complex a) where degree = const 0 quotRem x y = (quot x y, zero) quot x y = x `times` conjQuotAbs y rem = const $ const zero instance Field a => Field (Complex a) #if MIN_VERSION_base(4,12,0) deriving via (WrappedIntegral Int) instance GcdDomain Int deriving via (WrappedIntegral Int8) instance GcdDomain Int8 deriving via (WrappedIntegral Int16) instance GcdDomain Int16 deriving via (WrappedIntegral Int32) instance GcdDomain Int32 deriving via (WrappedIntegral Int64) instance GcdDomain Int64 deriving via (WrappedIntegral Integer) instance GcdDomain Integer deriving via (WrappedIntegral Word) instance GcdDomain Word deriving via (WrappedIntegral Word8) instance GcdDomain Word8 deriving via (WrappedIntegral Word16) instance GcdDomain Word16 deriving via (WrappedIntegral Word32) instance GcdDomain Word32 deriving via (WrappedIntegral Word64) instance GcdDomain Word64 deriving via (WrappedIntegral Natural) instance GcdDomain Natural #else $(let deriveGcdDomain :: Q Type -> Q [Dec] deriveGcdDomain ty = [d| instance GcdDomain $ty where gcd = P.gcd lcm = P.lcm coprime = coprimeIntegral |] in P.concat P.<$> P.traverse deriveGcdDomain [[t|Int|] ,[t|Int8|] ,[t|Int16|] ,[t|Int32|] ,[t|Int64|] ,[t|Integer|] ,[t|Word|] ,[t|Word8|] ,[t|Word16|] ,[t|Word32|] ,[t|Word64|] ,[t|Natural|] ]) #endif #if MIN_VERSION_base(4,12,0) deriving via (WrappedIntegral Int) instance Euclidean Int deriving via (WrappedIntegral Int8) instance Euclidean Int8 deriving via (WrappedIntegral Int16) instance Euclidean Int16 deriving via (WrappedIntegral Int32) instance Euclidean Int32 deriving via (WrappedIntegral Int64) instance Euclidean Int64 deriving via (WrappedIntegral Integer) instance Euclidean Integer deriving via (WrappedIntegral Word) instance Euclidean Word deriving via (WrappedIntegral Word8) instance Euclidean Word8 deriving via (WrappedIntegral Word16) instance Euclidean Word16 deriving via (WrappedIntegral Word32) instance Euclidean Word32 deriving via (WrappedIntegral Word64) instance Euclidean Word64 deriving via (WrappedIntegral Natural) instance Euclidean Natural #else $(let deriveEuclidean :: Q Type -> Q [Dec] deriveEuclidean ty = [d| instance Euclidean $ty where degree = P.fromIntegral . abs quotRem = P.quotRem quot = P.quot rem = P.rem |] in P.concat P.<$> P.traverse deriveEuclidean [[t|Int|] ,[t|Int8|] ,[t|Int16|] ,[t|Int32|] ,[t|Int64|] ,[t|Integer|] ,[t|Word|] ,[t|Word8|] ,[t|Word16|] ,[t|Word32|] ,[t|Word64|] ,[t|Natural|] ]) #endif semirings-0.6/Data/Field.hs0000644000000000000000000000310507346545000013777 0ustar0000000000000000-- | A 'Field' is a 'Data.Semiring.Ring' in which all nonzero elements -- have a multiplicative inverse. module Data.Field ( -- * Field typeclass Field , divide , fromRational , recip , (/) ) where import Prelude hiding (fromInteger, fromRational, negate, quot, recip, (/)) import Data.Euclidean (Field, quot) import Data.Ratio (denominator, numerator) import Data.Semiring (fromInteger, one) --------------------------------------------------------------------- -- Functions --------------------------------------------------------------------- -- | Divide two elements of a 'Field'. -- For any 'Prelude.Fractional' type, this is the same as '(Prelude./)'. -- -- @x `divide` y = x `Data.Semiring.times` 'recip' y@ divide :: Field a => a -> a -> a divide = quot {-# INLINE divide #-} infixl 7 `divide` -- | Invert an element of a 'Field'. -- For any 'Prelude.Fractional' type, this is the same as 'Prelude.recip'. -- -- @'recip' x `Data.Semiring.times` x = 'one'@ recip :: Field a => a -> a recip = quot one {-# INLINE recip #-} -- | Infix shorthand for 'divide'. (/) :: Field a => a -> a -> a (/) = quot {-# INLINE (/) #-} infixl 7 / -- | Convert from rational to field. -- -- When @{-#@ @LANGUAGE RebindableSyntax #-}@ is enabled, -- this function is used for desugaring rational literals (like, @2.37@). -- This may be used to facilitate transition from 'Fractional' to 'Field', -- because less casts are now required. fromRational :: Field a => Rational -> a fromRational x = quot (fromInteger (numerator x)) (fromInteger (denominator x)) {-# INLINE fromRational #-} semirings-0.6/Data/Semiring.hs0000644000000000000000000010373707346545000014545 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} #if MIN_VERSION_base(4,12,0) {-# LANGUAGE DerivingVia #-} #else {-# LANGUAGE TemplateHaskell #-} #endif ----------------------------------------------------------------------------- -- | -- A class for semirings (types with two binary operations, one commutative and one associative, and two respective identities), with various general-purpose instances. -- ----------------------------------------------------------------------------- module Data.Semiring ( -- * Semiring typeclass Semiring(..) , (+) , (*) , (^) , foldMapP , foldMapT , sum , product , sum' , product' , isZero , isOne -- * Types , Add(..) , Mul(..) , WrappedNum(..) , Mod2(..) #if defined(VERSION_containers) , IntSetOf(..) , IntMapOf(..) #endif -- * Ring typeclass , Ring(..) , fromInteger , fromIntegral , minus , (-) ) where import Control.Applicative (Applicative(..), Const(..), liftA2) import Data.Bits (Bits) import Data.Bool (Bool(..), (||), (&&), otherwise) import Data.Coerce (Coercible, coerce) import Data.Complex (Complex(..)) import Data.Eq (Eq(..)) import Data.Fixed (Fixed, HasResolution) import Data.Foldable (Foldable(foldMap)) import qualified Data.Foldable as Foldable import Data.Function ((.), const, id) #if defined(VERSION_unordered_containers) || defined(VERSION_containers) import Data.Function (flip) #endif import Data.Functor (Functor(..)) #if MIN_VERSION_base(4,12,0) import Data.Functor.Contravariant (Predicate(..), Equivalence(..), Op(..)) #endif import Data.Functor.Identity (Identity(..)) #if defined(VERSION_unordered_containers) import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet #endif import Data.Int (Int, Int8, Int16, Int32, Int64) import Data.Maybe (Maybe(..)) #if MIN_VERSION_base(4,12,0) import Data.Monoid (Ap(..)) #endif #if defined(VERSION_containers) #if MIN_VERSION_base(4,7,0) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet #endif import Data.Map (Map) import qualified Data.Map as Map #endif import Data.Monoid (Monoid(..), Dual(..)) import Data.Ord (Ord((<)), (>=)) import Data.Ord (Down(..)) import Data.Proxy (Proxy(..)) import Data.Ratio (Ratio, Rational, (%)) import Data.Semigroup.Compat (Semigroup(..)) #if defined(VERSION_containers) import Data.Set (Set) import qualified Data.Set as Set #endif import Data.Traversable (Traversable) import Data.Typeable (Typeable) import Data.Word (Word, Word8, Word16, Word32, Word64) 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 Foreign.Storable (Storable) import GHC.Enum (Enum, Bounded) import GHC.Err (error) import GHC.Float (Float, Double) import GHC.Generics (Generic,Generic1) import GHC.IO (IO) import qualified GHC.Num as Num import GHC.Read (Read) import GHC.Real (Integral, Fractional, Real, RealFrac) import qualified GHC.Real as Real import GHC.Show (Show) import Numeric.Natural (Natural) import Prelude (Integer) #if !MIN_VERSION_base(4,12,0) import Language.Haskell.TH.Syntax (Q, Dec, Type) import qualified Prelude as P #endif #ifdef mingw32_HOST_OS #define HOST_OS_WINDOWS 1 #else #define HOST_OS_WINDOWS 0 #endif #if !HOST_OS_WINDOWS import System.Posix.Types (CCc, CDev, CGid, CIno, CMode, CNlink, COff, CPid, CRLim, CSpeed, CSsize, CTcflag, CUid, Fd) #endif infixl 7 *, `times` infixl 6 +, `plus`, -, `minus` infixr 8 ^ {-------------------------------------------------------------------- Helpers --------------------------------------------------------------------} -- | Raise a number to a non-negative integral power. -- If the power is negative, this will call 'error'. {-# SPECIALISE [1] (^) :: Integer -> Integer -> Integer, Integer -> Int -> Integer, Int -> Int -> Int #-} {-# INLINABLE [1] (^) #-} -- See note [Inlining (^)] (^) :: (Semiring a, Integral b) => a -> b -> a x ^ y | y < 0 = error "Data.Semiring.^: negative power" | y == 0 = one | otherwise = getMul (stimes y (Mul x)) {- Note [Inlining (^)] ~~~~~~~~~~~~~~~~~~~ The INLINABLE pragma allows (^) to be specialised at its call sites. If it is called repeatedly at the same type, that can make a huge difference, because of those constants which can be repeatedly calculated. Currently the fromInteger calls are not floated because we get \d1 d2 x y -> blah after the gentle round of simplification. -} {- Rules for powers with known small exponent see Trac #5237 For small exponents, (^) is inefficient compared to manually expanding the multiplication tree. Here, rules for the most common exponent types are given. The range of exponents for which rules are given is quite arbitrary and kept small to not unduly increase the number of rules. It might be desirable to have corresponding rules also for exponents of other types (e.g., Word), but it's doubtful they would fire, since the exponents of other types tend to get floated out before the rule has a chance to fire. (Why?) Note: Trying to save multiplication by sharing the square for exponents 4 and 5 does not save time, indeed, for Double, it is up to twice slower, so the rules contain flat sequences of multiplications. -} {-# RULES "^0/Int" forall x. x ^ (0 :: Int) = one "^1/Int" forall x. x ^ (1 :: Int) = let u = x in u "^2/Int" forall x. x ^ (2 :: Int) = let u = x in u*u "^3/Int" forall x. x ^ (3 :: Int) = let u = x in u*u*u "^4/Int" forall x. x ^ (4 :: Int) = let u = x in u*u*u*u "^5/Int" forall x. x ^ (5 :: Int) = let u = x in u*u*u*u*u "^0/Integer" forall x. x ^ (0 :: Integer) = one "^1/Integer" forall x. x ^ (1 :: Integer) = let u = x in u "^2/Integer" forall x. x ^ (2 :: Integer) = let u = x in u*u "^3/Integer" forall x. x ^ (3 :: Integer) = let u = x in u*u*u "^4/Integer" forall x. x ^ (4 :: Integer) = let u = x in u*u*u*u "^5/Integer" forall x. x ^ (5 :: Integer) = let u = x in u*u*u*u*u #-} -- | Infix shorthand for 'plus'. (+) :: Semiring a => a -> a -> a (+) = plus {-# INLINE (+) #-} -- | Infix shorthand for 'times'. (*) :: Semiring a => a -> a -> a (*) = times {-# INLINE (*) #-} -- | Infix shorthand for 'minus'. (-) :: Ring a => a -> a -> a (-) = minus {-# INLINE (-) #-} -- | Map each element of the structure to a semiring, and combine the results -- using 'plus'. foldMapP :: (Foldable t, Semiring s) => (a -> s) -> t a -> s foldMapP f = Foldable.foldr (plus . f) zero {-# INLINE foldMapP #-} -- | Map each element of the structure to a semiring, and combine the results -- using 'times'. foldMapT :: (Foldable t, Semiring s) => (a -> s) -> t a -> s foldMapT f = Foldable.foldr (times . f) one {-# INLINE foldMapT #-} infixr 9 #. (#.) :: Coercible b c => (b -> c) -> (a -> b) -> a -> c (#.) _ = coerce -- | The 'sum' function computes the additive sum of the elements in a structure. -- This function is lazy. For a strict version, see 'sum''. sum :: (Foldable t, Semiring a) => t a -> a sum = getAdd #. foldMap Add {-# INLINE sum #-} -- | The 'product' function computes the product of the elements in a structure. -- This function is lazy. for a strict version, see 'product''. product :: (Foldable t, Semiring a) => t a -> a product = getMul #. foldMap Mul {-# INLINE product #-} -- | The 'sum'' function computes the additive sum of the elements in a structure. -- This function is strict. For a lazy version, see 'sum'. sum' :: (Foldable t, Semiring a) => t a -> a sum' = Foldable.foldl' plus zero {-# INLINE sum' #-} -- | The 'product'' function computes the additive sum of the elements in a structure. -- This function is strict. For a lazy version, see 'product'. product' :: (Foldable t, Semiring a) => t a -> a product' = Foldable.foldl' times one {-# INLINE product' #-} -- | Monoid under 'plus'. Analogous to 'Data.Monoid.Sum', but -- uses the 'Semiring' constraint rather than 'Num.Num'. newtype Add a = Add { getAdd :: a } deriving ( Bounded , Enum , Eq , Foldable , Fractional , Functor , Generic , Generic1 , Num.Num , Ord , Read , Real , RealFrac , Show , Storable , Traversable , Typeable ) instance Semiring a => Semigroup (Add a) where Add a <> Add b = Add (a + b) stimes n (Add a) = Add (fromNatural (Real.fromIntegral n) * a) {-# INLINE (<>) #-} instance Semiring a => Monoid (Add a) where mempty = Add zero mappend = (<>) {-# INLINE mempty #-} {-# INLINE mappend #-} -- | This is an internal type, solely for purposes -- of default implementation of 'fromNatural'. newtype Add' a = Add' { getAdd' :: a } instance Semiring a => Semigroup (Add' a) where Add' a <> Add' b = Add' (a + b) -- | Monoid under 'times'. Analogous to 'Data.Monoid.Product', but -- uses the 'Semiring' constraint rather than 'Num.Num'. newtype Mul a = Mul { getMul :: a } deriving ( Bounded , Enum , Eq , Foldable , Fractional , Functor , Generic , Generic1 , Num.Num , Ord , Read , Real , RealFrac , Show , Storable , Traversable , Typeable ) instance Semiring a => Semigroup (Mul a) where Mul a <> Mul b = Mul (a * b) {-# INLINE (<>) #-} instance Semiring a => Monoid (Mul a) where mempty = Mul one mappend = (<>) {-# INLINE mempty #-} {-# INLINE mappend #-} -- | Provide Semiring and Ring for an arbitrary 'Num.Num'. It is useful with GHC 8.6+'s DerivingVia extension. newtype WrappedNum a = WrapNum { unwrapNum :: a } deriving ( Bounded , Enum , Eq , Foldable , Fractional , Functor , Generic , Generic1 , Num.Num , Ord , Read , Real , RealFrac , Show , Storable , Traversable , Typeable , Bits ) instance Num.Num a => Semiring (WrappedNum a) where plus = (Num.+) zero = 0 times = (Num.*) one = 1 fromNatural = Real.fromIntegral instance Num.Num a => Ring (WrappedNum a) where negate = Num.negate -- | 'Mod2' represents the integers mod 2. -- -- It is useful in the computing of . newtype Mod2 = Mod2 { getMod2 :: Bool } deriving ( Bounded , Enum , Eq , Ord , Read , Show , Generic ) instance Semiring Mod2 where -- we inline the definition of 'xor' -- on Bools, since the instance did not exist until -- base-4.7.0. plus (Mod2 x) (Mod2 y) = Mod2 (x /= y) times (Mod2 x) (Mod2 y) = Mod2 (x && y) zero = Mod2 False one = Mod2 True instance Ring Mod2 where negate = id {-# INLINE negate #-} {-------------------------------------------------------------------- Classes --------------------------------------------------------------------} -- | The class of semirings (types with two binary -- operations and two respective identities). One -- can think of a semiring as two monoids of the same -- underlying type, with the first being commutative. -- In the documentation, you will often see the first -- monoid being referred to as @additive@, and the second -- monoid being referred to as @multiplicative@, a typical -- convention when talking about semirings. -- -- For any type R with a 'Num.Num' -- instance, the additive monoid is (R, 'Prelude.+', 0) -- and the multiplicative monoid is (R, 'Prelude.*', 1). -- -- For 'Prelude.Bool', the additive monoid is ('Prelude.Bool', 'Prelude.||', 'Prelude.False') -- and the multiplicative monoid is ('Prelude.Bool', 'Prelude.&&', 'Prelude.True'). -- -- Instances should satisfy the following laws: -- -- [/additive left identity/] -- @'zero' '+' x = x@ -- [/additive right identity/] -- @x '+' 'zero' = x@ -- [/additive associativity/] -- @x '+' (y '+' z) = (x '+' y) '+' z@ -- [/additive commutativity/] -- @x '+' y = y '+' x@ -- [/multiplicative left identity/] -- @'one' '*' x = x@ -- [/multiplicative right identity/] -- @x '*' 'one' = x@ -- [/multiplicative associativity/] -- @x '*' (y '*' z) = (x '*' y) '*' z@ -- [/left-distributivity of '*' over '+'/] -- @x '*' (y '+' z) = (x '*' y) '+' (x '*' z)@ -- [/right-distributivity of '*' over '+'/] -- @(x '+' y) '*' z = (x '*' z) '+' (y '*' z)@ -- [/annihilation/] -- @'zero' '*' x = x '*' 'zero' = 'zero'@ class Semiring a where #if __GLASGOW_HASKELL__ >= 708 {-# MINIMAL plus, times, (zero, one | fromNatural) #-} #endif plus :: a -> a -> a -- ^ Commutative Operation zero :: a -- ^ Commutative Unit zero = fromNatural 0 times :: a -> a -> a -- ^ Associative Operation one :: a -- ^ Associative Unit one = fromNatural 1 fromNatural :: Natural -> a -- ^ Homomorphism of additive semigroups fromNatural 0 = zero fromNatural n = getAdd' (stimes n (Add' one)) -- | The class of semirings with an additive inverse. -- -- @'negate' a '+' a = 'zero'@ class Semiring a => Ring a where #if __GLASGOW_HASKELL__ >= 708 {-# MINIMAL negate #-} #endif negate :: a -> a -- | Subtract two 'Ring' values. For any type @R@ with -- a 'Num.Num' instance, this is the same as '(Prelude.-)'. -- -- @x `minus` y = x '+' 'negate' y@ minus :: Ring a => a -> a -> a minus x y = x + negate y {-# INLINE minus #-} -- | Convert from integer to ring. -- -- When @{-#@ @LANGUAGE RebindableSyntax #-}@ is enabled, -- this function is used for desugaring integer literals. -- This may be used to facilitate transition from 'Num.Num' to 'Ring': -- no need to replace 0 and 1 with 'one' and 'zero' -- or to cast numeric literals. fromInteger :: Ring a => Integer -> a fromInteger x | x >= 0 = fromNatural (Num.fromInteger x) | otherwise = negate (fromNatural (Num.fromInteger (Num.negate x))) {-# INLINE fromInteger #-} -- | Convert from integral to ring. fromIntegral :: (Integral a, Ring b) => a -> b fromIntegral x | x >= 0 = fromNatural (Real.fromIntegral x) | otherwise = negate (fromNatural (Real.fromIntegral (Num.negate x))) {-# INLINE fromIntegral #-} {-------------------------------------------------------------------- Instances (base) --------------------------------------------------------------------} instance Semiring b => Semiring (a -> b) where plus f g = \x -> f x `plus` g x zero = const zero times f g = \x -> f x `times` g x one = const one fromNatural = const . fromNatural {-# INLINE plus #-} {-# INLINE zero #-} {-# INLINE times #-} {-# INLINE one #-} {-# INLINE fromNatural #-} instance Ring b => Ring (a -> b) where negate f x = negate (f x) {-# INLINE negate #-} instance Semiring () where plus _ _ = () zero = () times _ _ = () one = () fromNatural _ = () {-# INLINE plus #-} {-# INLINE zero #-} {-# INLINE times #-} {-# INLINE one #-} {-# INLINE fromNatural #-} instance Ring () where negate _ = () {-# INLINE negate #-} instance Semiring (Proxy a) where plus _ _ = Proxy zero = Proxy times _ _ = Proxy one = Proxy fromNatural _ = Proxy {-# INLINE plus #-} {-# INLINE zero #-} {-# INLINE times #-} {-# INLINE one #-} {-# INLINE fromNatural #-} instance Semiring Bool where plus = (||) zero = False times = (&&) one = True fromNatural 0 = False fromNatural _ = True {-# INLINE plus #-} {-# INLINE zero #-} {-# INLINE times #-} {-# INLINE one #-} {-# INLINE fromNatural #-} instance Semiring a => Semiring (Maybe a) where zero = Nothing one = Just one plus Nothing y = y plus x Nothing = x plus (Just x) (Just y) = Just (plus x y) times Nothing _ = Nothing times _ Nothing = Nothing times (Just x) (Just y) = Just (times x y) fromNatural 0 = Nothing fromNatural n = Just (fromNatural n) {-# INLINE plus #-} {-# INLINE zero #-} {-# INLINE times #-} {-# INLINE one #-} {-# INLINE fromNatural #-} instance Semiring a => Semiring (IO a) where zero = pure zero one = pure one plus = liftA2 plus times = liftA2 times fromNatural = pure . fromNatural {-# INLINE plus #-} {-# INLINE zero #-} {-# INLINE times #-} {-# INLINE one #-} {-# INLINE fromNatural #-} instance Ring a => Ring (IO a) where negate = fmap negate {-# INLINE negate #-} instance Semiring a => Semiring (Dual a) where zero = Dual zero Dual x `plus` Dual y = Dual (y `plus` x) one = Dual one Dual x `times` Dual y = Dual (y `times` x) fromNatural = Dual . fromNatural {-# INLINE plus #-} {-# INLINE zero #-} {-# INLINE times #-} {-# INLINE one #-} {-# INLINE fromNatural #-} instance Ring a => Ring (Dual a) where negate (Dual x) = Dual (negate x) {-# INLINE negate #-} instance Semiring a => Semiring (Const a b) where zero = Const zero one = Const one plus (Const x) (Const y) = Const (x `plus` y) times (Const x) (Const y) = Const (x `times` y) fromNatural = Const . fromNatural {-# INLINE plus #-} {-# INLINE zero #-} {-# INLINE times #-} {-# INLINE one #-} {-# INLINE fromNatural #-} instance Ring a => Ring (Const a b) where negate (Const x) = Const (negate x) {-# INLINE negate #-} -- | This instance can suffer due to floating point arithmetic. instance Ring a => Semiring (Complex a) where zero = zero :+ zero one = one :+ zero plus (x :+ y) (x' :+ y') = plus x x' :+ plus y y' times (x :+ y) (x' :+ y') = (x * x' - (y * y')) :+ (x * y' + y * x') fromNatural n = fromNatural n :+ zero {-# INLINE plus #-} {-# INLINE zero #-} {-# INLINE times #-} {-# INLINE one #-} {-# INLINE fromNatural #-} instance Ring a => Ring (Complex a) where negate (x :+ y) = negate x :+ negate y {-# INLINE negate #-} #if MIN_VERSION_base(4,12,0) instance (Semiring a, Applicative f) => Semiring (Ap f a) where zero = pure zero one = pure one plus = liftA2 plus times = liftA2 times fromNatural = pure . fromNatural {-# INLINE plus #-} {-# INLINE zero #-} {-# INLINE times #-} {-# INLINE one #-} {-# INLINE fromNatural #-} instance (Ring a, Applicative f) => Ring (Ap f a) where negate = fmap negate {-# INLINE negate #-} #endif #if MIN_VERSION_base(4,12,0) deriving instance Semiring (Predicate a) deriving instance Semiring a => Semiring (Equivalence a) deriving instance Semiring a => Semiring (Op a b) deriving instance Ring a => Ring (Op a b) #endif instance Integral a => Semiring (Ratio a) where {-# SPECIALIZE instance Semiring Rational #-} zero = 0 % 1 one = 1 % 1 plus = (Num.+) times = (Num.*) fromNatural n = Real.fromIntegral n % 1 {-# INLINE zero #-} {-# INLINE one #-} {-# INLINE plus #-} {-# INLINE times #-} {-# INLINE fromNatural #-} deriving instance Semiring a => Semiring (Identity a) deriving instance Semiring a => Semiring (Down a) instance HasResolution a => Semiring (Fixed a) where zero = 0 one = 1 plus = (Num.+) times = (Num.*) fromNatural = Real.fromIntegral {-# INLINE zero #-} {-# INLINE one #-} {-# INLINE plus #-} {-# INLINE times #-} {-# INLINE fromNatural #-} instance Integral a => Ring (Ratio a) where negate = Num.negate {-# INLINE negate #-} deriving instance Ring a => Ring (Down a) deriving instance Ring a => Ring (Identity a) instance HasResolution a => Ring (Fixed a) where negate = Num.negate {-# INLINE negate #-} {-------------------------------------------------------------------- Instances (containers) --------------------------------------------------------------------} #if defined(VERSION_containers) -- | The multiplication laws are satisfied for -- any underlying 'Monoid', so we require a -- 'Monoid' constraint instead of a 'Semiring' -- constraint since 'times' can use -- the context of either. instance (Ord a, Monoid a) => Semiring (Set a) where zero = Set.empty one = Set.singleton mempty plus = Set.union times xs ys = Foldable.foldMap (flip Set.map ys . mappend) xs fromNatural 0 = zero fromNatural _ = one {-# INLINE plus #-} {-# INLINE zero #-} {-# INLINE times #-} {-# INLINE one #-} {-# INLINE fromNatural #-} -- | Wrapper to mimic 'Set' ('Data.Semigroup.Sum' 'Int'), -- 'Set' ('Data.Semigroup.Product' 'Int'), etc., -- while having a more efficient underlying representation. newtype IntSetOf a = IntSetOf { getIntSet :: IntSet } deriving ( Eq , Generic , Generic1 , Ord , Read , Show , Typeable , Semigroup , Monoid ) instance (Coercible Int a, Monoid a) => Semiring (IntSetOf a) where zero = coerce IntSet.empty one = coerce IntSet.singleton (mempty :: a) plus = coerce IntSet.union xs `times` ys = coerce IntSet.fromList [ mappend k l | k :: a <- coerce IntSet.toList xs , l :: a <- coerce IntSet.toList ys ] fromNatural 0 = zero fromNatural _ = one {-# INLINE plus #-} {-# INLINE zero #-} {-# INLINE times #-} {-# INLINE one #-} {-# INLINE fromNatural #-} -- | The multiplication laws are satisfied for -- any underlying 'Monoid' as the key type, -- so we require a 'Monoid' constraint instead of -- a 'Semiring' constraint since 'times' can use -- the context of either. instance (Ord k, Monoid k, Semiring v) => Semiring (Map k v) where zero = Map.empty one = Map.singleton mempty one plus = Map.unionWith (+) xs `times` ys = Map.fromListWith (+) [ (mappend k l, v * u) | (k,v) <- Map.toList xs , (l,u) <- Map.toList ys ] fromNatural 0 = zero fromNatural n = Map.singleton mempty (fromNatural n) {-# INLINE plus #-} {-# INLINE zero #-} {-# INLINE times #-} {-# INLINE one #-} {-# INLINE fromNatural #-} -- | Wrapper to mimic 'Map' ('Data.Semigroup.Sum' 'Int') v, -- 'Map' ('Data.Semigroup.Product' 'Int') v, etc., -- while having a more efficient underlying representation. newtype IntMapOf k v = IntMapOf { getIntMap :: IntMap v } deriving ( Eq , Generic , Generic1 , Ord , Read , Show , Typeable , Semigroup , Monoid ) instance (Coercible Int k, Monoid k, Semiring v) => Semiring (IntMapOf k v) where zero = coerce (IntMap.empty :: IntMap v) one = coerce (IntMap.singleton :: Int -> v -> IntMap v) (mempty :: k) (one :: v) plus = coerce (IntMap.unionWith (+) :: IntMap v -> IntMap v -> IntMap v) xs `times` ys = coerce (IntMap.fromListWith (+) :: [(Int, v)] -> IntMap v) [ (mappend k l, v * u) | (k :: k, v :: v) <- coerce (IntMap.toList :: IntMap v -> [(Int, v)]) xs , (l :: k, u :: v) <- coerce (IntMap.toList :: IntMap v -> [(Int, v)]) ys ] fromNatural 0 = zero fromNatural n = coerce (IntMap.singleton :: Int -> v -> IntMap v) (mempty :: k) (fromNatural n :: v) {-# INLINE plus #-} {-# INLINE zero #-} {-# INLINE times #-} {-# INLINE one #-} {-# INLINE fromNatural #-} #endif {-------------------------------------------------------------------- Instances (unordered-containers) --------------------------------------------------------------------} #if defined(VERSION_unordered_containers) -- | The multiplication laws are satisfied for -- any underlying 'Monoid', so we require a -- 'Monoid' constraint instead of a 'Semiring' -- constraint since 'times' can use -- the context of either. instance (Eq a, Hashable a, Monoid a) => Semiring (HashSet a) where zero = HashSet.empty one = HashSet.singleton mempty plus = HashSet.union times xs ys = Foldable.foldMap (flip HashSet.map ys . mappend) xs fromNatural 0 = zero fromNatural _ = one {-# INLINE plus #-} {-# INLINE zero #-} {-# INLINE times #-} {-# INLINE one #-} {-# INLINE fromNatural #-} -- | The multiplication laws are satisfied for -- any underlying 'Monoid' as the key type, -- so we require a 'Monoid' constraint instead of -- a 'Semiring' constraint since 'times' can use -- the context of either. instance (Eq k, Hashable k, Monoid k, Semiring v) => Semiring (HashMap k v) where zero = HashMap.empty one = HashMap.singleton mempty one plus = HashMap.unionWith (+) xs `times` ys = HashMap.fromListWith (+) [ (mappend k l, v * u) | (k,v) <- HashMap.toList xs , (l,u) <- HashMap.toList ys ] fromNatural 0 = zero fromNatural n = HashMap.singleton mempty (fromNatural n) {-# INLINE plus #-} {-# INLINE zero #-} {-# INLINE times #-} {-# INLINE one #-} {-# INLINE fromNatural #-} #endif -- | Is the value 'zero'? isZero :: (Eq a, Semiring a) => a -> Bool isZero x = x == zero {-# INLINEABLE isZero #-} -- | Is the value 'one'? isOne :: (Eq a, Semiring a) => a -> Bool isOne x = x == one {-# INLINEABLE isOne #-} #if MIN_VERSION_base(4,12,0) deriving via (WrappedNum Int) instance Semiring Int deriving via (WrappedNum Int8) instance Semiring Int8 deriving via (WrappedNum Int16) instance Semiring Int16 deriving via (WrappedNum Int32) instance Semiring Int32 deriving via (WrappedNum Int64) instance Semiring Int64 deriving via (WrappedNum Integer) instance Semiring Integer deriving via (WrappedNum Word) instance Semiring Word deriving via (WrappedNum Word8) instance Semiring Word8 deriving via (WrappedNum Word16) instance Semiring Word16 deriving via (WrappedNum Word32) instance Semiring Word32 deriving via (WrappedNum Word64) instance Semiring Word64 deriving via (WrappedNum Float) instance Semiring Float deriving via (WrappedNum Double) instance Semiring Double deriving via (WrappedNum CUIntMax) instance Semiring CUIntMax deriving via (WrappedNum CIntMax) instance Semiring CIntMax deriving via (WrappedNum CUIntPtr) instance Semiring CUIntPtr deriving via (WrappedNum CIntPtr) instance Semiring CIntPtr deriving via (WrappedNum CSUSeconds) instance Semiring CSUSeconds deriving via (WrappedNum CUSeconds) instance Semiring CUSeconds deriving via (WrappedNum CTime) instance Semiring CTime deriving via (WrappedNum CClock) instance Semiring CClock deriving via (WrappedNum CSigAtomic) instance Semiring CSigAtomic deriving via (WrappedNum CWchar) instance Semiring CWchar deriving via (WrappedNum CSize) instance Semiring CSize deriving via (WrappedNum CPtrdiff) instance Semiring CPtrdiff deriving via (WrappedNum CDouble) instance Semiring CDouble deriving via (WrappedNum CFloat) instance Semiring CFloat deriving via (WrappedNum CULLong) instance Semiring CULLong deriving via (WrappedNum CLLong) instance Semiring CLLong deriving via (WrappedNum CULong) instance Semiring CULong deriving via (WrappedNum CLong) instance Semiring CLong deriving via (WrappedNum CUInt) instance Semiring CUInt deriving via (WrappedNum CInt) instance Semiring CInt deriving via (WrappedNum CUShort) instance Semiring CUShort deriving via (WrappedNum CShort) instance Semiring CShort deriving via (WrappedNum CUChar) instance Semiring CUChar deriving via (WrappedNum CSChar) instance Semiring CSChar deriving via (WrappedNum CChar) instance Semiring CChar deriving via (WrappedNum IntPtr) instance Semiring IntPtr deriving via (WrappedNum WordPtr) instance Semiring WordPtr #if !HOST_OS_WINDOWS deriving via (WrappedNum CCc) instance Semiring CCc deriving via (WrappedNum CDev) instance Semiring CDev deriving via (WrappedNum CGid) instance Semiring CGid deriving via (WrappedNum CIno) instance Semiring CIno deriving via (WrappedNum CMode) instance Semiring CMode deriving via (WrappedNum CNlink) instance Semiring CNlink deriving via (WrappedNum COff) instance Semiring COff deriving via (WrappedNum CPid) instance Semiring CPid deriving via (WrappedNum CRLim) instance Semiring CRLim deriving via (WrappedNum CSpeed) instance Semiring CSpeed deriving via (WrappedNum CSsize) instance Semiring CSsize deriving via (WrappedNum CTcflag) instance Semiring CTcflag deriving via (WrappedNum CUid) instance Semiring CUid deriving via (WrappedNum Fd) instance Semiring Fd #endif deriving via (WrappedNum Natural) instance Semiring Natural #else -- Integral and fieldlike instances $(let deriveSemiring :: Q Type -> Q [Dec] deriveSemiring ty = [d| instance Semiring $ty where zero = 0 one = 1 plus x y = (Num.+) x y times x y = (Num.*) x y fromNatural = Real.fromIntegral {-# INLINE zero #-} {-# INLINE one #-} {-# INLINE plus #-} {-# INLINE times #-} {-# INLINE fromNatural #-} |] in P.concat P.<$> P.traverse deriveSemiring [[t|Int|] ,[t|Int8|] ,[t|Int16|] ,[t|Int32|] ,[t|Int64|] ,[t|Integer|] ,[t|Word|] ,[t|Word8|] ,[t|Word16|] ,[t|Word32|] ,[t|Word64|] ,[t|Float|] ,[t|Double|] ,[t|CUIntMax|] ,[t|CIntMax|] ,[t|CUIntPtr|] ,[t|CIntPtr|] ,[t|CSUSeconds|] ,[t|CUSeconds|] ,[t|CTime|] ,[t|CClock|] ,[t|CSigAtomic|] ,[t|CWchar|] ,[t|CSize|] ,[t|CPtrdiff|] ,[t|CDouble|] ,[t|CFloat|] ,[t|CULLong|] ,[t|CLLong|] ,[t|CULong|] ,[t|CLong|] ,[t|CUInt|] ,[t|CInt|] ,[t|CUShort|] ,[t|CShort|] ,[t|CUChar|] ,[t|CSChar|] ,[t|CChar|] ,[t|IntPtr|] ,[t|WordPtr|] #if !HOST_OS_WINDOWS ,[t|CCc|] ,[t|CDev|] ,[t|CGid|] ,[t|CIno|] ,[t|CMode|] ,[t|CNlink|] ,[t|COff|] ,[t|CPid|] ,[t|CRLim|] ,[t|CSpeed|] ,[t|CSsize|] ,[t|CTcflag|] ,[t|CUid|] ,[t|Fd|] #endif ,[t|Natural|] ]) #endif #if MIN_VERSION_base(4,12,0) deriving via (WrappedNum Int) instance Ring Int deriving via (WrappedNum Int8) instance Ring Int8 deriving via (WrappedNum Int16) instance Ring Int16 deriving via (WrappedNum Int32) instance Ring Int32 deriving via (WrappedNum Int64) instance Ring Int64 deriving via (WrappedNum Integer) instance Ring Integer deriving via (WrappedNum Word) instance Ring Word deriving via (WrappedNum Word8) instance Ring Word8 deriving via (WrappedNum Word16) instance Ring Word16 deriving via (WrappedNum Word32) instance Ring Word32 deriving via (WrappedNum Word64) instance Ring Word64 deriving via (WrappedNum Float) instance Ring Float deriving via (WrappedNum Double) instance Ring Double deriving via (WrappedNum CUIntMax) instance Ring CUIntMax deriving via (WrappedNum CIntMax) instance Ring CIntMax deriving via (WrappedNum CUIntPtr) instance Ring CUIntPtr deriving via (WrappedNum CIntPtr) instance Ring CIntPtr deriving via (WrappedNum CSUSeconds) instance Ring CSUSeconds deriving via (WrappedNum CUSeconds) instance Ring CUSeconds deriving via (WrappedNum CTime) instance Ring CTime deriving via (WrappedNum CClock) instance Ring CClock deriving via (WrappedNum CSigAtomic) instance Ring CSigAtomic deriving via (WrappedNum CWchar) instance Ring CWchar deriving via (WrappedNum CSize) instance Ring CSize deriving via (WrappedNum CPtrdiff) instance Ring CPtrdiff deriving via (WrappedNum CDouble) instance Ring CDouble deriving via (WrappedNum CFloat) instance Ring CFloat deriving via (WrappedNum CULLong) instance Ring CULLong deriving via (WrappedNum CLLong) instance Ring CLLong deriving via (WrappedNum CULong) instance Ring CULong deriving via (WrappedNum CLong) instance Ring CLong deriving via (WrappedNum CUInt) instance Ring CUInt deriving via (WrappedNum CInt) instance Ring CInt deriving via (WrappedNum CUShort) instance Ring CUShort deriving via (WrappedNum CShort) instance Ring CShort deriving via (WrappedNum CUChar) instance Ring CUChar deriving via (WrappedNum CSChar) instance Ring CSChar deriving via (WrappedNum CChar) instance Ring CChar deriving via (WrappedNum IntPtr) instance Ring IntPtr deriving via (WrappedNum WordPtr) instance Ring WordPtr #if !HOST_OS_WINDOWS deriving via (WrappedNum CCc) instance Ring CCc deriving via (WrappedNum CDev) instance Ring CDev deriving via (WrappedNum CGid) instance Ring CGid deriving via (WrappedNum CIno) instance Ring CIno deriving via (WrappedNum CMode) instance Ring CMode deriving via (WrappedNum CNlink) instance Ring CNlink deriving via (WrappedNum COff) instance Ring COff deriving via (WrappedNum CPid) instance Ring CPid deriving via (WrappedNum CRLim) instance Ring CRLim deriving via (WrappedNum CSpeed) instance Ring CSpeed deriving via (WrappedNum CSsize) instance Ring CSsize deriving via (WrappedNum CTcflag) instance Ring CTcflag deriving via (WrappedNum CUid) instance Ring CUid deriving via (WrappedNum Fd) instance Ring Fd #endif #else $(let deriveRing :: Q Type -> Q [Dec] deriveRing ty = [d| instance Ring $ty where negate = Num.negate {-# INLINE negate #-} |] in P.concat P.<$> P.traverse deriveRing [[t|Int|] ,[t|Int8|] ,[t|Int16|] ,[t|Int32|] ,[t|Int64|] ,[t|Integer|] ,[t|Word|] ,[t|Word8|] ,[t|Word16|] ,[t|Word32|] ,[t|Word64|] ,[t|Float|] ,[t|Double|] ,[t|CUIntMax|] ,[t|CIntMax|] ,[t|CUIntPtr|] ,[t|CIntPtr|] ,[t|CSUSeconds|] ,[t|CUSeconds|] ,[t|CTime|] ,[t|CClock|] ,[t|CSigAtomic|] ,[t|CWchar|] ,[t|CSize|] ,[t|CPtrdiff|] ,[t|CDouble|] ,[t|CFloat|] ,[t|CULLong|] ,[t|CLLong|] ,[t|CULong|] ,[t|CLong|] ,[t|CUInt|] ,[t|CInt|] ,[t|CUShort|] ,[t|CShort|] ,[t|CUChar|] ,[t|CSChar|] ,[t|CChar|] ,[t|IntPtr|] ,[t|WordPtr|] #if !HOST_OS_WINDOWS ,[t|CCc|] ,[t|CDev|] ,[t|CGid|] ,[t|CIno|] ,[t|CMode|] ,[t|CNlink|] ,[t|COff|] ,[t|CPid|] ,[t|CRLim|] ,[t|CSpeed|] ,[t|CSsize|] ,[t|CTcflag|] ,[t|CUid|] ,[t|Fd|] #endif ]) #endif semirings-0.6/Data/Semiring/0000755000000000000000000000000007346545000014176 5ustar0000000000000000semirings-0.6/Data/Semiring/Generic.hs0000644000000000000000000001532307346545000016112 0ustar0000000000000000{-# LANGUAGE CPP #-} #if MIN_VERSION_base(4,6,0) {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} #endif -- below are safe orphan instances {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Semiring.Generic -- Copyright : (C) 2018 chessai -- License : MIT (see the file LICENSE) -- -- Maintainer : chessai -- Stability : provisional -- Portability : portable -- -- This module provides generic deriving tools for semirings and rings for -- product-like structures. -- ---------------------------------------------------------------------------- module Data.Semiring.Generic ( #if MIN_VERSION_base(4,6,0) GSemiring(..) , gzero , gone , gplus , gtimes , gfromNatural , GRing(..) , gnegate , GenericSemiring(..) #endif ) where #if MIN_VERSION_base(4,6,0) import Data.Semiring import GHC.Generics import Numeric.Natural (Natural) import Prelude hiding (Num(..)) -- | An Identity-style wrapper with a 'Generic' interface -- to be used with '-XDerivingVia'. newtype GenericSemiring a = GenericSemiring a instance (Generic a, GSemiring (Rep a)) => Semiring (GenericSemiring a) where zero = GenericSemiring gzero one = GenericSemiring gone plus (GenericSemiring x) (GenericSemiring y) = GenericSemiring (gplus x y) times (GenericSemiring x) (GenericSemiring y) = GenericSemiring (gtimes x y) fromNatural x = GenericSemiring (gfromNatural x) instance (Semiring a, Semiring b) => Semiring (a,b) where zero = gzero; one = gone; plus = gplus; times = gtimes; fromNatural = gfromNatural; instance (Semiring a, Semiring b, Semiring c) => Semiring (a,b,c) where zero = gzero; one = gone; plus = gplus; times = gtimes; fromNatural = gfromNatural; instance (Semiring a, Semiring b, Semiring c, Semiring d) => Semiring (a,b,c,d) where zero = gzero; one = gone; plus = gplus; times = gtimes; fromNatural = gfromNatural; instance (Semiring a, Semiring b, Semiring c, Semiring d, Semiring e) => Semiring (a,b,c,d,e) where zero = gzero; one = gone; plus = gplus; times = gtimes; fromNatural = gfromNatural; instance (Semiring a, Semiring b, Semiring c, Semiring d, Semiring e, Semiring f) => Semiring (a,b,c,d,e,f) where zero = gzero; one = gone; plus = gplus; times = gtimes; fromNatural = gfromNatural; instance (Semiring a, Semiring b, Semiring c, Semiring d, Semiring e, Semiring f, Semiring g) => Semiring (a,b,c,d,e,f,g) where zero = gzero; one = gone; plus = gplus; times = gtimes; fromNatural = gfromNatural; instance (Ring a, Ring b) => Ring (a,b) where negate = gnegate instance (Ring a, Ring b, Ring c) => Ring (a,b,c) where negate = gnegate instance (Ring a, Ring b, Ring c, Ring d) => Ring (a,b,c,d) where negate = gnegate instance (Ring a, Ring b, Ring c, Ring d, Ring e) => Ring (a,b,c,d,e) where negate = gnegate instance (Ring a, Ring b, Ring c, Ring d, Ring e, Ring f) => Ring (a,b,c,d,e,f) where negate = gnegate instance (Ring a, Ring b, Ring c, Ring d, Ring e, Ring f, Ring g) => Ring (a,b,c,d,e,f,g) where negate = gnegate {-------------------------------------------------------------------- Generics --------------------------------------------------------------------} -- | Generic 'Semiring' class, used to implement 'plus', 'times', 'zero', -- and 'one' for product-like types implementing 'Generic'. class GSemiring f where #if __GLASGOW_HASKELL__ >= 708 {-# MINIMAL gplus', gzero', gtimes', gone', gfromNatural' #-} #endif gzero' :: f a gone' :: f a gplus' :: f a -> f a -> f a gtimes' :: f a -> f a -> f a gfromNatural' :: Natural -> f a -- | Generic 'Ring' class, used to implement 'negate' for product-like -- types implementing 'Generic'. class GRing f where #if __GLASGOW_HASKELL__ >= 708 {-# MINIMAL gnegate' #-} #endif gnegate' :: f a -> f a -- | Generically generate a 'Semiring' 'zero' for any product-like type -- implementing 'Generic'. -- -- It is only defined for product types. -- -- @ -- 'gplus' 'gzero' a = a = 'gplus' a 'gzero' -- @ gzero :: (Generic a, GSemiring (Rep a)) => a gzero = to gzero' -- | Generically generate a 'Semiring' 'one' for any product-like type -- implementing 'Generic'. -- -- It is only defined for product types. -- -- @ -- 'gtimes' 'gone' a = a = 'gtimes' a 'gone' -- @ gone :: (Generic a, GSemiring (Rep a)) => a gone = to gone' -- | Generically generate a 'Semiring' 'plus' operation for any type -- implementing 'Generic'. It is only defined for product types. -- -- @ -- 'gplus' a b = 'gplus' b a -- @ gplus :: (Generic a, GSemiring (Rep a)) => a -> a -> a gplus x y = to $ from x `gplus'` from y -- | Generically generate a 'Semiring' 'times' operation for any type -- implementing 'Generic'. It is only defined for product types. -- -- @ -- 'gtimes' a ('gtimes' b c) = 'gtimes' ('gtimes' a b) c -- 'gtimes' a 'gzero' = 'gzero' = 'gtimes' 'gzero' a -- @ gtimes :: (Generic a, GSemiring (Rep a)) => a -> a -> a gtimes x y = to $ from x `gtimes'` from y -- | Generically generate a 'Semiring' 'fromNatural' for any product-like type -- implementing 'Generic'. -- -- It is only defined for product types. gfromNatural :: (Generic a, GSemiring (Rep a)) => Natural -> a gfromNatural = to . gfromNatural' -- | Generically generate a 'Ring' 'negate' operation for any type -- implementing 'Generic'. It is only defined for product types. -- -- @ -- 'gplus' a ('gnegate' a) = 'zero' -- @ gnegate :: (Generic a, GRing (Rep a)) => a -> a gnegate x = to $ gnegate' $ from x instance GSemiring U1 where gzero' = U1 gone' = U1 gplus' _ _ = U1 gtimes' _ _ = U1 gfromNatural' _ = U1 instance GRing U1 where gnegate' _ = U1 instance (GSemiring a, GSemiring b) => GSemiring (a :*: b) where gzero' = gzero' :*: gzero' gone' = gone' :*: gone' gplus' (a :*: b) (c :*: d) = gplus' a c :*: gplus' b d gtimes' (a :*: b) (c :*: d) = gtimes' a c :*: gtimes' b d gfromNatural' n = gfromNatural' n :*: gfromNatural' n instance (GRing a, GRing b) => GRing (a :*: b) where gnegate' (a :*: b) = gnegate' a :*: gnegate' b instance (GSemiring a) => GSemiring (M1 i c a) where gzero' = M1 gzero' gone' = M1 gone' gplus' (M1 x) (M1 y) = M1 $ gplus' x y gtimes' (M1 x) (M1 y) = M1 $ gtimes' x y gfromNatural' = M1 . gfromNatural' instance (GRing a) => GRing (M1 i c a) where gnegate' (M1 x) = M1 $ gnegate' x instance (Semiring a) => GSemiring (K1 i a) where gzero' = K1 zero gone' = K1 one gplus' (K1 x) (K1 y) = K1 $ plus x y gtimes' (K1 x) (K1 y) = K1 $ times x y gfromNatural' = K1 . fromNatural instance (Ring a) => GRing (K1 i a) where gnegate' (K1 x) = K1 $ negate x #endif semirings-0.6/Data/Semiring/Tropical.hs0000644000000000000000000001126607346545000016315 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- A tropical semiring is an extension of another totally ordered -- semiring with the operations of minimum or maximum as addition. -- The extended semiring is given positive or negative infinity as -- its 'zero' element, so that the following hold: -- -- @ --'plus' 'Infinity' y = y --'plus' x 'Infinity' = x@ -- -- -- i.e., In the max-plus tropical semiring (where 'plus' is 'max'), -- 'Infinity' unifies with the typical interpretation of negative infinity, -- and thus it is the identity for the maximum, and in the min-plus tropical -- semiring (where 'plus' is 'min'), 'Infinity' unifies with the typical -- interpretation of positive infinity, and thus it is the identity for the minimum. -- ----------------------------------------------------------------------------- module Data.Semiring.Tropical ( Tropical(Infinity,Tropical) , Extrema(Minima,Maxima) , Extremum(extremum) , EProxy(EProxy) ) where #if MIN_VERSION_base(4,7,0) import Data.Data (Data) #endif import Data.Semiring (Semiring(..)) import Data.Star (Star(..)) #if MIN_VERSION_base(4,7,0) import Data.Typeable (Typeable) #endif -- done for haddocks, to make sure -Wall works import qualified Data.Monoid as Monoid -- | On older GHCs, 'Data.Proxy.Proxy' is not polykinded, so we provide our own proxy type for 'Extrema'. -- This turns out not to be a problem, since 'Extremum' is a closed typeclass. data EProxy (e :: Extrema) = EProxy -- | A datatype to be used at the kind-level. Its only -- purpose is to decide the ordering for the tropical -- semiring in a type-safe way. data Extrema = Minima | Maxima -- | The 'Extremum' typeclass exists for us to match on -- the kind-level 'Extrema', so that we can recover -- which ordering to use in the `Semiring` instance -- for 'Tropical`. class Extremum (e :: Extrema) where -- unfortunately this has to take a `Proxy` because -- we don't have visual type applications before GHC 8.0 extremum :: EProxy e -> Extrema instance Extremum 'Minima where extremum _ = Minima {-# INLINE extremum #-} -- just to be safe instance Extremum 'Maxima where extremum _ = Maxima {-# INLINE extremum #-} -- just to be safe -- | The tropical semiring. -- -- @'Tropical' ''Minima' a@ is equivalent to the semiring -- \( (a \cup \{+\infty\}, \oplus, \otimes) \), where \( x \oplus y = min\{x,y\}\) and \(x \otimes y = x + y\). -- -- @'Tropical' ''Maxima' a@ is equivalent to the semiring -- \( (a \cup \{-\infty\}, \oplus, \otimes) \), where \( x \oplus y = max\{x,y\}\) and \(x \otimes y = x + y\). -- -- In literature, the 'Semiring' instance of the 'Tropical' semiring lifts -- the underlying semiring's additive structure. One might ask why this lifting doesn't -- instead witness a 'Monoid.Monoid', since we only lift 'zero' and 'plus' - the reason is -- that usually the additive structure of a semiring is monotonic, i.e. -- @a '+' ('min' b c) == 'min' (a '+' b) (a '+' c)@, but in general this is not true. -- For example, lifting 'Monoid.Product' 'Word' into 'Tropical' is lawful, -- but 'Monoid.Product' 'Int' is not, lacking distributivity: @(-1) '*' ('min' 0 1) '/=' 'min' ((-1) '*' 0) ((-1) '*' 1)@. -- So, we deviate from literature and instead -- witness the lifting of a 'Monoid.Monoid', so the user must take care to ensure -- that their implementation of 'mappend' is monotonic. data Tropical (e :: Extrema) a = Infinity | Tropical a deriving ( Eq , Show , Read #if MIN_VERSION_base(4,7,0) , Typeable , Data #endif ) instance forall e a. (Ord a, Extremum e) => Ord (Tropical e a) where compare Infinity Infinity = EQ compare Infinity _ = case extremum (EProxy :: EProxy e) of Minima -> GT Maxima -> LT compare _ Infinity = case extremum (EProxy :: EProxy e) of Minima -> LT Maxima -> GT compare (Tropical x) (Tropical y) = compare x y instance forall e a. (Ord a, Monoid.Monoid a, Extremum e) => Semiring (Tropical e a) where zero = Infinity one = Tropical Monoid.mempty plus Infinity y = y plus x Infinity = x plus (Tropical x) (Tropical y) = Tropical ( case extremum (EProxy :: EProxy e) of Minima -> min x y Maxima -> max x y ) times Infinity _ = Infinity times _ Infinity = Infinity times (Tropical x) (Tropical y) = Tropical (Monoid.mappend x y) fromNatural 0 = zero fromNatural _ = one instance forall e a. (Ord a, Monoid.Monoid a, Extremum e) => Star (Tropical e a) where star _ = one semirings-0.6/Data/Star.hs0000644000000000000000000000266507346545000013677 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE NoImplicitPrelude #-} ----------------------------------------------------------------------------- -- | -- A class for *-semirings (pron. "star-semirings"). -- ----------------------------------------------------------------------------- module Data.Star ( Star(..) ) where import Data.Bool (Bool(..)) import Data.Function (id, (.), const) import Data.Proxy (Proxy(..)) import Data.Semiring -- | A -- adds one operation, 'star' to a 'Semiring', such that it follows the -- law: -- -- @'star' x = 'one' '+' x '*' 'star' x = 'one' '+' 'star' x '*' x@ -- -- Another operation, 'aplus', can be defined in terms of 'star': -- -- @'aplus' x = x '*' 'star' x@ class (Semiring a) => Star a where #if __GLASGOW_HASKELL__ >= 708 {-# MINIMAL star | aplus #-} #endif star :: a -> a star a = one `plus` aplus a aplus :: a -> a aplus a = a `times` star a instance Star b => Star (a -> b) where star = (.) star aplus = (.) aplus {-# INLINE star #-} {-# INLINE aplus #-} instance Star Bool where star _ = True aplus = id {-# INLINE star #-} {-# INLINE aplus #-} instance Star () where star _ = () aplus _ = () {-# INLINE star #-} {-# INLINE aplus #-} instance Star (Proxy a) where star _ = Proxy aplus _ = Proxy {-# INLINE star #-} {-# INLINE aplus #-} instance Star Mod2 where star = const one semirings-0.6/LICENSE0000644000000000000000000000271507346545000012562 0ustar0000000000000000Copyright 2019 chessai Copyright 2019 Andrew Lelechenko Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. semirings-0.6/README.md0000755000000000000000000000561507346545000013041 0ustar0000000000000000semirings ========== [![Hackage](https://img.shields.io/hackage/v/semirings.svg)](https://hackage.haskell.org/package/semirings) [![Build Status](https://travis-ci.org/chessai/semirings.svg?branch=master)](https://travis-ci.org/chessai/semirings) Haskellers are usually familiar with monoids and semigroups. A monoid has an appending operation `<>` or `mappend` and an identity element `mempty`. A semigroup has an append `<>`, but does not require an `mempty` element. A Semiring has two appending operations, 'plus' and 'times', and two respective identity elements, 'zero' and 'one'. More formally, A semiring R is a set equipped with two binary relations + and *, such that: - (R, +) is a commutative monoid with identity element 0: - (a + b) + c = a + (b + c) - 0 + a = a + 0 = a - a + b = b + a - (R, *) is a monoid with identity element 1: - (a * b) * c = a * (b * c) - 1 * a = a * 1 = a - Multiplication left and right distributes over addition - a * (b + c) = (a * b) + (a * c) - (a + b) * c = (a * c) + (b * c) - Multiplication by '0' annihilates R: - 0 * a = a * 0 = 0 *-semirings =========== A *-semiring (pron. "star-semiring") is any semiring with an additional operation 'star' (read as "asteration"), such that: - star a = 1 + a * star a = 1 + star a * a A derived operation called "aplus" can be defined in terms of star by: - star :: a -> a - star a = 1 + aplus a - aplus :: a -> a - aplus a = a * star a As such, a minimal instance of the typeclass 'Star' requires only 'star' or 'aplus' to be defined. use cases ========= semirings themselves are useful as a way to express that a type that supports a commutative and associative operation. Some examples: - Numbers {Int, Integer, Word, Double, etc.}: - 'plus' is 'Prelude.+' - 'times' is 'Prelude.*' - 'zero' is 0. - 'one' is 1. - Booleans: - 'plus' is '||' - 'times' is '&&' - 'zero' is 'False' - 'one' is 'True' - Set: - 'plus' is 'union' - 'times' is 'intersection' - 'zero' is the empty Set. - 'one' is the singleton Set containing the 'one' element of the underlying type. - NFA: - 'plus' unions two NFAs. - 'times' appends two NFAs. - 'zero' is the NFA that acceptings nothing. - 'one' is the empty NFA. - DFA: - 'plus' unions two DFAs. - 'times' intersects two DFAs. - 'zero' is the DFA that accepts nothing. - 'one' is the DFA that accepts everything. *-semirings are useful in a number of applications; such as matrix algebra, regular expressions, kleene algebras, graph theory, tropical algebra, dataflow analysis, power series, and linear recurrence relations. Some relevant (informal) reading material: http://stedolan.net/research/semirings.pdf http://r6.ca/blog/20110808T035622Z.html https://byorgey.wordpress.com/2016/04/05/the-network-reliability-problem-and-star-semirings/ additional credit ====== Some of the code in this library was lifted directly from the Haskell library 'semiring-num'. semirings-0.6/Setup.hs0000644000000000000000000000005607346545000013205 0ustar0000000000000000import Distribution.Simple main = defaultMain semirings-0.6/semirings.cabal0000644000000000000000000000501107346545000014531 0ustar0000000000000000name: semirings category: Algebra, Data, Data Structures, Math, Maths, Mathematics version: 0.6 license: BSD3 cabal-version: >= 1.10 license-file: LICENSE author: chessai maintainer: chessai stability: provisional homepage: http://github.com/chessai/semirings bug-reports: http://github.com/chessai/semirings/issues copyright: Copyright (C) 2018 chessai synopsis: two monoids as one, in holy haskimony description: Haskellers are usually familiar with monoids and semigroups. A monoid has an appending operation `<>` (or `mappend`), and an identity element, `mempty`. A semigroup has an appending `<>` operation, but does not require a `mempty` element. . A Semiring has two appending operations, `plus` and `times`, and two respective identity elements, `zero` and `one`. . More formally, a Semiring R is a set equipped with two binary relations `+` and `*`, such that: . (R,+) is a commutative monoid with identity element 0, . (R,*) is a monoid with identity element 1, . (*) left and right distributes over addition, and . multiplication by '0' annihilates R. build-type: Simple extra-source-files: README.md CHANGELOG.md tested-with: GHC == 7.10.3 , GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.4 , GHC == 8.10.2 source-repository head type: git location: git://github.com/chessai/semirings.git flag containers description: You can disable the use of the `containers` package using `-f-containers`. . Disabling this may be useful for accelerating builds in sandboxes for expert users. default: True manual: True flag unordered-containers description: You can disable the use of the `unordered-containers` package using `-f-unordered-containers`. . Disabling this may be useful for accelerating builds in sandboxes for expert users. default: True manual: True library default-language: Haskell98 ghc-options: -Wall build-depends: base >= 4.8 && < 5 , base-compat-batteries exposed-modules: Data.Euclidean Data.Field Data.Semiring Data.Star Data.Semiring.Tropical Data.Semiring.Generic if impl(ghc < 8.6.1) build-depends: template-haskell >= 2.4.0.0 if flag(containers) build-depends: containers >= 0.5.4 && < 0.7 if flag(unordered-containers) build-depends: hashable >= 1.1 && < 1.4 , unordered-containers >= 0.2 && < 0.3