diff --git a/bench/bench.hs b/bench/bench.hs new file mode 100644 --- /dev/null +++ b/bench/bench.hs @@ -0,0 +1,20 @@ +module Main (main) where + +import Criterion.Main + +import System.Random + +import Control.Monad + +import Data.Semiring + +threeInts :: IO (Int,Int,Int) +threeInts = (,,) <$> randomIO <*> randomIO <*> randomIO + +sumAtSize :: Int -> Benchmark +sumAtSize n = + env (replicateM n threeInts) $ + \xs -> + bgroup (show n) [bench "add" $ nf add xs] +main :: IO () +main = defaultMain [sumAtSize 10000] diff --git a/semiring-num.cabal b/semiring-num.cabal --- a/semiring-num.cabal +++ b/semiring-num.cabal @@ -1,5 +1,5 @@ name: semiring-num -version: 1.1.0.1 +version: 1.2.0.0 synopsis: Basic semiring class and instances description: Adds a basic semiring class homepage: https://github.com/oisdk/semiring-num @@ -22,6 +22,8 @@ other-modules: Data.Semiring.TH build-depends: base >= 4.9 && < 5 , template-haskell >= 2.11 + , containers >= 0.5 + , log-domain >= 0.10 default-language: Haskell2010 ghc-options: -Wall @@ -36,10 +38,26 @@ , containers >= 0.5 , QuickCheck >= 2.8 , nat-sized-numbers >= 0.1 + , tasty >= 0.11 + , tasty-smallcheck >= 0.8 + , tasty-quickcheck >= 0.8 + , log-domain >= 0.10 ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + default-language: Haskell2010 + +benchmark bench + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: bench.hs + build-depends: base + , semiring-num + , criterion >=1.1 + , random >= 1.1 + , containers >= 0.5 + ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 source-repository head diff --git a/src/Data/Semiring.hs b/src/Data/Semiring.hs --- a/src/Data/Semiring.hs +++ b/src/Data/Semiring.hs @@ -1,674 +1,1747 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} - -{-| -Module: Data.Semiring -Description: Haskell semirings -License: MIT -Maintainer: mail@doisinkidney.com -Stability: experimental --} - -module Data.Semiring - ( -- * Semiring classes - Semiring(..) - , StarSemiring(..) - -- * Helper classes - , HasPositiveInfinity(..) - , HasNegativeInfinity(..) - , DetectableZero(..) - -- * Monoidal wrappers - , Add(..) - , Mul(..) - , add - , mul - -- * Ordering wrappers - , 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 - - --- | A is like the --- the combination of two 'Data.Monoid.Monoid's. The first --- is called '<+>'; it has the identity element 'zero', and it is --- commutative. The second is called '<.>'; it has identity element 'one', --- and it must distribute over '<+>'. --- --- = Laws --- == Normal 'Monoid' laws --- --- @(a '<+>' b) '<+>' c = a '<+>' (b '<+>' c) ---'zero' '<+>' a = a '<+>' 'zero' = a ---(a '<.>' b) '<.>' c = a '<.>' (b '<.>' c) ---'one' '<.>' a = a '<.>' 'one' = a@ --- --- == Commutativity of '<+>' --- @a '<+>' b = b '<+>' a@ --- --- == Distribution of '<.>' over '<+>' --- @a '<.>' (b '<+>' c) = (a '<.>' b) '<+>' (a '<.>' c) ---(a '<+>' b) '<.>' c = (a '<.>' c) '<+>' (b '<.>' c)@ --- --- == Annihilation --- @'zero' '<.>' a = a '<.>' 'zero' = 'zero'@ --- --- An ordered semiring follows the laws: --- --- @x '<=' y => x '<+>' z '<=' y '<+>' z ---x '<=' y => x '<+>' z '<=' y '<+>' z ---'zero' '<=' z '&&' x '<=' y => x '<.>' z '<=' y '<.>' z '&&' z '<.>' x '<=' z '<.>' y@ -class Semiring a where - -- | The identity of '<+>'. - zero - :: a - -- | The identity of '<.>'. - one - :: a - -- | An associative binary operation, which distributes over '<+>'. - infixl 7 <.> - (<.>) :: a -> a -> a - -- | An associative, commutative binary operation. - 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 - {-# INLINE zero #-} - one = 1 - {-# INLINE one #-} - (<+>) = (+) - {-# INLINE (<+>) #-} - (<.>) = (*) - {-# INLINE (<.>) #-} - --- | A --- adds one operation, 'star' to a 'Semiring', such that it follows the --- law: --- --- @'star' x = 'one' '<+>' x '<.>' 'star' x = 'one' '<+>' 'star' x '<.>' x@ --- --- For the semiring of types, this is equivalent to a list. When looking --- at the 'Applicative' and 'Control.Applicative.Alternative' classes as --- (near-) semirings, this is equivalent to the --- 'Control.Applicative.many' operation. --- --- Another operation, 'plus', can be defined in relation to 'star': --- --- @'plus' x = x '<.>' 'star' x@ --- --- This should be recognizable as a non-empty list on types, or the --- 'Control.Applicative.some' operation in --- 'Control.Applicative.Alternative'. -class Semiring a => - StarSemiring a where - {-# MINIMAL star | plus #-} - star :: a -> a - plus :: a -> a - star x = one <+> plus x - plus x = x <.> star x - --- | Useful for operations where zeroes may need to be discarded: for instance --- in sparse matrix calculations. -class Semiring a => DetectableZero a where - -- | 'True' if x is 'zero'. - isZero :: a -> Bool - default isZero :: Eq a => a -> Bool - isZero = (zero==) - --------------------------------------------------------------------------------- --- Infinites --------------------------------------------------------------------------------- - --- | A class for semirings with a concept of "infinity". It's important that --- this isn't regarded as the same as "bounded": --- @x '<+>' 'positiveInfinity'@ should probably equal 'positiveInfinity'. -class HasPositiveInfinity a where - -- | A positive infinite value - positiveInfinity :: a - default positiveInfinity :: RealFloat a => a - positiveInfinity = 1/0 - -- | Test if a value is positive infinity. - isPositiveInfinity :: a -> Bool - default isPositiveInfinity :: RealFloat a => a -> Bool - isPositiveInfinity x = isInfinite x && x > 0 - --- | A class for semirings with a concept of "negative infinity". It's important\ --- that this isn't regarded as the same as "bounded": --- @x '<+>' 'negativeInfinity'@ should probably equal 'negativeInfinity'. -class HasNegativeInfinity a where - -- | A negative infinite value - negativeInfinity :: a - default negativeInfinity :: RealFloat a => a - negativeInfinity = negate (1/0) - -- | Test if a value is negative infinity. - 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 - --------------------------------------------------------------------------------- --- Instances --------------------------------------------------------------------------------- -instance Semiring Bool where - one = True - zero = False - (<+>) = (||) - (<.>) = (&&) - {-# INLINE zero #-} - {-# INLINE one #-} - {-# INLINE (<+>) #-} - {-# INLINE (<.>) #-} - -instance StarSemiring Bool where - star _ = True - plus = id - {-# INLINE star #-} - {-# INLINE plus #-} - -instance DetectableZero Bool - - -instance Semiring () where - one = () - zero = () - _ <+> _ = () - _ <.> _ = () - {-# INLINE zero #-} - {-# INLINE one #-} - {-# INLINE (<+>) #-} - {-# INLINE (<.>) #-} - -instance DetectableZero () - -instance StarSemiring () where - star _ = () - plus _ = () - {-# INLINE star #-} - {-# INLINE plus #-} - --- | A polynomial in /x/ can be defined as a list of its coefficients, --- where the /i/th element is the coefficient of /x^i/. This is the --- semiring for such a list. Adapted from --- . -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 - --------------------------------------------------------------------------------- --- Addition and multiplication newtypes --------------------------------------------------------------------------------- -type WrapBinary f a = (a -> a -> a) -> f a -> f a -> f a - --- | Monoid under '<+>'. Analogous to 'Data.Monoid.Sum', but uses the --- 'Semiring' constraint, rather than 'Num'. -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) - --- | Monoid under '<.>'. Analogous to 'Data.Monoid.Product', but uses the --- 'Semiring' constraint, rather than 'Num'. -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) (<+>) - {-# INLINE (<>) #-} - -instance Semiring a => - Semigroup (Mul a) where - (<>) = (coerce :: WrapBinary Mul a) (<.>) - {-# INLINE (<>) #-} - -instance Semiring a => - Monoid (Add a) where - mempty = Add zero - mappend = (<>) - {-# INLINE mempty #-} - {-# INLINE mappend #-} - -instance Semiring a => - Monoid (Mul a) where - mempty = Mul one - mappend = (<>) - {-# INLINE mempty #-} - {-# INLINE mappend #-} - --------------------------------------------------------------------------------- --- Addition and multiplication folds --------------------------------------------------------------------------------- --- | Takes the sum of the elements of a 'Foldable'. Analogous to 'sum' --- on numbers, or 'or' on 'Bool's. --- --- >>> add [1..5] --- 15 --- >>> add [False, False] --- False --- >>> add [False, True] --- True --- >>> add [True, undefined] --- True -add - :: (Foldable f, Semiring a) - => f a -> a -add = getAdd . foldMap Add - --- | Takes the product of the elements of a 'Foldable'. Analogous to --- 'product' on numbers, or 'and' on 'Bool's. --- --- >>> mul [1..5] --- 120 --- >>> mul [True, True] --- True --- >>> mul [True, False] --- False --- >>> mul [False, undefined] --- False -mul - :: (Foldable f, Semiring a) - => f a -> a -mul = getMul . foldMap Mul - --------------------------------------------------------------------------------- --- Ord wrappers --------------------------------------------------------------------------------- --- | The "" or --- min-plus semiring. It is a semiring where: --- --- @'<+>' = 'min' ---'zero' = ∞ ---'<.>' = '<+>' ---'one' = 'zero'@ --- --- Note that we can't use 'Data.Semigroup.Min' from 'Data.Semigroup' --- because annihilation needs to hold: --- --- @∞ '<+>' x = x '<+>' ∞ = ∞@ --- --- Taking ∞ to be 'maxBound' would break the above law. Using 'positiveInfinity' --- to represent it follows the law. -newtype Min a = Min - { getMin :: a - } deriving (Eq,Ord,Read,Show,Bounded,Generic,Generic1,Num,Enum,Typeable - ,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable) - --- | The "" --- or max-plus semiring. It is a semiring where: --- --- @'<+>' = 'max' ---'zero' = -∞ ---'<.>' = '<+>' ---'one' = 'zero'@ --- --- Note that we can't use 'Data.Semigroup.Max' from 'Data.Semigroup' --- because annihilation needs to hold: --- --- @-∞ '<+>' x = x '<+>' -∞ = -∞@ --- --- Taking -∞ to be 'minBound' would break the above law. Using --- 'negativeInfinity' to represent it follows the law. -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 - {-# INLINE (<>) #-} - -instance Ord a => - Semigroup (Min a) where - (<>) = (coerce :: WrapBinary Min a) min - {-# INLINE (<>) #-} - --- | >>> (getMax . foldMap Max) [1..10] --- 10.0 -instance (Ord a, HasNegativeInfinity a) => - Monoid (Max a) where - mempty = Max negativeInfinity - mappend = (<>) - {-# INLINE mempty #-} - {-# INLINE mappend #-} - --- | >>> (getMin . foldMap Min) [1..10] --- 1.0 -instance (Ord a, HasPositiveInfinity a) => - Monoid (Min a) where - mempty = Min positiveInfinity - mappend = (<>) - {-# INLINE mempty #-} - {-# INLINE mappend #-} - -instance (Semiring a, Ord a, HasNegativeInfinity a) => - Semiring (Max a) where - (<+>) = mappend - zero = mempty - (<.>) = (coerce :: WrapBinary Max a) (<+>) - one = Max zero - {-# INLINE zero #-} - {-# INLINE one #-} - {-# INLINE (<+>) #-} - {-# INLINE (<.>) #-} - -instance (Semiring a, Ord a, HasPositiveInfinity a) => - Semiring (Min a) where - (<+>) = mappend - zero = mempty - (<.>) = (coerce :: WrapBinary Min a) (<+>) - one = Min zero - {-# INLINE zero #-} - {-# INLINE one #-} - {-# INLINE (<+>) #-} - {-# INLINE (<.>) #-} - -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 --------------------------------------------------------------------------------- --- | The @(->)@ instance is analogous to the one for 'Monoid'. -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) - --------------------------------------------------------------------------------- --- Endo instance --------------------------------------------------------------------------------- --- | This is /not/ a true semiring. In particular, it requires the --- underlying monoid to be commutative, and even then, it is only a near --- semiring. It is, however, extremely useful. For instance, this type: --- --- @forall a. 'Endo' ('Endo' a)@ --- --- Is a valid encoding of church numerals, with addition and --- multiplication being their semiring variants. -instance Monoid a => - Semiring (Endo a) where - zero = Endo mempty - Endo f <+> Endo g = Endo (f `mappend` g) - one = mempty - (<.>) = mappend - {-# INLINE zero #-} - {-# INLINE one #-} - {-# INLINE (<+>) #-} - {-# INLINE (<.>) #-} - -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]) - --------------------------------------------------------------------------------- --- Instances for Bool wrappers --------------------------------------------------------------------------------- -instance Semiring Any where - (<+>) = coerce (||) - zero = Any False - (<.>) = coerce (&&) - one = Any True - {-# INLINE zero #-} - {-# INLINE one #-} - {-# INLINE (<+>) #-} - {-# INLINE (<.>) #-} - -instance StarSemiring Any where - star _ = Any True - plus = id - {-# INLINE star #-} - {-# INLINE plus #-} - -instance Semiring All where - (<+>) = coerce (||) - zero = All False - (<.>) = coerce (&&) - one = All True - {-# INLINE zero #-} - {-# INLINE one #-} - {-# INLINE (<+>) #-} - {-# INLINE (<.>) #-} - -instance StarSemiring All where - star _ = All True - plus = id - {-# INLINE star #-} - {-# INLINE plus #-} - -instance DetectableZero Any -instance DetectableZero All - --------------------------------------------------------------------------------- --- Boring instances --------------------------------------------------------------------------------- - -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) - --------------------------------------------------------------------------------- --- Very boring instances --------------------------------------------------------------------------------- - -$(traverse semiringIns [2..9]) -$(traverse starIns [2..9]) -$(traverse zeroIns [2..9]) +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} + +{-| +Module: Data.Semiring +Description: Haskell semirings +License: MIT +Maintainer: mail@doisinkidney.com +Stability: experimental +-} +module Data.Semiring + ( + -- * Semiring classes + Semiring(..) + ,StarSemiring(..) + ,mulFoldable + ,addFoldable + , + -- * Helper classes + HasPositiveInfinity(..) + ,HasNegativeInfinity(..) + ,DetectableZero(..) + , + -- * Monoidal wrappers + Add(..) + ,Mul(..) + , + -- * Ordering wrappers + Max(..) + ,Min(..) + , + -- * Matrix wrapper + Matrix(..)) + 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 +import GHC.Generics (Generic, Generic1) +import Data.Typeable (Typeable) +import Foreign.Storable (Storable) +import Data.Semiring.TH +import Data.Functor.Classes +import Text.Read + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map + +import Data.Set (Set) +import qualified Data.Set as Set + +import Numeric.Log hiding (sum) +import qualified Numeric.Log + +import Control.Monad +import Control.Applicative +import Data.Foldable + +-- $setup +-- >>> import Data.Function + +-- | A is like the +-- the combination of two 'Data.Monoid.Monoid's. The first +-- is called '<+>'; it has the identity element 'zero', and it is +-- commutative. The second is called '<.>'; it has identity element 'one', +-- and it must distribute over '<+>'. +-- +-- = Laws +-- == Normal 'Monoid' laws +-- +-- @(a '<+>' b) '<+>' c = a '<+>' (b '<+>' c) +--'zero' '<+>' a = a '<+>' 'zero' = a +--(a '<.>' b) '<.>' c = a '<.>' (b '<.>' c) +--'one' '<.>' a = a '<.>' 'one' = a@ +-- +-- == Commutativity of '<+>' +-- @a '<+>' b = b '<+>' a@ +-- +-- == Distribution of '<.>' over '<+>' +-- @a '<.>' (b '<+>' c) = (a '<.>' b) '<+>' (a '<.>' c) +--(a '<+>' b) '<.>' c = (a '<.>' c) '<+>' (b '<.>' c)@ +-- +-- == Annihilation +-- @'zero' '<.>' a = a '<.>' 'zero' = 'zero'@ +-- +-- An ordered semiring follows the laws: +-- +-- @x '<=' y => x '<+>' z '<=' y '<+>' z +--x '<=' y => x '<+>' z '<=' y '<+>' z +--'zero' '<=' z '&&' x '<=' y => x '<.>' z '<=' y '<.>' z '&&' z '<.>' x '<=' z '<.>' y@ +class Semiring a where + {-# MINIMAL zero , one , (<.>) , (<+>) #-} + -- | The identity of '<+>'. + zero + :: a + -- | The identity of '<.>'. + one + :: a + -- | An associative binary operation, which distributes over '<+>'. + infixl 7 <.> + (<.>) :: a -> a -> a + -- | An associative, commutative binary operation. + infixl 6 <+> + (<+>) :: a -> a -> a + -- | Takes the sum of the elements of a 'Foldable'. Analogous to 'sum' + -- on numbers, or 'or' on 'Bool's. + -- + -- >>> add [1..5] + -- 15 + -- >>> add [False, False] + -- False + -- >>> add [False, True] + -- True + -- >>> add [True, undefined] + -- True + add + :: [a] -> a + add = getAdd . foldMap Add + {-# INLINE add #-} + -- | Takes the product of the elements of a 'Foldable'. Analogous to + -- 'product' on numbers, or 'and' on 'Bool's. + -- + -- >>> mul [1..5] + -- 120 + -- >>> mul [True, True] + -- True + -- >>> mul [True, False] + -- False + -- >>> mul [False, undefined] + -- False + mul + :: [a] -> a + mul = getMul . foldMap Mul + {-# INLINE mul #-} + +-- | The product of the contents of a 'Foldable'. +mulFoldable :: (Foldable f, Semiring a) => f a -> a +mulFoldable = mul . toList +{-# INLINE mulFoldable #-} + +-- | The sum of the contents of a 'Foldable'. +addFoldable :: (Foldable f, Semiring a) => f a -> a +addFoldable = add . toList +{-# INLINE addFoldable #-} + + +-- | A +-- adds one operation, 'star' to a 'Semiring', such that it follows the +-- law: +-- +-- @'star' x = 'one' '<+>' x '<.>' 'star' x = 'one' '<+>' 'star' x '<.>' x@ +-- +-- For the semiring of types, this is equivalent to a list. When looking +-- at the 'Applicative' and 'Control.Applicative.Alternative' classes as +-- (near-) semirings, this is equivalent to the +-- 'Control.Applicative.many' operation. +-- +-- Another operation, 'plus', can be defined in relation to 'star': +-- +-- @'plus' x = x '<.>' 'star' x@ +-- +-- This should be recognizable as a non-empty list on types, or the +-- 'Control.Applicative.some' operation in +-- 'Control.Applicative.Alternative'. +class Semiring a => + StarSemiring a where + {-# MINIMAL star | plus #-} + star :: a -> a + plus :: a -> a + star x = one <+> plus x + {-# INLINE star #-} + plus x = x <.> star x + {-# INLINE plus #-} + +-- | Useful for operations where zeroes may need to be discarded: for instance +-- in sparse matrix calculations. +class Semiring a => + DetectableZero a where + -- | 'True' if x is 'zero'. + isZero + :: a -> Bool + +isZeroEq + :: (Semiring a, Eq a) + => a -> Bool +isZeroEq = (zero ==) +{-# INLINE isZeroEq #-} + +-------------------------------------------------------------------------------- +-- Infinites +-------------------------------------------------------------------------------- +-- | A class for semirings with a concept of "infinity". It's important that +-- this isn't regarded as the same as "bounded": +-- @x '<+>' 'positiveInfinity'@ should probably equal 'positiveInfinity'. +class HasPositiveInfinity a where + -- | A positive infinite value + positiveInfinity + :: a + -- | Test if a value is positive infinity. + isPositiveInfinity + :: a -> Bool + +defaultPositiveInfinity + :: RealFloat a + => a +defaultPositiveInfinity = 1 / 0 +{-# INLINE defaultPositiveInfinity #-} + +defaultIsPositiveInfinity + :: RealFloat a + => a -> Bool +defaultIsPositiveInfinity x = isInfinite x && x > 0 +{-# INLINE defaultIsPositiveInfinity #-} + +-- | A class for semirings with a concept of "negative infinity". It's important\ +-- that this isn't regarded as the same as "bounded": +-- @x '<+>' 'negativeInfinity'@ should probably equal 'negativeInfinity'. +class HasNegativeInfinity a where + -- | A negative infinite value + negativeInfinity + :: a + -- | Test if a value is negative infinity. + isNegativeInfinity + :: a -> Bool + +defaultIsNegativeInfinity + :: RealFloat a + => a -> Bool +defaultIsNegativeInfinity x = isInfinite x && x < 0 +{-# INLINE defaultIsNegativeInfinity #-} + +defaultNegativeInfinity + :: RealFloat a + => a +defaultNegativeInfinity = negate (1 / 0) +{-# INLINE defaultNegativeInfinity #-} + +instance HasPositiveInfinity Double where + positiveInfinity = defaultPositiveInfinity + isPositiveInfinity = defaultIsPositiveInfinity + {-# INLINE positiveInfinity #-} + {-# INLINE isPositiveInfinity #-} + +instance HasNegativeInfinity Double where + negativeInfinity = defaultNegativeInfinity + isNegativeInfinity = defaultIsNegativeInfinity + {-# INLINE negativeInfinity #-} + {-# INLINE isNegativeInfinity #-} + +instance HasPositiveInfinity Float where + positiveInfinity = defaultPositiveInfinity + isPositiveInfinity = defaultIsPositiveInfinity + {-# INLINE positiveInfinity #-} + {-# INLINE isPositiveInfinity #-} + +instance HasNegativeInfinity Float where + negativeInfinity = defaultNegativeInfinity + isNegativeInfinity = defaultIsNegativeInfinity + {-# INLINE negativeInfinity #-} + {-# INLINE isNegativeInfinity #-} + +instance HasPositiveInfinity CDouble where + positiveInfinity = defaultPositiveInfinity + isPositiveInfinity = defaultIsPositiveInfinity + {-# INLINE positiveInfinity #-} + {-# INLINE isPositiveInfinity #-} + +instance HasNegativeInfinity CDouble where + negativeInfinity = defaultNegativeInfinity + isNegativeInfinity = defaultIsNegativeInfinity + {-# INLINE negativeInfinity #-} + {-# INLINE isNegativeInfinity #-} + +instance HasPositiveInfinity CFloat where + positiveInfinity = defaultPositiveInfinity + isPositiveInfinity = defaultIsPositiveInfinity + {-# INLINE positiveInfinity #-} + {-# INLINE isPositiveInfinity #-} + +instance HasNegativeInfinity CFloat where + negativeInfinity = defaultNegativeInfinity + isNegativeInfinity = defaultIsNegativeInfinity + {-# INLINE negativeInfinity #-} + {-# INLINE isNegativeInfinity #-} + +-------------------------------------------------------------------------------- +-- Instances +-------------------------------------------------------------------------------- +instance Semiring Bool where + one = True + zero = False + (<+>) = (||) + (<.>) = (&&) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance StarSemiring Bool where + star _ = True + plus = id + {-# INLINE star #-} + {-# INLINE plus #-} + +instance DetectableZero Bool where + isZero = not + {-# INLINE isZero #-} + +instance Semiring () where + one = () + zero = () + _ <+> _ = () + _ <.> _ = () + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance DetectableZero () where + isZero _ = True + {-# INLINE isZero #-} + +instance StarSemiring () where + star _ = () + plus _ = () + {-# INLINE star #-} + {-# INLINE plus #-} + +-- | A polynomial in /x/ can be defined as a list of its coefficients, +-- where the /i/th element is the coefficient of /x^i/. This is the +-- semiring for such a list. Adapted from +-- . +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 + {-# INLINE isZero #-} + +instance (Monoid a, Ord a) => + Semiring (Set a) where + (<+>) = Set.union + zero = Set.empty + one = Set.singleton mempty + xs <.> ys = foldMap (flip Set.map ys . mappend) xs + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + {-# INLINE zero #-} + {-# INLINE one #-} + +instance (Ord a, Monoid a, Semiring b) => + Semiring (Map a b) where + one = Map.singleton mempty one + {-# INLINE one #-} + zero = Map.empty + {-# INLINE zero #-} + (<+>) = Map.unionWith (<+>) + {-# INLINE (<+>) #-} + xs <.> ys = + Map.fromListWith + (<+>) + [ (mappend k l, v <.> u) + | (k,v) <- Map.toList xs + , (l,u) <- Map.toList ys ] + {-# INLINE (<.>) #-} + +instance (Monoid a, Ord a) => + DetectableZero (Set a) where + isZero = Set.null + {-# INLINE isZero #-} + +instance (Precise a, RealFloat a) => Semiring (Log a) where + (<.>) = (*) + {-# INLINE (<.>) #-} + (<+>) = (+) + {-# INLINE (<+>) #-} + one = Exp 0 + {-# INLINE one #-} + zero = Exp (-(1/0)) + {-# INLINE zero #-} + add = Numeric.Log.sum + {-# INLINE add #-} + +instance (Precise a, RealFloat a) => DetectableZero (Log a) where + isZero = isZeroEq + {-# INLINE isZero #-} + +-------------------------------------------------------------------------------- +-- Addition and multiplication newtypes +-------------------------------------------------------------------------------- +type WrapBinary f a = (a -> a -> a) -> f a -> f a -> f a + +-- | Monoid under '<+>'. Analogous to 'Data.Monoid.Sum', but uses the +-- 'Semiring' constraint, rather than 'Num'. +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,DetectableZero,StarSemiring) + +instance Eq1 Add where + liftEq = coerce + +instance Ord1 Add where + liftCompare = coerce + +showsNewtype :: Coercible b a => String -> String -> (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> b -> ShowS +showsNewtype cons acc = s + where + s sp _ n x = + showParen (n > 10) $ + showString cons . + showString " {" . + showString acc . showString " =" . sp 0 (coerce x) . showChar '}' + +readsNewtype :: Coercible a b => String -> String -> (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS b +readsNewtype cons acc = r where + r rp _ = readPrec_to_S $ prec 10 $ do + Ident c <- lexP + guard (c == cons) + Punc "{" <- lexP + Ident a <- lexP + guard (a == acc) + Punc "=" <- lexP + x <- prec 0 $ readS_to_Prec rp + Punc "}" <- lexP + pure (coerce x) + +instance Show1 Add where + liftShowsPrec = showsNewtype "Add" "getAdd" + +instance Read1 Add where + liftReadsPrec = readsNewtype "Add" "getAdd" + +-- | Monoid under '<.>'. Analogous to 'Data.Monoid.Product', but uses the +-- 'Semiring' constraint, rather than 'Num'. +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,DetectableZero,StarSemiring) + +instance Eq1 Mul where + liftEq = coerce + +instance Ord1 Mul where + liftCompare = coerce + +instance Show1 Mul where + liftShowsPrec = showsNewtype "Mul" "getMul" + +instance Read1 Mul where + liftReadsPrec = readsNewtype "Mul" "getMul" + +instance Semiring a => + Semigroup (Add a) where + (<>) = (coerce :: WrapBinary Add a) (<+>) + {-# INLINE (<>) #-} + +instance Semiring a => + Semigroup (Mul a) where + (<>) = (coerce :: WrapBinary Mul a) (<.>) + {-# INLINE (<>) #-} + +instance Semiring a => + Monoid (Add a) where + mempty = Add zero + {-# INLINE mempty #-} + mappend = (<>) + {-# INLINE mappend #-} + mconcat = (coerce :: ([a] -> a) -> [Add a] -> Add a) add + {-# INLINE mconcat #-} + +instance Semiring a => + Monoid (Mul a) where + mempty = Mul one + {-# INLINE mempty #-} + mappend = (<>) + {-# INLINE mappend #-} + mconcat = (coerce :: ([a] -> a) -> [Mul a] -> Mul a) mul + {-# INLINE mconcat #-} + +-------------------------------------------------------------------------------- +-- Traversable newtype +-------------------------------------------------------------------------------- +-- | A suitable definition of a square matrix for certain types which are both +-- 'Applicative' and 'Traversable'. For instance, given a type like so: +-- +-- >>> :{ +-- data Quad a = Quad a a a a deriving Show +-- instance Functor Quad where +-- fmap f (Quad w x y z) = Quad (f w) (f x) (f y) (f z) +-- instance Applicative Quad where +-- pure x = Quad x x x x +-- Quad fw fx fy fz <*> Quad xw xx xy xz = +-- Quad (fw xw) (fx xx) (fy xy) (fz xz) +-- instance Foldable Quad where +-- foldr f b (Quad w x y z) = f w (f x (f y (f z b))) +-- instance Traversable Quad where +-- traverse f (Quad w x y z) = Quad <$> f w <*> f x <*> f y <*> f z +-- :} +-- +-- The newtype performs as you would expect: +-- +-- >>> getMatrix one :: Quad (Quad Integer) +-- Quad (Quad 1 0 0 0) (Quad 0 1 0 0) (Quad 0 0 1 0) (Quad 0 0 0 1) +-- +-- 'ZipList's are another type which works with this newtype: +-- +-- >>> :{ +-- let xs = (Matrix . ZipList . map ZipList) [[1,2],[3,4]] +-- ys = (Matrix . ZipList . map ZipList) [[5,6],[7,8]] +-- in (map getZipList . getZipList . getMatrix) (xs <.> ys) +-- :} +-- [[19,22],[43,50]] +newtype Matrix f a = Matrix + { getMatrix :: f (f a) + } deriving (Generic,Generic1,Typeable,Functor,Foldable,Traversable) + +instance Applicative f => + Applicative (Matrix f) where + pure = Matrix #. pure . pure + (<*>) = + (coerce :: (f (f (a -> b)) -> f (f a) -> f (f b)) -> Matrix f (a -> b) -> Matrix f a -> Matrix f b) + (liftA2 (<*>)) + +instance (Traversable f, Applicative f, Semiring a) => + Semiring (Matrix f a) where + Matrix xs <.> Matrix ys = + Matrix (fmap (\row -> fmap (addFoldable . liftA2 (<.>) row) c) xs) + where + c = sequenceA ys + (<+>) = liftA2 (<+>) + zero = pure zero + one = case zero of + Matrix xs -> Matrix (imap (\i -> imap (\j x -> if i == j then one else x)) xs) + +newtype State a = State (Int -> (a, Int)) deriving Functor + +instance Applicative State where + pure x = State (\i -> (x, i)) + State fs <*> State xs = State (\i -> case fs i of + (f, i') -> case xs i' of + (x,i'') -> (f x, i'')) + +evalState :: State a -> Int -> a +evalState (State r) i = case r i of + (x,_) -> x + +imap :: Traversable t => (Int -> a -> b) -> t a -> t b +imap f xs = evalState (traverse (\x -> State (\i -> (f i x, i + 1))) xs) 0 + +infixr 9 #. +(#.) :: Coercible b c => (b -> c) -> (a -> b) -> a -> c +(#.) _ = coerce + +instance Show1 f => + Show1 (Matrix f) where + liftShowsPrec (sp :: Int -> a -> ShowS) sl = + showsNewtype "Matrix" "getMatrix" liftedTwiceSP liftedTwiceSL + where + liftedOnceSP :: Int -> f a -> ShowS + liftedOnceSP = liftShowsPrec sp sl + liftedOnceSL :: [f a] -> ShowS + liftedOnceSL = liftShowList sp sl + liftedTwiceSP :: Int -> f (f a) -> ShowS + liftedTwiceSP = liftShowsPrec liftedOnceSP liftedOnceSL + liftedTwiceSL :: [f (f a)] -> ShowS + liftedTwiceSL = liftShowList liftedOnceSP liftedOnceSL + +instance Read1 f => + Read1 (Matrix f) where + liftReadsPrec (rp :: Int -> ReadS a) rl = + readsNewtype "Matrix" "getMatrix" liftedTwiceRP liftedTwiceRL + where + liftedOnceRP :: Int -> ReadS (f a) + liftedOnceRP = liftReadsPrec rp rl + liftedOnceRL :: ReadS [f a] + liftedOnceRL = liftReadList rp rl + liftedTwiceRP :: Int -> ReadS (f (f a)) + liftedTwiceRP = liftReadsPrec liftedOnceRP liftedOnceRL + liftedTwiceRL :: ReadS [f (f a)] + liftedTwiceRL = liftReadList liftedOnceRP liftedOnceRL + +instance Eq1 f => + Eq1 (Matrix f) where + liftEq (eq :: a -> b -> Bool) = + coerce (liftEq (liftEq eq) :: f (f a) -> f (f b) -> Bool) + +instance Ord1 f => Ord1 (Matrix f) where + liftCompare (cmp :: a -> b -> Ordering) = + coerce (liftCompare (liftCompare cmp) :: f (f a) -> f (f b) -> Ordering) + +instance (Show1 f, Show a) => Show (Matrix f a) where + showsPrec = showsPrec1 + +instance (Read1 f, Read a) => Read (Matrix f a) where + readsPrec = readsPrec1 + +instance (Eq1 f, Eq a) => Eq (Matrix f a) where + (==) = eq1 + +instance (Ord1 f, Ord a) => Ord (Matrix f a) where + compare = compare1 + +-------------------------------------------------------------------------------- +-- Ord wrappers +-------------------------------------------------------------------------------- +-- | The "" or +-- min-plus semiring. It is a semiring where: +-- +-- @'<+>' = 'min' +--'zero' = ∞ +--'<.>' = '<+>' +--'one' = 'zero'@ +-- +-- Note that we can't use 'Data.Semigroup.Min' from 'Data.Semigroup' +-- because annihilation needs to hold: +-- +-- @∞ '<+>' x = x '<+>' ∞ = ∞@ +-- +-- Taking ∞ to be 'maxBound' would break the above law. Using 'positiveInfinity' +-- to represent it follows the law. +newtype Min a = Min + { getMin :: a + } deriving (Eq,Ord,Read,Show,Bounded,Generic,Generic1,Num,Enum,Typeable + ,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable) + +-- | The "" +-- or max-plus semiring. It is a semiring where: +-- +-- @'<+>' = 'max' +--'zero' = -∞ +--'<.>' = '<+>' +--'one' = 'zero'@ +-- +-- Note that we can't use 'Data.Semigroup.Max' from 'Data.Semigroup' +-- because annihilation needs to hold: +-- +-- @-∞ '<+>' x = x '<+>' -∞ = -∞@ +-- +-- Taking -∞ to be 'minBound' would break the above law. Using +-- 'negativeInfinity' to represent it follows the law. +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 Eq1 Max where + liftEq = coerce + +instance Ord1 Max where + liftCompare = coerce + +instance Show1 Max where + liftShowsPrec = showsNewtype "Max" "getMax" + +instance Read1 Max where + liftReadsPrec = readsNewtype "Max" "getMax" + +instance Eq1 Min where + liftEq = coerce + +instance Ord1 Min where + liftCompare = coerce + +instance Show1 Min where + liftShowsPrec = showsNewtype "Min" "getMin" + +instance Read1 Min where + liftReadsPrec = readsNewtype "Min" "getMin" + +instance Ord a => + Semigroup (Max a) where + (<>) = (coerce :: WrapBinary Max a) max + {-# INLINE (<>) #-} + +instance Ord a => + Semigroup (Min a) where + (<>) = (coerce :: WrapBinary Min a) min + {-# INLINE (<>) #-} + +-- | >>> (getMax . foldMap Max) [1..10] +-- 10.0 +instance (Ord a, HasNegativeInfinity a) => + Monoid (Max a) where + mempty = Max negativeInfinity + mappend = (<>) + {-# INLINE mempty #-} + {-# INLINE mappend #-} + +-- | >>> (getMin . foldMap Min) [1..10] +-- 1.0 +instance (Ord a, HasPositiveInfinity a) => + Monoid (Min a) where + mempty = Min positiveInfinity + mappend = (<>) + {-# INLINE mempty #-} + {-# INLINE mappend #-} + +instance (Semiring a, Ord a, HasNegativeInfinity a) => + Semiring (Max a) where + (<+>) = mappend + zero = mempty + (<.>) = (coerce :: WrapBinary Max a) (<+>) + one = Max zero + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance (Semiring a, Ord a, HasPositiveInfinity a) => + Semiring (Min a) where + (<+>) = mappend + zero = mempty + (<.>) = (coerce :: WrapBinary Min a) (<+>) + one = Min zero + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +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 + {-# INLINE isZero #-} + +instance (Semiring a, Ord a, HasNegativeInfinity a) => + DetectableZero (Max a) where + isZero (Max x) = isNegativeInfinity x + {-# INLINE isZero #-} + +-------------------------------------------------------------------------------- +-- (->) instance +-------------------------------------------------------------------------------- +-- | The @(->)@ instance is analogous to the one for 'Monoid'. +instance Semiring b => + Semiring (a -> b) where + zero = const zero + {-# INLINE zero #-} + one = const one + {-# INLINE one #-} + (f <+> g) x = f x <+> g x + {-# INLINE (<+>) #-} + (f <.> g) x = f x <.> g x + {-# INLINE (<.>) #-} + +instance StarSemiring b => + StarSemiring (a -> b) where + star = (.) star + {-# INLINE star #-} + plus = (.) plus + {-# INLINE plus #-} + +-------------------------------------------------------------------------------- +-- Endo instance +-------------------------------------------------------------------------------- +-- | This is /not/ a true semiring. In particular, it requires the +-- underlying monoid to be commutative, and even then, it is only a near +-- semiring. It is, however, extremely useful. For instance, this type: +-- +-- @forall a. 'Endo' ('Endo' a)@ +-- +-- Is a valid encoding of church numerals, with addition and +-- multiplication being their semiring variants. +instance Monoid a => + Semiring (Endo a) where + zero = Endo mempty + Endo f <+> Endo g = Endo (f `mappend` g) + one = mempty + (<.>) = mappend + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +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]) + +-------------------------------------------------------------------------------- +-- Instances for Bool wrappers +-------------------------------------------------------------------------------- +instance Semiring Any where + (<+>) = coerce (||) + zero = Any False + (<.>) = coerce (&&) + one = Any True + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance StarSemiring Any where + star _ = Any True + plus = id + {-# INLINE star #-} + {-# INLINE plus #-} + +instance Semiring All where + (<+>) = coerce (||) + zero = All False + (<.>) = coerce (&&) + one = All True + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance StarSemiring All where + star _ = All True + plus = id + {-# INLINE star #-} + {-# INLINE plus #-} + +instance DetectableZero Any where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero All where + isZero = isZeroEq + {-# INLINE isZero #-} + +-------------------------------------------------------------------------------- +-- Boring instances +-------------------------------------------------------------------------------- + +instance Semiring Int where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring Int8 where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring Int16 where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring Int32 where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring Int64 where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring Integer where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring Word where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring Word8 where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring Word16 where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring Word32 where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring Word64 where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring Float where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring Double where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CUIntMax where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CIntMax where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CUIntPtr where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CIntPtr where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CSUSeconds where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CUSeconds where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CTime where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CClock where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CSigAtomic where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CWchar where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CSize where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CPtrdiff where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CDouble where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CFloat where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CULLong where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CLLong where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CULong where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CLong where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CUInt where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CInt where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CUShort where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CShort where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CUChar where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CSChar where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CChar where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring IntPtr where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring WordPtr where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring Fd where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CRLim where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CTcflag where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CSpeed where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CCc where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CUid where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CNlink where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CGid where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CSsize where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CPid where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring COff where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CMode where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CIno where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring CDev where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring Natural where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Integral a => + Semiring (Ratio a) where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring a => Semiring (Product a) where + one = Product one + {-# INLINE one #-} + zero = Product zero + {-# INLINE zero #-} + (<+>) = (coerce :: WrapBinary Product a) (<+>) + {-# INLINE (<+>) #-} + (<.>) = (coerce :: WrapBinary Product a) (<.>) + {-# INLINE (<.>) #-} + +instance Semiring a => Semiring (Sum a) where + one = Sum one + {-# INLINE one #-} + zero = Sum zero + {-# INLINE zero #-} + (<+>) = (coerce :: WrapBinary Sum a) (<+>) + {-# INLINE (<+>) #-} + (<.>) = (coerce :: WrapBinary Sum a) (<.>) + {-# INLINE (<.>) #-} + +instance RealFloat a => + Semiring (Complex a) where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance HasResolution a => + Semiring (Fixed a) where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance Semiring a => Semiring (Identity a) where + one = Identity one + {-# INLINE one #-} + zero = Identity zero + {-# INLINE zero #-} + (<+>) = (coerce :: WrapBinary Identity a) (<+>) + {-# INLINE (<+>) #-} + (<.>) = (coerce :: WrapBinary Identity a) (<.>) + {-# INLINE (<.>) #-} + +instance DetectableZero Int where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero Int8 where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero Int16 where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero Int32 where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero Int64 where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero Integer where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero Word where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero Word8 where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero Word16 where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero Word32 where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero Word64 where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero Float where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero Double where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CUIntMax where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CIntMax where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CUIntPtr where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CIntPtr where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CSUSeconds where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CUSeconds where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CTime where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CClock where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CSigAtomic where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CWchar where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CSize where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CPtrdiff where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CDouble where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CFloat where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CULLong where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CLLong where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CULong where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CLong where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CUInt where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CInt where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CUShort where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CShort where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CUChar where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CSChar where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CChar where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero IntPtr where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero WordPtr where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero Fd where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CRLim where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CTcflag where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CSpeed where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CCc where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CUid where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CNlink where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CGid where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CSsize where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CPid where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero COff where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CMode where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CIno where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero CDev where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance DetectableZero Natural where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance Integral a => + DetectableZero (Ratio a) where + isZero = isZeroEq + {-# INLINE isZero #-} + +deriving instance DetectableZero a => DetectableZero (Product a) + +deriving instance DetectableZero a => DetectableZero (Sum a) + +instance RealFloat a => + DetectableZero (Complex a) where + isZero = isZeroEq + {-# INLINE isZero #-} + +instance HasResolution a => + DetectableZero (Fixed a) where + isZero = isZeroEq + {-# INLINE isZero #-} + +deriving instance DetectableZero a => DetectableZero (Identity a) + +-------------------------------------------------------------------------------- +-- Very boring instances +-------------------------------------------------------------------------------- +$(traverse semiringIns [2 .. 15]) + +$(traverse starIns [2 .. 15]) + +$(traverse zeroIns [2 .. 15]) diff --git a/src/Data/Semiring/Free.hs b/src/Data/Semiring/Free.hs --- a/src/Data/Semiring/Free.hs +++ b/src/Data/Semiring/Free.hs @@ -1,47 +1,76 @@ -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | The Free semiring. module Data.Semiring.Free - ( Free(..) - , liftFree - , unFree - ) where + (Free(..) + ,liftFree + ,lowerFree + ,runFree) + where -import Control.Applicative (liftA2) import Data.Coerce import Data.Semiring --- | The free semiring. Adapted from PureScript's version, available --- . --- Only a valid semiring if treated as a multiset, as in: --- --- > Free [[1],[0]] = Free [[0],[1]] -newtype Free a = Free - { getFree :: [[a]] - } deriving (Show, Read, Functor, Foldable, Traversable, Monoid) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map -instance Semiring (Free a) where - Free xs <+> Free ys = Free (xs ++ ys) - Free xs <.> Free ys = Free (liftA2 (++) xs ys) - one = Free [[]] - zero = Free [] +import Numeric.Natural -instance Applicative Free where - pure = Free . pure . pure - Free fs <*> Free xs = Free (liftA2 (<*>) fs xs) +-- | The free semiring +newtype Free a = Free + { getFree :: Map [a] Natural + } deriving (Show, Read, Eq, Ord, Semiring) +instance Ord a => Num (Free a) where + fromInteger = Free . Map.singleton [] . fromInteger + {-# INLINE fromInteger #-} + (+) = (<+>) + {-# INLINE (+) #-} + (*) = (<.>) + {-# INLINE (*) #-} + abs = id + {-# INLINE abs #-} + signum (Free x) = if Map.null x then zero else one + {-# INLINE signum #-} + negate = id + {-# INLINE negate #-} + -- | Run a 'Free'. -liftFree :: Semiring s => (a -> s) -> Free a -> s -liftFree f = unFree . fmap f +runFree :: Semiring s => (a -> s) -> Free a -> s +runFree f = getAdd .# Map.foldMapWithKey ((rep #. Add) . mul . map f) . getFree +{-# INLINE runFree #-} -- | Run a 'Free', interpreting it in the underlying semiring. -unFree :: Semiring s => Free s -> s -unFree = getAdd .# foldMap (Add .# getMul .# foldMap Mul) . getFree +lowerFree :: Semiring s => Free s -> s +lowerFree = runFree id +{-# INLINE lowerFree #-} +liftFree :: a -> Free a +liftFree = Free . flip Map.singleton one . pure +{-# INLINE liftFree #-} + +infixr 9 #. +(#.) :: Coercible a b => (b -> c) -> (a -> b) -> a -> c +(#.) f _ = coerce f +{-# INLINE (#.) #-} + infixr 9 .# -(.#) :: Coercible b c => (b -> c) -> (a -> b) -> a -> c +(.#) :: Coercible b c => (b -> c) -> (a -> b) -> a -> c (.#) _ = coerce +{-# INLINE (.#) #-} +instance Foldable Free where + foldMap f (Free xs) = Map.foldMapWithKey (rep . foldMap f) xs + {-# INLINE foldMap #-} + +rep :: Monoid m => m -> Natural -> m +rep x = go + where + go 0 = mempty + go 1 = x + go n + | even n = r `mappend` r + | otherwise = x `mappend` r `mappend` r + where + r = go (n `div` 2) +{-# INLINE rep #-} diff --git a/src/Data/Semiring/Numeric.hs b/src/Data/Semiring/Numeric.hs --- a/src/Data/Semiring/Numeric.hs +++ b/src/Data/Semiring/Numeric.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-| @@ -16,18 +17,23 @@ , Division(..) , Łukasiewicz(..) , Viterbi(..) - , Log(..) , PosFrac(..) , PosInt(..) ) where import Data.Coerce +import Text.Read +import Control.Monad + import Data.Semiring -import GHC.Generics +import GHC.Generics (Generic,Generic1) import Data.Typeable (Typeable) import Foreign.Storable (Storable) +import Data.Functor.Classes + + type WrapBinary f a = (a -> a -> a) -> f a -> f a -> f a -- | Useful for some constraint problems. @@ -52,8 +58,21 @@ {-# INLINE zero #-} {-# INLINE one #-} -instance (Bounded a, Ord a) => DetectableZero (Bottleneck a) +instance (Bounded a, Ord a) => DetectableZero (Bottleneck a) where + isZero = (zero==) +instance Eq1 Bottleneck where + liftEq = coerce + +instance Ord1 Bottleneck where + liftCompare = coerce + +instance Show1 Bottleneck where + liftShowsPrec = showsNewtype "Bottleneck" "getBottleneck" + +instance Read1 Bottleneck where + liftReadsPrec = readsNewtype "Bottleneck" "getBottleneck" + -- | Positive numbers only. -- -- @('<+>') = 'gcd' @@ -77,6 +96,18 @@ {-# INLINE zero #-} {-# INLINE one #-} +instance Eq1 Division where + liftEq = coerce + +instance Ord1 Division where + liftCompare = coerce + +instance Show1 Division where + liftShowsPrec = showsNewtype "Division" "getDivision" + +instance Read1 Division where + liftReadsPrec = readsNewtype "Division" "getDivision" + -- | -- has some information on this. Also -- @@ -102,8 +133,21 @@ {-# INLINE zero #-} {-# INLINE one #-} -instance (Ord a, Num a) => DetectableZero (Łukasiewicz a) +instance (Ord a, Num a) => DetectableZero (Łukasiewicz a) where + isZero = (zero==) +instance Eq1 Łukasiewicz where + liftEq = coerce + +instance Ord1 Łukasiewicz where + liftCompare = coerce + +instance Show1 Łukasiewicz where + liftShowsPrec = showsNewtype "Łukasiewicz" "getŁukasiewicz" + +instance Read1 Łukasiewicz where + liftReadsPrec = readsNewtype "Łukasiewicz" "getŁukasiewicz" + -- | -- has some information on this. Also -- @@ -129,31 +173,18 @@ {-# INLINE zero #-} {-# INLINE one #-} --- | Useful for optimizing multiplication, or working with large numbers. --- --- @('<.>') = ('+') ---x '<+>' y = -('log' ('exp' (-x) + 'exp' (-y))) ---'zero' = 'positiveInfinity' ---'one' = 0@ -newtype Log a = Log - { getLog :: a - } deriving (Eq, Ord, Read, Show, Generic, Generic1, Typeable, Functor - ,Foldable) +instance Eq1 Viterbi where + liftEq = coerce -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)))) - {-# INLINE (<+>) #-} - {-# INLINE (<.>) #-} - {-# INLINE zero #-} - {-# INLINE one #-} +instance Ord1 Viterbi where + liftCompare = coerce -instance (Floating a, HasPositiveInfinity a) => DetectableZero (Log a) where - isZero (Log x) = isPositiveInfinity x +instance Show1 Viterbi where + liftShowsPrec = showsNewtype "Viterbi" "getViterbi" +instance Read1 Viterbi where + liftReadsPrec = readsNewtype "Viterbi" "getViterbi" + -- | Adds a star operation to fractional types. -- -- @('<+>') = ('<+>') @@ -181,7 +212,8 @@ {-# INLINE zero #-} {-# INLINE one #-} -instance (Eq a, Semiring a) => DetectableZero (PosFrac a) +instance (Eq a, Semiring a) => DetectableZero (PosFrac a) where + isZero = (zero==) instance (Ord a, Fractional a, Semiring a, HasPositiveInfinity a) => StarSemiring (PosFrac a) where @@ -189,6 +221,18 @@ | n < 1 = PosFrac (1 / (1 - n)) | otherwise = PosFrac positiveInfinity +instance Eq1 PosFrac where + liftEq = coerce + +instance Ord1 PosFrac where + liftCompare = coerce + +instance Show1 PosFrac where + liftShowsPrec = showsNewtype "PosFrac" "getPosFrac" + +instance Read1 PosFrac where + liftReadsPrec = readsNewtype "PosFrac" "getPosFrac" + -- | Adds a star operation to integral types. -- -- @('<+>') = ('<+>') @@ -217,9 +261,44 @@ {-# INLINE zero #-} {-# INLINE one #-} -instance (Eq a, Semiring a) => DetectableZero (PosInt a) +instance (Eq a, Semiring a) => DetectableZero (PosInt a) where + isZero = (zero==) instance (Eq a, Semiring a, HasPositiveInfinity a) => StarSemiring (PosInt a) where star (PosInt n) | n == zero = PosInt one - star _ = PosInt positiveInfinity + star _ = PosInt positiveInfinity + +instance Eq1 PosInt where + liftEq = coerce + +instance Ord1 PosInt where + liftCompare = coerce + +instance Show1 PosInt where + liftShowsPrec = showsNewtype "PosInt" "getPosInt" + +instance Read1 PosInt where + liftReadsPrec = readsNewtype "PosInt" "getPosInt" + +showsNewtype :: Coercible b a => String -> String -> (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> b -> ShowS +showsNewtype cons acc = s + where + s sp _ n x = + showParen (n > 10) $ + showString cons . + showString " {" . + showString acc . showString " =" . sp 0 (coerce x) . showChar '}' + +readsNewtype :: Coercible a b => String -> String -> (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS b +readsNewtype cons acc = r where + r rp _ = readPrec_to_S $ prec 10 $ do + Ident c <- lexP + guard (c == cons) + Punc "{" <- lexP + Ident a <- lexP + guard (a == acc) + Punc "=" <- lexP + x <- prec 0 $ readS_to_Prec rp + Punc "}" <- lexP + pure (coerce x) diff --git a/src/Data/Semiring/TH.hs b/src/Data/Semiring/TH.hs --- a/src/Data/Semiring/TH.hs +++ b/src/Data/Semiring/TH.hs @@ -3,6 +3,14 @@ import Control.Monad import Language.Haskell.TH +typeNames :: Int -> Q [Name] +typeNames = traverse (pure . mkName) . map pure . flip take ['a'..] + +varNames :: Int -> Q [Name] +varNames n = + (traverse newName . map pure . reverse . take n . reverse . take 26) + ['a' ..] + repN :: Int -> String -> Q Dec repN n nm = do let v = VarP (mkName nm) @@ -12,7 +20,7 @@ appN :: Int -> String -> Q Dec appN n nm = do let f = VarE (mkName nm) - xs <- replicateM n (newName "x") + xs <- varNames n let args = [TupP (map VarP xs)] ntup = TupE (map (AppE f . VarE) xs) return $ FunD (mkName nm) [Clause args (NormalB ntup) []] @@ -20,35 +28,46 @@ cmbN :: Int -> String -> Q Dec cmbN n nm = do let f = VarE (mkName nm) - xs <- replicateM n (newName "x") - ys <- replicateM n (newName "y") + xs <- varNames n + ys <- varNames n let args = [TupP (map VarP xs), TupP (map VarP ys)] ntup = TupE (zipWith (AppE . AppE f) (map VarE xs) (map VarE ys)) return $ FunD (mkName nm) [Clause args (NormalB ntup) []] starIns :: Int -> Q Dec starIns n = do - names <- replicateM n (newName "a") + names <- typeNames n let c = ConT (mkName "StarSemiring") ct = map (AppT c . VarT) names InstanceD Nothing ct (AppT c $ foldl AppT (TupleT n) (map VarT names)) <$> - sequence [appN n "star", appN n "plus"] + sequence [appN n "star", pure (inline "star"), appN n "plus", pure (inline "plus")] +inline :: String -> Dec +inline n = PragmaD (InlineP (mkName n) Inline FunLike AllPhases) + semiringIns :: Int -> Q Dec semiringIns n = do - names <- replicateM n (newName "a") + names <- typeNames n let c = ConT (mkName "Semiring") ct = map (AppT c . VarT) names InstanceD Nothing ct (AppT c $ foldl AppT (TupleT n) (map VarT names)) <$> - sequence [cmbN n "<+>", cmbN n "<.>", repN n "zero", repN n "one"] + sequence + [ cmbN n "<+>" + , pure (inline "<+>") + , cmbN n "<.>" + , pure (inline "<.>") + , repN n "zero" + , pure (inline "zero") + , repN n "one" + , pure (inline "one")] zeroIns :: Int -> Q Dec zeroIns n = do - names <- replicateM n (newName "a") + names <- typeNames n let c = ConT (mkName "DetectableZero") ct = map (AppT c . VarT) names InstanceD Nothing ct (AppT c $ foldl AppT (TupleT n) (map VarT names)) <$> - sequence [andAll n] + sequence [andAll n, pure (inline "isZero")] andAll :: Int -> Q Dec andAll n = do diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,10 +1,14 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Main (main) where @@ -13,7 +17,7 @@ import Control.Arrow (first) import Data.Bool -import Data.Function +import Data.Proxy import Data.Foldable import Data.Monoid @@ -24,7 +28,6 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map - import Data.Semiring import Data.Semiring.Free import Data.Semiring.Infinite @@ -37,286 +40,295 @@ import Test.DocTest import Test.QuickCheck hiding (Positive (..), generate, (.&.)) -import Test.SmallCheck hiding (Testable, (==>)) import Test.SmallCheck.Series hiding (Positive) import qualified Test.SmallCheck.Series as SC +import Test.Tasty +import qualified Test.Tasty.QuickCheck as QC +import qualified Test.Tasty.SmallCheck as SC import Test.Semiring +import Data.Functor.Classes ------------------------------------------------------------------------ -main :: IO () -main = do - putStrLn "Integer" - smallCheck 1000 (unaryLaws :: UnaryLaws Integer) - smallCheck 1000 (zeroLaws :: UnaryLaws Integer) - smallCheck 100 (binaryLaws :: BinaryLaws Integer) - smallCheck 10 (ternaryLaws :: TernaryLaws Integer) - smallCheck 10 (ordLaws :: TernaryLaws Integer) - - putStrLn "(WordOfSize 2)" - smallCheck 16 (unaryLaws :: UnaryLaws (WordOfSize 2)) - smallCheck 16 (zeroLaws :: UnaryLaws (WordOfSize 2)) - smallCheck 16 (binaryLaws :: BinaryLaws (WordOfSize 2)) - smallCheck 16 (ternaryLaws :: TernaryLaws (WordOfSize 2)) - smallCheck 16 (starLaws :: UnaryLaws (PositiveInfinite (WordOfSize 2))) - - putStrLn "(WordOfSize 2,WordOfSize 2)" - smallCheck 16 (unaryLaws :: UnaryLaws (WordOfSize 2,WordOfSize 2)) - smallCheck 16 (zeroLaws :: UnaryLaws (WordOfSize 2,WordOfSize 2)) - smallCheck 14 (binaryLaws :: BinaryLaws (WordOfSize 2,WordOfSize 2)) - smallCheck 8 (ternaryLaws :: TernaryLaws (WordOfSize 2,WordOfSize 2)) - smallCheck 16 (starLaws :: UnaryLaws (PositiveInfinite (WordOfSize 2) - ,PositiveInfinite (WordOfSize 2))) - - putStrLn "(WordOfSize 2,WordOfSize 2,WordOfSize 2)" - smallCheck 10 (unaryLaws :: UnaryLaws (WordOfSize 2,WordOfSize 2,WordOfSize 2)) - smallCheck 10 (zeroLaws :: UnaryLaws (WordOfSize 2,WordOfSize 2,WordOfSize 2)) - smallCheck 5 (binaryLaws :: BinaryLaws (WordOfSize 2,WordOfSize 2,WordOfSize 2)) - smallCheck 2 (ternaryLaws :: TernaryLaws (WordOfSize 2,WordOfSize 2,WordOfSize 2)) - smallCheck 10 (starLaws :: UnaryLaws (PositiveInfinite (WordOfSize 2) - ,PositiveInfinite (WordOfSize 2) - ,PositiveInfinite (WordOfSize 2))) - - putStrLn "(WordOfSize 2,WordOfSize 2,WordOfSize 2,WordOfSize 2)" - smallCheck 8 (unaryLaws :: UnaryLaws (WordOfSize 2,WordOfSize 2,WordOfSize 2,WordOfSize 2)) - smallCheck 8 (zeroLaws :: UnaryLaws (WordOfSize 2,WordOfSize 2,WordOfSize 2,WordOfSize 2)) - smallCheck 4 (binaryLaws :: BinaryLaws (WordOfSize 2,WordOfSize 2,WordOfSize 2,WordOfSize 2)) - smallCheck 1 (ternaryLaws :: TernaryLaws (WordOfSize 2,WordOfSize 2,WordOfSize 2,WordOfSize 2)) - smallCheck 16 (starLaws :: UnaryLaws (PositiveInfinite (WordOfSize 2) - ,PositiveInfinite (WordOfSize 2) - ,PositiveInfinite (WordOfSize 2) - ,PositiveInfinite (WordOfSize 2))) - - putStrLn "(Int,Int,Int,Int,Int)" - quickCheck (unaryLaws :: UnaryLaws (Int,Int,Int,Int,Int)) - quickCheck (zeroLaws :: UnaryLaws (Int,Int,Int,Int,Int)) - quickCheck (binaryLaws :: BinaryLaws (Int,Int,Int,Int,Int)) - quickCheck (ternaryLaws :: TernaryLaws (Int,Int,Int,Int,Int)) - quickCheck (starLaws :: UnaryLaws (PositiveInfinite Int - ,PositiveInfinite Int - ,PositiveInfinite Int - ,PositiveInfinite Int - ,PositiveInfinite Int)) - - putStrLn "(Int,Int,Int,Int,Int,Int)" - quickCheck (unaryLaws :: UnaryLaws (Int,Int,Int,Int,Int,Int)) - quickCheck (zeroLaws :: UnaryLaws (Int,Int,Int,Int,Int,Int)) - quickCheck (binaryLaws :: BinaryLaws (Int,Int,Int,Int,Int,Int)) - quickCheck (ternaryLaws :: TernaryLaws (Int,Int,Int,Int,Int,Int)) - quickCheck (starLaws :: UnaryLaws (PositiveInfinite Int - ,PositiveInfinite Int - ,PositiveInfinite Int - ,PositiveInfinite Int - ,PositiveInfinite Int - ,PositiveInfinite Int)) - - putStrLn "(Int,Int,Int,Int,Int,Int,Int)" - quickCheck (unaryLaws :: UnaryLaws (Int,Int,Int,Int,Int,Int,Int)) - quickCheck (zeroLaws :: UnaryLaws (Int,Int,Int,Int,Int,Int,Int)) - quickCheck (binaryLaws :: BinaryLaws (Int,Int,Int,Int,Int,Int,Int)) - quickCheck (ternaryLaws :: TernaryLaws (Int,Int,Int,Int,Int,Int,Int)) - quickCheck (starLaws :: UnaryLaws (PositiveInfinite Int - ,PositiveInfinite Int - ,PositiveInfinite Int - ,PositiveInfinite Int - ,PositiveInfinite Int - ,PositiveInfinite Int - ,PositiveInfinite Int)) - - putStrLn "(Int,Int,Int,Int,Int,Int,Int,Int)" - quickCheck (unaryLaws :: UnaryLaws (Int,Int,Int,Int,Int,Int,Int,Int)) - quickCheck (zeroLaws :: UnaryLaws (Int,Int,Int,Int,Int,Int,Int,Int)) - quickCheck (binaryLaws :: BinaryLaws (Int,Int,Int,Int,Int,Int,Int,Int)) - quickCheck (ternaryLaws :: TernaryLaws (Int,Int,Int,Int,Int,Int,Int,Int)) - quickCheck (starLaws :: UnaryLaws (PositiveInfinite Int - ,PositiveInfinite Int - ,PositiveInfinite Int - ,PositiveInfinite Int - ,PositiveInfinite Int - ,PositiveInfinite Int - ,PositiveInfinite Int - ,PositiveInfinite Int)) - - putStrLn "(Int,Int,Int,Int,Int,Int,Int,Int,Int)" - quickCheck (unaryLaws :: UnaryLaws (Int,Int,Int,Int,Int,Int,Int,Int,Int)) - quickCheck (zeroLaws :: UnaryLaws (Int,Int,Int,Int,Int,Int,Int,Int,Int)) - quickCheck (binaryLaws :: BinaryLaws (Int,Int,Int,Int,Int,Int,Int,Int,Int)) - quickCheck (ternaryLaws :: TernaryLaws (Int,Int,Int,Int,Int,Int,Int,Int,Int)) - quickCheck (starLaws :: UnaryLaws (PositiveInfinite Int - ,PositiveInfinite Int - ,PositiveInfinite Int - ,PositiveInfinite Int - ,PositiveInfinite Int - ,PositiveInfinite Int - ,PositiveInfinite Int - ,PositiveInfinite Int - ,PositiveInfinite Int)) - - putStrLn "Int" - smallCheck 1000 (unaryLaws :: UnaryLaws Int) - smallCheck 1000 (zeroLaws :: UnaryLaws Int) - smallCheck 100 (binaryLaws :: BinaryLaws Int) - smallCheck 10 (ternaryLaws :: TernaryLaws Int) - - putStrLn "PosInf Natural" - smallCheck 1000 (unaryLaws :: UnaryLaws (PositiveInfinite Natural)) - smallCheck 1000 (zeroLaws :: UnaryLaws (PositiveInfinite Natural)) - smallCheck 100 (binaryLaws :: BinaryLaws (PositiveInfinite Natural)) - smallCheck 10 (ternaryLaws :: TernaryLaws (PositiveInfinite Natural)) - smallCheck 10 (ordLaws :: TernaryLaws (PositiveInfinite Natural)) - - putStrLn "NegInf Integer" - smallCheck 1000 (nearUnaryLaws :: UnaryLaws (NegativeInfinite Integer)) - smallCheck 1000 (zeroLaws :: UnaryLaws (NegativeInfinite Integer)) - smallCheck 100 (binaryLaws :: BinaryLaws (NegativeInfinite Integer)) - smallCheck 10 (plusAssoc :: TernaryLaws (NegativeInfinite Integer)) - smallCheck 10 (mulAssoc :: TernaryLaws (NegativeInfinite Integer)) - smallCheck 10 (mulDistribL :: TernaryLaws (NegativeInfinite Integer)) - smallCheck 10 (ordLaws :: TernaryLaws (NegativeInfinite Integer)) - - putStrLn "Inf Integer" - smallCheck 1000 (unaryLaws :: UnaryLaws (Infinite Integer)) - smallCheck 1000 (zeroLaws :: UnaryLaws (Infinite Integer)) - smallCheck 100 (binaryLaws :: BinaryLaws (Infinite Integer)) - smallCheck 10 (plusAssoc :: TernaryLaws (Infinite Integer)) - smallCheck 10 (mulAssoc :: TernaryLaws (Infinite Integer)) - smallCheck 10 (ordLaws :: TernaryLaws (Infinite Integer)) - - putStrLn "()" - smallCheck 1 (unaryLaws :: UnaryLaws ()) - smallCheck 1 (zeroLaws :: UnaryLaws ()) - smallCheck 1 (binaryLaws :: BinaryLaws ()) - smallCheck 1 (ternaryLaws :: TernaryLaws ()) - smallCheck 1 (starLaws :: UnaryLaws ()) - - putStrLn "Bool" - smallCheck 2 (unaryLaws :: UnaryLaws Bool) - smallCheck 2 (zeroLaws :: UnaryLaws Bool) - smallCheck 4 (binaryLaws :: BinaryLaws Bool) - smallCheck 8 (ternaryLaws :: TernaryLaws Bool) - smallCheck 2 (starLaws :: UnaryLaws Bool) - - putStrLn "Any" - smallCheck 2 (unLawsOn Any :: UnaryLaws Bool) - smallCheck 2 (zeroLaws . Any :: UnaryLaws Bool) - smallCheck 4 (binLawsOn Any :: BinaryLaws Bool) - smallCheck 8 (ternLawsOn Any :: TernaryLaws Bool) - - putStrLn "All" - smallCheck 2 (unLawsOn All :: UnaryLaws Bool) - smallCheck 2 (zeroLaws . All :: UnaryLaws Bool) - smallCheck 4 (binLawsOn All :: BinaryLaws Bool) - smallCheck 8 (ternLawsOn All :: TernaryLaws Bool) - - putStrLn "[WordOfSize 2]" - smallCheck 5 (unaryLaws :: UnaryLaws [WordOfSize 2]) - smallCheck 5 (zeroLaws :: UnaryLaws [WordOfSize 2]) - smallCheck 4 (binaryLaws :: BinaryLaws [WordOfSize 2]) - smallCheck 3 (ternaryLaws :: TernaryLaws [WordOfSize 2]) - - putStrLn "Min Integer" - smallCheck 1000 (unLawsOn Min :: UnaryLaws (PositiveInfinite Integer)) - smallCheck 100 (binLawsOn Min :: BinaryLaws (PositiveInfinite Integer)) - smallCheck 10 (ternLawsOn Min :: TernaryLaws (PositiveInfinite Integer)) - smallCheck 1000 (starLaws . Min :: UnaryLaws (Infinite Integer)) - - putStrLn "Max Integer" - smallCheck 1000 (unLawsOn Max :: UnaryLaws (NegativeInfinite Integer)) - smallCheck 100 (binLawsOn Max :: BinaryLaws (NegativeInfinite Integer)) - smallCheck 10 (ternLawsOn Max :: TernaryLaws (NegativeInfinite Integer)) - smallCheck 1000 (starLaws . Max :: UnaryLaws (Infinite Integer)) - - putStrLn "Free (WordOfSize 2)" - smallCheck 4 (unLawsOn Free :: UnaryLaws [[WordOfSize 2]]) - smallCheck 3 (binLawsOn Free :: BinaryLaws [[WordOfSize 2]]) - smallCheck 3 (ternLawsOn Free :: TernaryLaws [[WordOfSize 2]]) - - putStrLn "Bottleneck (WordOfSize 2)" - smallCheck 1000 (unLawsOn Bottleneck :: UnaryLaws (WordOfSize 2)) - smallCheck 1000 (zeroLaws . Bottleneck :: UnaryLaws (WordOfSize 2)) - smallCheck 100 (binLawsOn Bottleneck :: BinaryLaws (WordOfSize 2)) - smallCheck 10 (ternLawsOn Bottleneck :: TernaryLaws (WordOfSize 2)) - - putStrLn "Division Integer" - smallCheck 1000 (unLawsOn (Division . getPositive) :: UnaryLaws (SC.Positive Integer)) - smallCheck 1000 (zeroLaws . Division . getPositive :: UnaryLaws (SC.Positive Integer)) - smallCheck 100 (binLawsOn (Division . getPositive) :: BinaryLaws (SC.Positive Integer)) - smallCheck 10 (ternLawsOn (Division . getPositive) :: TernaryLaws (SC.Positive Integer)) - - putStrLn "Łukasiewicz Double" - smallCheck 1000 (unLawsOn Łukasiewicz :: UnaryLaws Fraction) - smallCheck 1000 (zeroLaws . Łukasiewicz :: UnaryLaws Fraction) - smallCheck 100 (binLawsOn Łukasiewicz :: BinaryLaws Fraction) - smallCheck 10 (ternLawsOn Łukasiewicz :: TernaryLaws Fraction) - - putStrLn "Viterbi Double" - smallCheck 1000 (unLawsOn Viterbi :: UnaryLaws Fraction) - smallCheck 1000 (zeroLaws . Viterbi :: UnaryLaws Fraction) - smallCheck 100 (binLawsOn Viterbi :: BinaryLaws Fraction) - smallCheck 10 (ternLawsOn Viterbi :: TernaryLaws Fraction) - - putStrLn "Log Double" - quickCheck (unLawsOn Log :: UnaryLaws (Approx Double)) - quickCheck (zeroLaws . Log :: UnaryLaws (Approx Double)) - quickCheck (binLawsOn Log :: BinaryLaws (Approx Double)) - quickCheck (ternLawsOn Log :: TernaryLaws (Approx Double)) - - putStrLn "Bool -> Bool" - smallCheck 3 (unLawsOn fromFunc :: UnaryLaws (Bool -> Bool)) - smallCheck 2 (binLawsOn fromFunc :: BinaryLaws (Bool -> Bool)) - smallCheck 2 (ternLawsOn fromFunc :: TernaryLaws (Bool -> Bool)) - quickCheck (unLawsOn fromFunc :: UnaryLaws (Bool -> Bool)) - quickCheck (binLawsOn fromFunc :: BinaryLaws (Bool -> Bool)) - quickCheck (ternLawsOn fromFunc :: TernaryLaws (Bool -> Bool)) - - - putStrLn "Endo (Add Bool)" - smallCheck 3 (nearUnaryLaws . eFromFunc :: UnaryLaws (Bool -> Bool)) - smallCheck 3 (zeroLaws . eFromFunc :: UnaryLaws (Bool -> Bool)) - smallCheck 2 (binLawsOn eFromFunc :: BinaryLaws (Bool -> Bool)) - smallCheck 2 (ternOn nearTernaryLaws eFromFunc :: TernaryLaws (Bool -> Bool)) +semiringLawsSC :: (Show r, Eq r, Semiring r, Serial IO r) => f r -> TestTree +semiringLawsSC (_ :: f r) = testGroup "Semiring Laws" + [ SC.testProperty "plusId" (plusId :: r -> Either String String) + , SC.testProperty "mulId" (mulId :: r -> Either String String) + , SC.testProperty "annihilateL" (annihilateL :: r -> Either String String) + , SC.testProperty "annihilateR" (annihilateR :: r -> Either String String) + , SC.testProperty "plusComm" (plusComm :: r -> r -> Either String String) + , SC.testProperty "plusAssoc" (plusAssoc :: r -> r -> r -> Either String String) + , SC.testProperty "mulAssoc" (mulAssoc :: r -> r -> r -> Either String String) + , SC.testProperty "mulDistribL" (mulDistribL :: r -> r -> r -> Either String String) + , SC.testProperty "mulDistribR" (mulDistribR :: r -> r -> r -> Either String String)] - doctest [ "-isrc" - , "src/" ] +semiringLawsQC :: (Show r, Eq r, Semiring r, Arbitrary r) => f r -> TestTree +semiringLawsQC (_ :: f r) = testGroup "Semiring Laws" + [ QC.testProperty "plusId" (plusId :: r -> Either String String) + , QC.testProperty "mulId" (mulId :: r -> Either String String) + , QC.testProperty "annihilateL" (annihilateL :: r -> Either String String) + , QC.testProperty "annihilateR" (annihilateR :: r -> Either String String) + , QC.testProperty "plusComm" (plusComm :: r -> r -> Either String String) + , QC.testProperty "plusAssoc" (plusAssoc :: r -> r -> r -> Either String String) + , QC.testProperty "mulAssoc" (mulAssoc :: r -> r -> r -> Either String String) + , QC.testProperty "mulDistribL" (mulDistribL :: r -> r -> r -> Either String String) + , QC.testProperty "mulDistribR" (mulDistribR :: r -> r -> r -> Either String String)] +starLawsQC :: (Show r, Eq r, StarSemiring r, Arbitrary r) => f r -> TestTree +starLawsQC (_ :: f r) = testGroup "Star laws" + [ QC.testProperty "starLaw" (starLaw :: r -> Either String String) + , QC.testProperty "plusLaw" (plusLaw :: r -> Either String String)] --- Test helpers +starLawsSC :: (Show r, Eq r, StarSemiring r, Serial IO r) => f r -> TestTree +starLawsSC (_ :: f r) = testGroup "Star laws" + [ SC.testProperty "starLaw" (starLaw :: r -> Either String String) + , SC.testProperty "plusLaw" (plusLaw :: r -> Either String String)] -unOn :: UnaryLaws b -> (a -> b) -> UnaryLaws a -unOn = (.) +-- ordLawsQC :: (Show r, Ord r, Semiring r, Arbitrary r) => f r -> TestTree +-- ordLawsQC (_ :: f r) = testGroup "Ordering laws" +-- [ QC.testProperty "mulLaw" (ordMulLaw :: r -> r -> r -> Either String String) +-- , QC.testProperty "addLaw" (ordAddLaw :: r -> r -> r -> Either String String)] -binOn :: BinaryLaws b -> (a -> b) -> BinaryLaws a -binOn = on +zeroLawsQC :: (Show r, Eq r, DetectableZero r, Arbitrary r) => f r -> TestTree +zeroLawsQC (_ :: f r) = testGroup "Zero laws" + [ QC.testProperty "zeroLaw" (zeroLaw :: r -> Either String String) + , QC.testProperty "zeroIsZero" (once $ zeroIsZero (Proxy :: Proxy r))] -ternOn :: TernaryLaws b -> (a -> b) -> TernaryLaws a -ternOn t f x y z = t (f x) (f y) (f z) +ordLawsSC :: (Show r, Ord r, Semiring r, Serial IO r) => f r -> TestTree +ordLawsSC (_ :: f r) = testGroup "Ordering laws" + [ SC.testProperty "mulLaw" (ordMulLaw :: r -> r -> r -> Either String String) + , SC.testProperty "addLaw" (ordAddLaw :: r -> r -> r -> Either String String)] -unLawsOn :: (Eq b, Semiring b, Show b) => (a -> b) -> UnaryLaws a -unLawsOn = unOn unaryLaws +zeroLawsSC :: (Show r, Eq r, DetectableZero r, Serial IO r) => f r -> TestTree +zeroLawsSC (_ :: f r) = testGroup "Zero laws" + [ SC.testProperty "zeroLaw" (zeroLaw :: r -> Either String String) + , SC.testProperty "zeroIsZero" (zeroIsZero (Proxy :: Proxy r))] -binLawsOn :: (Eq b, Semiring b, Show b) => (a -> b) -> BinaryLaws a -binLawsOn = binOn binaryLaws +type Tup2 a = (a,a) +type Tup3 a = (a,a,a) +type Tup4 a = (a,a,a,a) +type Tup5 a = (a,a,a,a,a) +type Tup6 a = (a,a,a,a,a,a) +type Tup7 a = (a,a,a,a,a,a,a) +type Tup8 a = (a,a,a,a,a,a,a,a) +type Tup9 a = (a,a,a,a,a,a,a,a,a) -ternLawsOn :: (Eq b, Semiring b, Show b) => (a -> b) -> TernaryLaws a -ternLawsOn = ternOn ternaryLaws +main :: IO () +main = do + doctest ["-isrc", "src/"] + defaultMain $ + testGroup + "Tests" + [ let p = Proxy :: Proxy (Map String Int) + in testGroup "Map" [localOption (QC.QuickCheckMaxSize 10) $ semiringLawsQC p] + , let p = Proxy :: Proxy (Matrix Quad Integer) + in testGroup "Matrix" [semiringLawsQC p] + , let p = Proxy :: Proxy Integer + in testGroup + "Integer" + [semiringLawsSC p, ordLawsSC p, zeroLawsSC p] + , let p = Proxy :: Proxy (Func Bool Bool) + in testGroup "Bool -> Bool" + [semiringLawsQC p] + , testGroup "Endo Bool" + [ QC.testProperty + "plusId" + (plusId :: UnaryLaws (EndoFunc (Add Bool))) + , QC.testProperty + "mulId" + (mulId :: UnaryLaws (EndoFunc (Add Bool))) + , QC.testProperty + "annihilateR" + (annihilateR :: UnaryLaws (EndoFunc (Add Bool))) + , zeroLawsQC (Proxy :: Proxy (EndoFunc (Add Bool))) + , QC.testProperty + "plusComm" + (plusComm :: BinaryLaws (EndoFunc (Add Bool))) + , QC.testProperty + "plusAssoc" + (plusAssoc :: TernaryLaws (EndoFunc (Add Bool))) + , QC.testProperty + "mulAssoc" + (mulAssoc :: TernaryLaws (EndoFunc (Add Bool))) + , QC.testProperty + "mulDistribR" + (mulDistribR :: TernaryLaws (EndoFunc (Add Bool)))] + , let p = Proxy :: Proxy (PositiveInfinite Natural) + in testGroup + "PosInf Natural" + [semiringLawsSC p, ordLawsSC p, zeroLawsSC p] + , let p = Proxy :: Proxy Int + in testGroup "Int" [semiringLawsSC p, ordLawsSC p, zeroLawsSC p] + , let p = Proxy :: Proxy (WordOfSize 2) + in testGroup + "WordOfSize 2" + [semiringLawsSC p, zeroLawsSC p] + , let p = Proxy :: Proxy (Tup2 (WordOfSize 2)) + in testGroup + "Tup2 (WordOfSize 2)" + [semiringLawsSC p, zeroLawsSC p] + , let p = Proxy :: Proxy (Tup3 (WordOfSize 2)) + in testGroup + "Tup3 (WordOfSize 2)" + [semiringLawsSC p, zeroLawsSC p] + , let p = Proxy :: Proxy (Tup4 Int) + in testGroup + "Tup4 Int" + [semiringLawsQC p, zeroLawsQC p] + , let p = Proxy :: Proxy (Tup5 Int) + in testGroup + "Tup5 Int" + [semiringLawsQC p, zeroLawsQC p] + , let p = Proxy :: Proxy (Tup6 Int) + in testGroup + "Tup6 Int" + [semiringLawsQC p, zeroLawsQC p] + , let p = Proxy :: Proxy (Tup7 Int) + in testGroup + "Tup7 Int" + [semiringLawsQC p, zeroLawsQC p] + , let p = Proxy :: Proxy (Tup8 Int) + in testGroup + "Tup8 Int" + [semiringLawsQC p, zeroLawsQC p] + , let p = Proxy :: Proxy (Tup9 Int) + in testGroup + "Tup9 Int" + [semiringLawsQC p, zeroLawsQC p] + , let p = Proxy :: Proxy (Tup2 (PositiveInfinite (WordOfSize 2))) + in testGroup + "Tup2 (WordOfSize 2)" + [starLawsSC p] + , let p = Proxy :: Proxy (Tup3 (PositiveInfinite (WordOfSize 2))) + in testGroup + "Tup3 (WordOfSize 2)" + [starLawsSC p] + , let p = Proxy :: Proxy (Tup4 (PositiveInfinite Int)) + in testGroup + "Tup4 Int" + [starLawsQC p] + , let p = Proxy :: Proxy (Tup5 (PositiveInfinite Int)) + in testGroup + "Tup5 Int" + [starLawsQC p] + , let p = Proxy :: Proxy (Tup6 (PositiveInfinite Int)) + in testGroup + "Tup6 Int" + [starLawsQC p] + , let p = Proxy :: Proxy (Tup7 (PositiveInfinite Int)) + in testGroup + "Tup7 Int" + [starLawsQC p] + , let p = Proxy :: Proxy (Tup8 (PositiveInfinite Int)) + in testGroup + "Tup8 Int" + [starLawsQC p] + , let p = Proxy :: Proxy (Tup9 (PositiveInfinite Int)) + in testGroup + "Tup9 Int" + [starLawsQC p] + , testGroup + "Negative Infinite Integer" + [ SC.testProperty + "plusId" + (plusId :: UnaryLaws (NegativeInfinite Integer)) + , SC.testProperty + "mulId" + (mulId :: UnaryLaws (NegativeInfinite Integer)) + , SC.testProperty + "annihilateR" + (annihilateR :: UnaryLaws (NegativeInfinite Integer)) + , zeroLawsSC (Proxy :: Proxy (NegativeInfinite Integer)) + , SC.testProperty + "plusComm" + (plusComm :: BinaryLaws (NegativeInfinite Integer)) + , ordLawsSC (Proxy :: Proxy (NegativeInfinite Integer)) + , SC.testProperty + "plusAssoc" + (plusAssoc :: TernaryLaws (NegativeInfinite Integer)) + , SC.testProperty + "mulAssoc" + (mulAssoc :: TernaryLaws (NegativeInfinite Integer)) + , SC.testProperty + "mulDistribL" + (mulDistribL :: TernaryLaws (NegativeInfinite Integer))] + , testGroup + "Infinite Integer" + [ SC.testProperty + "plusId" + (plusId :: UnaryLaws (Infinite Integer)) + , SC.testProperty + "mulId" + (mulId :: UnaryLaws (Infinite Integer)) + , SC.testProperty + "annihilateR" + (annihilateR :: UnaryLaws (Infinite Integer)) + , SC.testProperty + "annihilateL" + (annihilateL :: UnaryLaws (Infinite Integer)) + , zeroLawsSC (Proxy :: Proxy (Infinite Integer)) + , SC.testProperty + "plusComm" + (plusComm :: BinaryLaws (Infinite Integer)) + , ordLawsSC (Proxy :: Proxy (Infinite Integer)) + , SC.testProperty + "plusAssoc" + (plusAssoc :: TernaryLaws (Infinite Integer)) + , SC.testProperty + "mulAssoc" + (mulAssoc :: TernaryLaws (Infinite Integer))] + , let p = Proxy :: Proxy () + in testGroup + "()" + [semiringLawsSC p, ordLawsSC p, zeroLawsSC p, starLawsSC p] + , let p = Proxy :: Proxy Bool + in testGroup + "Bool" + [semiringLawsSC p, ordLawsSC p, zeroLawsSC p, starLawsSC p] + , let p = Proxy :: Proxy Any + in testGroup + "Any" + [semiringLawsSC p, ordLawsSC p, zeroLawsSC p, starLawsSC p] + , let p = Proxy :: Proxy All + in testGroup + "All" + [semiringLawsSC p, ordLawsSC p, zeroLawsSC p, starLawsSC p] + , let p = Proxy :: Proxy [WordOfSize 2] + in testGroup "[WordOfSize 2]" [semiringLawsSC p, zeroLawsSC p] + , let p = Proxy :: Proxy (Min (PositiveInfinite Integer)) + in testGroup + "Min Inf Integer" + [semiringLawsSC p, zeroLawsSC p] + , let p = Proxy :: Proxy (Min (Infinite Integer)) + in testGroup + "Min Inf Integer" + [starLawsSC p] + , let p = Proxy :: Proxy (Max (NegativeInfinite Integer)) + in testGroup + "Max NegInf Integer" + [semiringLawsSC p, zeroLawsSC p] + , let p = Proxy :: Proxy (Max (Infinite Integer)) + in testGroup + "Max Inf Integer" + [starLawsSC p] + , let p = Proxy :: Proxy (Free (WordOfSize 2)) + in testGroup "Free (WordOfSize 2)" [localOption (QC.QuickCheckMaxSize 10) $ semiringLawsQC p] + , let p = Proxy :: Proxy (Division (SC.Positive Integer)) + in testGroup "Division Integer" [semiringLawsSC p, zeroLawsSC p] + , let p = Proxy :: Proxy (Łukasiewicz Fraction) + in testGroup + "Łukasiewicz Fraction" + [semiringLawsSC p, zeroLawsSC p] + , let p = Proxy :: Proxy (Viterbi Fraction) + in testGroup "Viterbi Fraction" [semiringLawsSC p, zeroLawsSC p]] + -- , let p = Proxy :: Proxy (Log (Approx Double)) + -- in testGroup + -- "Log (Approx Double)" + -- [semiringLawsQC p, zeroLawsQC p]] -isAnagram :: Ord a => [a] -> [a] -> Bool -isAnagram = go (Map.empty :: Map a Int) where - go !m (x:xs) (y:ys) = - go ( Map.alter (remZero . maybe (-1) pred) x - $ Map.alter (remZero . maybe 1 succ) y - m) xs ys - go !m [] [] = Map.null m - go _ _ _ = False - remZero 0 = Nothing - remZero n = Just n - -instance Ord a => Eq (Free a) where - (==) = isAnagram `on` getFree - ------------------------------------------------------------------------ -- Serial wrappers @@ -370,9 +382,15 @@ instance KnownNat n => Arbitrary (WordOfSize n) where arbitrary = arbitraryBoundedEnum -instance KnownNat n => Semiring (WordOfSize n) -instance KnownNat n => DetectableZero (WordOfSize n) +instance KnownNat n => Semiring (WordOfSize n) where + one = 1 + zero = 0 + (<+>) = (+) + (<.>) = (*) +instance KnownNat n => DetectableZero (WordOfSize n) where + isZero = (zero==) + instance (Monad m, Serial m a) => Serial m (PositiveInfinite a) where series = fmap (maybe PositiveInfinity PosFinite) series @@ -385,6 +403,45 @@ instance Monad m => Serial m Natural where series = generate (`take` [0..]) +instance Monad m => Serial m Any where + series = fmap Any series + +instance Monad m => Serial m All where + series = fmap All series + +instance (Monad m, Serial m a) => Serial m (Min a) where + series = fmap Min series + +instance (Monad m, Serial m a) => Serial m (Max a) where + series = fmap Max series + +instance (Ord a, Arbitrary a) => Arbitrary (Free a) where + arbitrary = fmap Free arbitrary + +instance Num a => Semiring (SC.Positive a) where + zero = 0 + one = 1 + (<+>) = (+) + (<.>) = (*) + +instance (Eq a, Num a) => DetectableZero (SC.Positive a) where + isZero = (zero==) + +instance (Serial m a, Monad m) => Serial m (Division a) where + series = fmap Division series + +instance (Serial m a, Monad m) => Serial m (Łukasiewicz a) where + series = fmap Łukasiewicz series + +instance (Serial m a, Monad m) => Serial m (Viterbi a) where + series = fmap Viterbi series + +-- instance (Serial m a, Monad m) => Serial m (Log a) where +-- series = fmap Log series + +-- instance Arbitrary a => Arbitrary (Log a) where +-- arbitrary = fmap Log arbitrary + ------------------------------------------------------------------------ -- Function Equality @@ -400,6 +457,14 @@ instance (Enum a, Bounded a, Ord a, Show a) => Show (EndoFunc a) where show (EndoFunc (Endo f)) = show (fromFunc f) +instance (Bounded a, Enum a, Ord b, Arbitrary b, CoArbitrary a) => + Arbitrary (Func a b) where + arbitrary = fmap fromFunc arbitrary + +instance (Arbitrary a, CoArbitrary a) => + Arbitrary (EndoFunc (Add a)) where + arbitrary = fmap eFromFunc arbitrary + fromList' :: Eq b => b -> [(Int,b)] -> Func a b fromList' cnst = Func cnst @@ -420,13 +485,23 @@ eFromFunc :: (a -> a) -> EndoFunc (Add a) eFromFunc f = (EndoFunc . Endo) (Add . f . getAdd) +data Pair a b = !a :*: !b + +fst' :: Pair a b -> a +fst' (x :*: _) = x + +data Many a = (:#:) {-# UNPACK #-} !Int !a + +val :: Many a -> a +val (_ :#: x) = x + mostFrequent :: (Ord a, Foldable f) => f a -> Maybe a -mostFrequent = fmap fst . fst . foldl' f (Nothing, Map.empty :: Map.Map a Int) where - f (b,m) e = (Just nb, Map.insert e c m) where +mostFrequent = fmap val . fst' . foldl' f (Nothing :*: (Map.empty :: Map a Int)) where + f (b :*: m) e = Just nb :*: Map.insert e c m where c = maybe 1 succ (Map.lookup e m) nb = case b of - Just (a,d) | d >= c -> (a,d) - _ -> (e,c) + Just (d :#: a) | d >= c -> d :#: a + _ -> c :#: e apply :: Enum a => Func a b -> a -> b apply (Func c cs) x = IntMap.findWithDefault c (fromEnum x) cs @@ -442,8 +517,28 @@ f <+> g = fromFunc (apply f <+> apply g) f <.> g = fromFunc (apply f <.> apply g) +data Quad a = Quad a a a a deriving (Show, Eq, Ord, Functor, Foldable, Traversable) +instance Applicative Quad where + pure x = Quad x x x x + Quad fw fx fy fz <*> Quad xw xx xy xz = Quad (fw xw) (fx xx) (fy xy) (fz xz) +instance Eq1 Quad where + liftEq eq x y = mulFoldable (liftA2 eq x y) + +instance Ord1 Quad where + liftCompare cmp x y = fold (liftA2 cmp x y) + +instance Show1 Quad where + liftShowsPrec sp _ n (Quad w x y z) = + showParen (n > 10) $ + showString "Quad " . + sp 10 w . sp 10 x . sp 10 y . sp 10 z + +instance Arbitrary a => Arbitrary (Quad a) where + arbitrary = Quad <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + shrink = traverse shrink + ------------------------------------------------------------------------ -- QuickCheck wrappers @@ -459,48 +554,6 @@ instance Testable (Either String String) where property = either (`counterexample` False) (const (property True)) -instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e - ,Arbitrary f) - => Arbitrary (a,b,c,d,e,f) where - arbitrary = (,,,,,) <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - -instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e - ,Arbitrary f, Arbitrary g) - => Arbitrary (a,b,c,d,e,f,g) where - arbitrary = (,,,,,,) <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - -instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e - ,Arbitrary f, Arbitrary g, Arbitrary h) - => Arbitrary (a,b,c,d,e,f,g,h) where - arbitrary = (,,,,,,,) <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - -instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e - ,Arbitrary f, Arbitrary g, Arbitrary h, Arbitrary i) - => Arbitrary (a,b,c,d,e,f,g,h,i) where - arbitrary = (,,,,,,,,) <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary +instance Arbitrary (f (f a)) => Arbitrary (Matrix f a) where + arbitrary = fmap Matrix arbitrary + shrink (Matrix xs) = fmap Matrix (shrink xs)