diff --git a/bench/bench.hs b/bench/bench.hs --- a/bench/bench.hs +++ b/bench/bench.hs @@ -22,30 +22,35 @@ \xs -> bgroup (show n) [bench "add" $ nf add xs] -prodAtSize :: Int -> Int -> Benchmark -prodAtSize n m = +atSizeList :: Int -> Int -> Benchmark +atSizeList n m = env ((,) <$> replicateM n int <*> replicateM m int) $ \xs -> - bench "prod-list" (nf (uncurry (<.>)) xs) + bgroup + (show (n, m)) + [ bench (show n ++ "<.>" ++ show m) (nf (uncurry (<.>)) xs) + , bench (show m ++ "<.>" ++ show n) (nf (uncurry (flip (<.>))) xs) + , bench (show n ++ "<+>" ++ show m) (nf (uncurry (<+>)) xs) + , bench (show m ++ "<+>" ++ show n) (nf (uncurry (flip (<+>))) xs)] -prodAtSizeVec :: Int -> Int -> Benchmark -prodAtSizeVec n m = +starList :: Int -> Benchmark +starList n = env (replicateM n (pure ())) $ \xs -> bench (show n) (nf (take n . star) xs) + +atSizeVec :: Int -> Int -> Benchmark +atSizeVec n m = env ((,) <$> Vector.replicateM n int <*> Vector.replicateM m int) $ \xs -> bgroup - "vec" + (show (n, m)) [ bench (show n ++ "<.>" ++ show m) (nf (uncurry (<.>)) xs) , bench (show m ++ "<.>" ++ show n) (nf (uncurry (flip (<.>))) xs) , bench (show n ++ "<+>" ++ show m) (nf (uncurry (<+>)) xs) - , bench (show m ++ "<+>" ++ show n) (nf (uncurry (flip (<+>))) xs) - ] + , bench (show m ++ "<+>" ++ show n) (nf (uncurry (flip (<+>))) xs)] main :: IO () main = defaultMain - [ prodAtSizeVec 4000 2000 - , prodAtSizeVec 4000 2000] - - - --- prodAtSize 2000 1000, sumAtSize 10000] + [ bgroup "list star" [starList 2000] + , bgroup "vec" [atSizeVec 4000 2000, atSizeVec 4000 2000] + , bgroup "list" [atSizeList 400 200, atSizeList 4000 2000] + , bgroup "add" [sumAtSize 100, sumAtSize 1000]] 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.5.0.0 +version: 1.6.0.0 synopsis: Basic semiring class and instances description: Adds a basic semiring class homepage: https://github.com/oisdk/semiring-num @@ -20,15 +20,17 @@ , Data.Semiring.Infinite , Test.Semiring other-modules: Data.Semiring.TH - build-depends: base >= 4.9 && < 5 - , template-haskell >= 2.11 - , containers >= 0.5 - , log-domain >= 0.10 - , scientific >= 0.3 - , time >= 1.6 - , unordered-containers >= 0.2 - , vector >= 0.12 - , hashable >= 1.2 + , Data.Semiring.Newtype + build-depends: base >=4.9 && <5 + , template-haskell >=2.11 + , containers >=0.5 + , log-domain >=0.10.3.1 + , scientific >=0.3.4.10 + , time >=1.6 + , unordered-containers >=0.2.6.0 + , vector >=0.10.12.3 + , hashable >=1.2.4.0 + , deepseq >=1.4 default-language: Haskell2010 ghc-options: -Wall @@ -36,18 +38,25 @@ type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs - build-depends: base >= 4.9 && < 5 + other-modules: Func + , CompUtils + , Orphans + , ApproxLog + , Fraction + , Vectors + , LimitSize + build-depends: base >=4.9 && <5 , semiring-num - , smallcheck >= 1.1 - , doctest >= 0.11 - , 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 - , vector >= 0.12 + , smallcheck >=0.2.1 + , doctest >=0.3.0 + , containers >=0.5 + , QuickCheck >=1.0 + , nat-sized-numbers >=0.1.0.0 + , tasty >=0.1 + , tasty-smallcheck >=0.1 + , tasty-quickcheck >=0.1 + , log-domain >=0.10.3.1 + , vector >=0.10.12.3 ghc-options: -threaded -rtsopts -with-rtsopts=-N @@ -58,12 +67,12 @@ type: exitcode-stdio-1.0 hs-source-dirs: bench main-is: bench.hs - build-depends: base + build-depends: base -any , semiring-num - , criterion >=1.1 - , random >= 1.1 - , containers >= 0.5 - , vector >= 0.12 + , criterion >=0.1 + , random >=1.0.0.0 + , containers >=0.5 + , vector >=0.10.12.3 ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 diff --git a/src/Data/Semiring.hs b/src/Data/Semiring.hs --- a/src/Data/Semiring.hs +++ b/src/Data/Semiring.hs @@ -1,13 +1,15 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} {-| Module: Data.Semiring @@ -40,61 +42,74 @@ -- * Matrix wrapper Matrix(..) ,transpose - ,mulMatrix) + ,mulMatrix + ,rows + ,cols) 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.Scientific(Scientific) -import Data.Time.Clock(DiffTime,NominalDiffTime) +import Data.Complex (Complex) +import Data.Fixed (Fixed, HasResolution) +import Data.Functor.Identity (Identity (..)) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Ratio (Ratio) +import Data.Scientific (Scientific) +import Data.Time.Clock (DiffTime, NominalDiffTime) +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 Numeric.Natural (Natural) +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.Semigroup hiding (Max (..), Min (..)) -import Data.Coerce -import GHC.Generics (Generic, Generic1) -import Data.Typeable (Typeable) -import Foreign.Storable (Storable) +import Data.Coerce +import Data.Typeable (Typeable) +import Foreign.Storable (Storable) +import GHC.Generics (Generic, Generic1) -import Data.Semiring.TH -import Data.Functor.Classes -import Text.Read +import Data.Functor.Classes +import Data.Semiring.TH -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map -import Data.Set (Set) -import qualified Data.Set as Set +import Data.Set (Set) +import qualified Data.Set as Set -import qualified Data.HashMap.Strict as HashMap -import qualified Data.HashSet as HashSet -import Data.Hashable +import Data.Hashable +import qualified Data.HashMap.Strict as HashMap +import qualified Data.HashSet as HashSet -import qualified Data.Vector as Vector -import qualified Data.Vector.Storable as StorableVector -import qualified Data.Vector.Unboxed as UnboxedVector +import qualified Data.Vector as Vector +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Generic.Mutable as M +import qualified Data.Vector.Storable as StorableVector +import qualified Data.Vector.Unboxed as UnboxedVector +import qualified Data.Vector.Unboxed.Base as U -import Numeric.Log hiding (sum) +import Control.DeepSeq + +import Numeric.Log hiding (sum) import qualified Numeric.Log +import Numeric.Log.Signed -import Control.Monad -import Control.Applicative -import Data.Foldable -import Data.Traversable +import Control.Applicative +import Data.Foldable +import Data.Traversable +import Data.Semiring.Newtype +import GHC.Base (build) + + -- $setup -- >>> import Data.Function @@ -141,7 +156,7 @@ -- | An associative, commutative binary operation. infixl 6 <+> (<+>) :: a -> a -> a - -- | Takes the sum of the elements of a 'Foldable'. Analogous to 'sum' + -- | Takes the sum of the elements of a list. Analogous to 'sum' -- on numbers, or 'or' on 'Bool's. -- -- >>> add [1..5] @@ -156,7 +171,7 @@ :: [a] -> a add = getAdd . foldMap Add {-# INLINE add #-} - -- | Takes the product of the elements of a 'Foldable'. Analogous to + -- | Takes the product of the elements of a list. Analogous to -- 'product' on numbers, or 'and' on 'Bool's. -- -- >>> mul [1..5] @@ -369,34 +384,162 @@ -- where the /i/th element is the coefficient of /x^i/. This is the -- semiring for such a list. Adapted from -- . +-- +-- Effort is made to allow some of these functions to fuse. The reference +-- implementation is: +-- +-- @ +-- 'one' = ['one'] +-- 'zero' = [] +-- [] '<+>' ys = ys +-- xs '<+>' [] = xs +-- (x:xs) '<+>' (y:ys) = x '<+>' y : (xs '<+>' ys) +-- _ '<.>' [] = [] +-- xs '<.>' ys = 'foldr' f [] xs where +-- f x zs = 'map' (x '<.>') ys '<+>' ('zero' : zs) +-- @ 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) : add' xs ys + (<+>) = listAdd + xs <.> ys + | null ys = [] + | otherwise = foldr f [] xs where - add' xs' [] = map (<.> y) xs' - add' [] ys' = map (x <.>) ys' - add' xs' ys' = - map (x <.>) ys' <+> map (<.> y) xs' <+> (zero : (xs' <.> ys')) + f x zs = foldr (g x) id ys (zero : zs) + g x y a (z:zs) = x <.> y <+> z : a zs + g x y a [] = x <.> y : a [] + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + {-# INLINE one #-} + {-# INLINE zero #-} + {-# SPECIALISE (<.>) :: BinaryWrapped [] Int #-} + {-# SPECIALISE (<.>) :: BinaryWrapped [] Int8 #-} + {-# SPECIALISE (<.>) :: BinaryWrapped [] Int16 #-} + {-# SPECIALISE (<.>) :: BinaryWrapped [] Int32 #-} + {-# SPECIALISE (<.>) :: BinaryWrapped [] Int64 #-} + {-# SPECIALISE (<.>) :: BinaryWrapped [] Word #-} + {-# SPECIALISE (<.>) :: BinaryWrapped [] Word8 #-} + {-# SPECIALISE (<.>) :: BinaryWrapped [] Word16 #-} + {-# SPECIALISE (<.>) :: BinaryWrapped [] Word32 #-} + {-# SPECIALISE (<.>) :: BinaryWrapped [] Word64 #-} + {-# SPECIALISE (<.>) :: BinaryWrapped [] Integer #-} + {-# SPECIALISE (<.>) :: BinaryWrapped [] Double #-} + {-# SPECIALISE (<.>) :: BinaryWrapped [] Float #-} + {-# SPECIALISE (<.>) :: BinaryWrapped [] Natural #-} + {-# SPECIALISE (<.>) :: BinaryWrapped [] Bool #-} + {-# SPECIALISE (<+>) :: BinaryWrapped [] Int #-} + {-# SPECIALISE (<+>) :: BinaryWrapped [] Int8 #-} + {-# SPECIALISE (<+>) :: BinaryWrapped [] Int16 #-} + {-# SPECIALISE (<+>) :: BinaryWrapped [] Int32 #-} + {-# SPECIALISE (<+>) :: BinaryWrapped [] Int64 #-} + {-# SPECIALISE (<+>) :: BinaryWrapped [] Word #-} + {-# SPECIALISE (<+>) :: BinaryWrapped [] Word8 #-} + {-# SPECIALISE (<+>) :: BinaryWrapped [] Word16 #-} + {-# SPECIALISE (<+>) :: BinaryWrapped [] Word32 #-} + {-# SPECIALISE (<+>) :: BinaryWrapped [] Word64 #-} + {-# SPECIALISE (<+>) :: BinaryWrapped [] Integer #-} + {-# SPECIALISE (<+>) :: BinaryWrapped [] Double #-} + {-# SPECIALISE (<+>) :: BinaryWrapped [] Float #-} + {-# SPECIALISE (<+>) :: BinaryWrapped [] Natural #-} + {-# SPECIALISE (<+>) :: BinaryWrapped [] Bool #-} + +listAdd :: Semiring a => [a] -> [a] -> [a] +listAdd [] ys = ys +listAdd xs [] = xs +listAdd (x:xs) (y:ys) = (x <+> y) : listAdd xs ys +{-# NOINLINE [0] listAdd #-} +{-# SPECIALISE listAdd :: BinaryWrapped [] Int #-} +{-# SPECIALISE listAdd :: BinaryWrapped [] Int8 #-} +{-# SPECIALISE listAdd :: BinaryWrapped [] Int16 #-} +{-# SPECIALISE listAdd :: BinaryWrapped [] Int32 #-} +{-# SPECIALISE listAdd :: BinaryWrapped [] Int64 #-} +{-# SPECIALISE listAdd :: BinaryWrapped [] Word #-} +{-# SPECIALISE listAdd :: BinaryWrapped [] Word8 #-} +{-# SPECIALISE listAdd :: BinaryWrapped [] Word16 #-} +{-# SPECIALISE listAdd :: BinaryWrapped [] Word32 #-} +{-# SPECIALISE listAdd :: BinaryWrapped [] Word64 #-} +{-# SPECIALISE listAdd :: BinaryWrapped [] Integer #-} +{-# SPECIALISE listAdd :: BinaryWrapped [] Double #-} +{-# SPECIALISE listAdd :: BinaryWrapped [] Float #-} +{-# SPECIALISE listAdd :: BinaryWrapped [] Natural #-} +{-# SPECIALISE listAdd :: BinaryWrapped [] Bool #-} + +-- a definition of addition which can be fused on its left argument +listAddFBL :: Semiring a => ListBuilder a -> [a] -> [a] +listAddFBL xf = xf f id where + f x xs (y:ys) = x <+> y : xs ys + f x xs [] = x : xs [] + +type FBL a = ListBuilder a -> [a] -> [a] +{-# SPECIALISE listAddFBL :: FBL Int #-} +{-# SPECIALISE listAddFBL :: FBL Int8 #-} +{-# SPECIALISE listAddFBL :: FBL Int16 #-} +{-# SPECIALISE listAddFBL :: FBL Int32 #-} +{-# SPECIALISE listAddFBL :: FBL Int64 #-} +{-# SPECIALISE listAddFBL :: FBL Word #-} +{-# SPECIALISE listAddFBL :: FBL Word8 #-} +{-# SPECIALISE listAddFBL :: FBL Word16 #-} +{-# SPECIALISE listAddFBL :: FBL Word32 #-} +{-# SPECIALISE listAddFBL :: FBL Word64 #-} +{-# SPECIALISE listAddFBL :: FBL Integer #-} +{-# SPECIALISE listAddFBL :: FBL Double #-} +{-# SPECIALISE listAddFBL :: FBL Float #-} +{-# SPECIALISE listAddFBL :: FBL Natural #-} +{-# SPECIALISE listAddFBL :: FBL Bool #-} + +-- a definition of addition which can be fused on its right argument +listAddFBR :: Semiring a => [a] -> ListBuilder a -> [a] +listAddFBR xs' yf = yf f id xs' where + f y ys (x:xs) = x <+> y : ys xs + f y ys [] = y : ys [] + +type FBR a = [a] -> ListBuilder a -> [a] +{-# SPECIALISE listAddFBR :: FBR Int #-} +{-# SPECIALISE listAddFBR :: FBR Int8 #-} +{-# SPECIALISE listAddFBR :: FBR Int16 #-} +{-# SPECIALISE listAddFBR :: FBR Int32 #-} +{-# SPECIALISE listAddFBR :: FBR Int64 #-} +{-# SPECIALISE listAddFBR :: FBR Word #-} +{-# SPECIALISE listAddFBR :: FBR Word8 #-} +{-# SPECIALISE listAddFBR :: FBR Word16 #-} +{-# SPECIALISE listAddFBR :: FBR Word32 #-} +{-# SPECIALISE listAddFBR :: FBR Word64 #-} +{-# SPECIALISE listAddFBR :: FBR Integer #-} +{-# SPECIALISE listAddFBR :: FBR Double #-} +{-# SPECIALISE listAddFBR :: FBR Float #-} +{-# SPECIALISE listAddFBR :: FBR Natural #-} +{-# SPECIALISE listAddFBR :: FBR Bool #-} + +type ListBuilder a = forall b. (a -> b -> b) -> b -> b + +{-# RULES +"listAddFB/left" forall (g :: ListBuilder a). listAdd (build g) = listAddFBL g +"listAddFB/right" forall xs (g :: ListBuilder a). listAdd xs (build g) = listAddFBR xs g + #-} + instance StarSemiring a => StarSemiring [a] where star [] = one star (x:xs) = r where - r = [star x] <.> (one : (xs <.> r)) + r = xst : map (xst <.>) (xs <.> r) + xst = star x + {-# SPECIALISE star :: [Bool] -> [Bool] #-} + {-# SPECIALISE star :: [Min Double] -> [Min Double] #-} + {-# SPECIALISE star :: [Min Float] -> [Min Float] #-} + {-# SPECIALISE star :: [Min CDouble] -> [Min CDouble] #-} + {-# SPECIALISE star :: [Min CFloat] -> [Min CFloat] #-} + {-# SPECIALISE star :: [Max Double] -> [Max Double] #-} + {-# SPECIALISE star :: [Max Float] -> [Max Float] #-} + {-# SPECIALISE star :: [Max CDouble] -> [Max CDouble] #-} + {-# SPECIALISE star :: [Max CFloat] -> [Max CFloat] #-} instance DetectableZero a => DetectableZero [a] where isZero = all isZero {-# INLINE isZero #-} -type BinaryContainer c a = c a -> c a -> c a - instance Semiring a => Semiring (Vector.Vector a) where one = Vector.singleton one @@ -420,36 +563,36 @@ zero [kmin .. kmax] where - kmin = max 0 (n - (klen - 1)) - kmax = min n (slen - 1) - slen = Vector.length signal - klen = Vector.length kernel - {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Double #-} - {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Float #-} - {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Int #-} - {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Bool #-} - {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Word #-} - {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Int8 #-} - {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Int16 #-} - {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Int32 #-} - {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Int64 #-} - {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Word8 #-} - {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Word16 #-} - {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Word32 #-} - {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Word64 #-} - {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Double #-} - {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Float #-} - {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Int #-} - {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Bool #-} - {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Word #-} - {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Int8 #-} - {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Int16 #-} - {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Int32 #-} - {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Int64 #-} - {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Word8 #-} - {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Word16 #-} - {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Word32 #-} - {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Word64 #-} + !kmin = max 0 (n - (klen - 1)) + !kmax = min n (slen - 1) + !slen = Vector.length signal + !klen = Vector.length kernel + {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Double #-} + {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Float #-} + {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Int #-} + {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Bool #-} + {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Word #-} + {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Int8 #-} + {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Int16 #-} + {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Int32 #-} + {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Int64 #-} + {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Word8 #-} + {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Word16 #-} + {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Word32 #-} + {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Word64 #-} + {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Double #-} + {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Float #-} + {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Int #-} + {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Bool #-} + {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Word #-} + {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Int8 #-} + {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Int16 #-} + {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Int32 #-} + {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Int64 #-} + {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Word8 #-} + {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Word16 #-} + {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Word32 #-} + {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Word64 #-} instance DetectableZero a => DetectableZero (Vector.Vector a) where isZero = Vector.all isZero @@ -481,32 +624,32 @@ kmax = min n (slen - 1) slen = UnboxedVector.length signal klen = UnboxedVector.length kernel - {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Double #-} - {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Float #-} - {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Int #-} - {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Bool #-} - {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Word #-} - {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Int8 #-} - {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Int16 #-} - {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Int32 #-} - {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Int64 #-} - {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Word8 #-} - {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Word16 #-} - {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Word32 #-} - {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Word64 #-} - {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Double #-} - {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Float #-} - {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Int #-} - {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Bool #-} - {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Word #-} - {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Int8 #-} - {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Int16 #-} - {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Int32 #-} - {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Int64 #-} - {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Word8 #-} - {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Word16 #-} - {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Word32 #-} - {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Word64 #-} + {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Double #-} + {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Float #-} + {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Int #-} + {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Bool #-} + {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Word #-} + {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Int8 #-} + {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Int16 #-} + {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Int32 #-} + {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Int64 #-} + {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Word8 #-} + {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Word16 #-} + {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Word32 #-} + {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Word64 #-} + {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Double #-} + {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Float #-} + {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Int #-} + {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Bool #-} + {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Word #-} + {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Int8 #-} + {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Int16 #-} + {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Int32 #-} + {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Int64 #-} + {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Word8 #-} + {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Word16 #-} + {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Word32 #-} + {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Word64 #-} instance (UnboxedVector.Unbox a, DetectableZero a) => DetectableZero (UnboxedVector.Vector a) where isZero = UnboxedVector.all isZero @@ -541,34 +684,35 @@ kmax = min n (slen - 1) slen = StorableVector.length signal klen = StorableVector.length kernel - {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Double #-} - {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Float #-} - {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Int #-} - {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Bool #-} - {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Word #-} - {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Int8 #-} - {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Int16 #-} - {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Int32 #-} - {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Int64 #-} - {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Word8 #-} - {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Word16 #-} - {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Word32 #-} - {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Word64 #-} - {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Double #-} - {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Float #-} - {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Int #-} - {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Bool #-} - {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Word #-} - {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Int8 #-} - {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Int16 #-} - {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Int32 #-} - {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Int64 #-} - {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Word8 #-} - {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Word16 #-} - {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Word32 #-} - {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Word64 #-} + {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Double #-} + {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Float #-} + {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Int #-} + {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Bool #-} + {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Word #-} + {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Int8 #-} + {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Int16 #-} + {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Int32 #-} + {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Int64 #-} + {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Word8 #-} + {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Word16 #-} + {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Word32 #-} + {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Word64 #-} + {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Double #-} + {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Float #-} + {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Int #-} + {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Bool #-} + {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Word #-} + {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Int8 #-} + {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Int16 #-} + {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Int32 #-} + {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Int64 #-} + {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Word8 #-} + {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Word16 #-} + {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Word32 #-} + {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Word64 #-} -instance (StorableVector.Storable a, DetectableZero a) => DetectableZero (StorableVector.Vector a) where +instance (StorableVector.Storable a, DetectableZero a) => + DetectableZero (StorableVector.Vector a) where isZero = StorableVector.all isZero instance (Monoid a, Ord a) => @@ -645,50 +789,36 @@ add = Numeric.Log.sum {-# INLINE add #-} + {-# SPECIALISE (<.>) :: BinaryWrapped Log Double #-} + {-# SPECIALISE (<.>) :: BinaryWrapped Log Float #-} + {-# SPECIALISE (<+>) :: BinaryWrapped Log Double #-} + {-# SPECIALISE (<+>) :: BinaryWrapped Log Float #-} + instance (Precise a, RealFloat a) => DetectableZero (Log a) where isZero = isZeroEq {-# INLINE isZero #-} --------------------------------------------------------------------------------- --- Newtype utilities --------------------------------------------------------------------------------- - -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 '}' +instance (Precise a, RealFloat a) => Semiring (SignedLog a) where + (<.>) = (*) + {-# INLINE (<.>) #-} + (<+>) = (+) + {-# INLINE (<+>) #-} + one = SLExp True 0 + {-# INLINE one #-} + zero = SLExp False (-(1/0)) + {-# INLINE zero #-} -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) + {-# SPECIALISE (<.>) :: BinaryWrapped SignedLog Double #-} + {-# SPECIALISE (<.>) :: BinaryWrapped SignedLog Float #-} + {-# SPECIALISE (<+>) :: BinaryWrapped SignedLog Double #-} + {-# SPECIALISE (<+>) :: BinaryWrapped SignedLog Float #-} +instance (Precise a, RealFloat a) => DetectableZero (SignedLog 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'. @@ -812,7 +942,7 @@ instance (Traversable f, Applicative f, Semiring a, f ~ g) => Semiring (Matrix f g a) where - (<.>) = mulMatrix + (<.>) = (coerce :: Binary (f (g a)) -> Binary (Matrix f g a)) mulMatrix (<+>) = liftA2 (<+>) zero = pure zero one = @@ -833,18 +963,23 @@ -- | Multiply two matrices. mulMatrix - :: (Applicative f, Traversable g, Applicative g, Semiring a) - => Matrix f g a -> Matrix g f a -> Matrix f f a -mulMatrix (Matrix xs) (Matrix ys) = - Matrix - (fmap (\row -> fmap (addFoldable . liftA2 (<.>) row) c) xs) + :: (Applicative n, Traversable m, Applicative m, Applicative p, Semiring a) + => n (m a) -> m (p a) -> n (p a) +mulMatrix xs ys = fmap (\row -> fmap (addFoldable . liftA2 (<.>) row) cs) xs where - c = sequenceA ys + cs = sequenceA ys -infixr 9 #. -(#.) :: Coercible b c => (b -> c) -> (a -> b) -> a -> c -(#.) _ = coerce +-- | Convert the matrix to a nested list, in row-major form. +rows :: (Foldable f, Foldable g) => Matrix f g a -> [[a]] +rows = foldr ((:) . toList) [] . getMatrix + +-- | Convert the matrix to a nested list, in column-major form. +cols :: (Foldable f, Foldable g) => Matrix f g a -> [[a]] +cols = foldr (foldr f (const [])) (repeat []) . getMatrix where + f e a (x:xs) = (e:x) : a xs + f _ _ [] = [] + instance (Show1 f, Show1 g) => Show1 (Matrix f g) where liftShowsPrec (sp :: Int -> a -> ShowS) sl = @@ -915,7 +1050,8 @@ newtype Min a = Min { getMin :: a } deriving (Eq,Ord,Read,Show,Bounded,Generic,Generic1,Num,Enum,Typeable - ,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable) + ,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable + ,NFData) -- | The "" -- or max-plus semiring. It is a semiring where: @@ -935,64 +1071,91 @@ newtype Max a = Max { getMax :: a } deriving (Eq,Ord,Read,Show,Bounded,Generic,Generic1,Num,Enum,Typeable - ,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable) + ,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable + ,NFData) instance Eq1 Max where liftEq = coerce + {-# INLINE liftEq #-} instance Ord1 Max where liftCompare = coerce + {-# INLINE liftCompare #-} instance Show1 Max where liftShowsPrec = showsNewtype "Max" "getMax" + {-# INLINE liftShowsPrec #-} instance Read1 Max where liftReadsPrec = readsNewtype "Max" "getMax" + {-# INLINE liftReadsPrec #-} instance Eq1 Min where liftEq = coerce + {-# INLINE liftEq #-} instance Ord1 Min where liftCompare = coerce + {-# INLINE liftCompare #-} instance Show1 Min where liftShowsPrec = showsNewtype "Min" "getMin" + {-# INLINE liftShowsPrec #-} instance Read1 Min where liftReadsPrec = readsNewtype "Min" "getMin" + {-# INLINE liftReadsPrec #-} instance Ord a => Semigroup (Max a) where (<>) = (coerce :: WrapBinary Max a) max {-# INLINE (<>) #-} + stimes = stimesIdempotent + {-# SPECIALISE (<>) :: BinaryWrapped Max Double #-} + {-# SPECIALISE (<>) :: BinaryWrapped Max Float #-} + {-# SPECIALISE (<>) :: BinaryWrapped Max CDouble #-} + {-# SPECIALISE (<>) :: BinaryWrapped Max CFloat #-} instance Ord a => Semigroup (Min a) where (<>) = (coerce :: WrapBinary Min a) min {-# INLINE (<>) #-} + stimes = stimesIdempotent + {-# SPECIALISE (<>) :: BinaryWrapped Min Double #-} + {-# SPECIALISE (<>) :: BinaryWrapped Min Float #-} + {-# SPECIALISE (<>) :: BinaryWrapped Min CDouble #-} + {-# SPECIALISE (<>) :: BinaryWrapped Min CFloat #-} -- | >>> (getMax . foldMap Max) [1..10] -- 10.0 instance (Ord a, HasNegativeInfinity a) => Monoid (Max a) where mempty = Max negativeInfinity - mappend = (<>) + mappend = (coerce :: WrapBinary Max a) max {-# INLINE mempty #-} {-# INLINE mappend #-} + {-# SPECIALISE mappend :: BinaryWrapped Max Double #-} + {-# SPECIALISE mappend :: BinaryWrapped Max Float #-} + {-# SPECIALISE mappend :: BinaryWrapped Max CDouble #-} + {-# SPECIALISE mappend :: BinaryWrapped Max CFloat #-} -- | >>> (getMin . foldMap Min) [1..10] -- 1.0 instance (Ord a, HasPositiveInfinity a) => Monoid (Min a) where mempty = Min positiveInfinity - mappend = (<>) + mappend = (coerce :: WrapBinary Min a) min {-# INLINE mempty #-} {-# INLINE mappend #-} + {-# SPECIALISE mappend :: BinaryWrapped Min Double #-} + {-# SPECIALISE mappend :: BinaryWrapped Min Float #-} + {-# SPECIALISE mappend :: BinaryWrapped Min CDouble #-} + {-# SPECIALISE mappend :: BinaryWrapped Min CFloat #-} instance (Semiring a, Ord a, HasNegativeInfinity a) => Semiring (Max a) where - (<+>) = mappend - zero = mempty + (<+>) = (coerce :: WrapBinary Max a) max + zero = Max negativeInfinity (<.>) = (coerce :: WrapBinary Max a) (<+>) one = Max zero {-# INLINE zero #-} @@ -1000,28 +1163,69 @@ {-# INLINE (<+>) #-} {-# INLINE (<.>) #-} + {-# SPECIALISE (<+>) :: BinaryWrapped Max Double #-} + {-# SPECIALISE (<+>) :: BinaryWrapped Max Float #-} + {-# SPECIALISE (<+>) :: BinaryWrapped Max CDouble #-} + {-# SPECIALISE (<+>) :: BinaryWrapped Max CFloat #-} + {-# SPECIALISE (<.>) :: BinaryWrapped Max Double #-} + {-# SPECIALISE (<.>) :: BinaryWrapped Max Float #-} + {-# SPECIALISE (<.>) :: BinaryWrapped Max CDouble #-} + {-# SPECIALISE (<.>) :: BinaryWrapped Max CFloat #-} + {-# SPECIALISE one :: Max Double #-} + {-# SPECIALISE one :: Max Float #-} + {-# SPECIALISE one :: Max CDouble #-} + {-# SPECIALISE one :: Max CFloat #-} + {-# SPECIALISE zero :: Max Double #-} + {-# SPECIALISE zero :: Max Float #-} + {-# SPECIALISE zero :: Max CDouble #-} + {-# SPECIALISE zero :: Max CFloat #-} + instance (Semiring a, Ord a, HasPositiveInfinity a) => Semiring (Min a) where - (<+>) = mappend - zero = mempty + (<+>) = (coerce :: WrapBinary Min a) min + zero = Min positiveInfinity (<.>) = (coerce :: WrapBinary Min a) (<+>) one = Min zero {-# INLINE zero #-} {-# INLINE one #-} {-# INLINE (<+>) #-} {-# INLINE (<.>) #-} + {-# SPECIALISE (<+>) :: BinaryWrapped Min Double #-} + {-# SPECIALISE (<+>) :: BinaryWrapped Min Float #-} + {-# SPECIALISE (<+>) :: BinaryWrapped Min CDouble #-} + {-# SPECIALISE (<+>) :: BinaryWrapped Min CFloat #-} + {-# SPECIALISE (<.>) :: BinaryWrapped Min Double #-} + {-# SPECIALISE (<.>) :: BinaryWrapped Min Float #-} + {-# SPECIALISE (<.>) :: BinaryWrapped Min CDouble #-} + {-# SPECIALISE (<.>) :: BinaryWrapped Min CFloat #-} + {-# SPECIALISE one :: Min Double #-} + {-# SPECIALISE one :: Min Float #-} + {-# SPECIALISE one :: Min CDouble #-} + {-# SPECIALISE one :: Min CFloat #-} + {-# SPECIALISE zero :: Min Double #-} + {-# SPECIALISE zero :: Min Float #-} + {-# SPECIALISE zero :: Min CDouble #-} + {-# SPECIALISE zero :: Min CFloat #-} instance (Semiring a, Ord a, HasPositiveInfinity a, HasNegativeInfinity a) => StarSemiring (Max a) where star (Max x) | x > zero = Max positiveInfinity | otherwise = Max zero + {-# SPECIALISE star :: Max Double -> Max Double #-} + {-# SPECIALISE star :: Max Float -> Max Float #-} + {-# SPECIALISE star :: Max CDouble -> Max CDouble #-} + {-# SPECIALISE star :: Max CFloat -> Max CFloat #-} instance (Semiring a, Ord a, HasPositiveInfinity a, HasNegativeInfinity a) => StarSemiring (Min a) where star (Min x) | x < zero = Min negativeInfinity | otherwise = Min zero + {-# SPECIALISE star :: Min Double -> Min Double #-} + {-# SPECIALISE star :: Min Float -> Min Float #-} + {-# SPECIALISE star :: Min CDouble -> Min CDouble #-} + {-# SPECIALISE star :: Min CFloat -> Min CFloat #-} instance (Semiring a, Ord a, HasPositiveInfinity a) => DetectableZero (Min a) where @@ -1033,6 +1237,119 @@ isZero (Max x) = isNegativeInfinity x {-# INLINE isZero #-} +newtype instance U.Vector (Min a) = V_Min (U.Vector a) +newtype instance U.MVector s (Min a) = MV_Min (U.MVector s a) + +instance U.Unbox a => + M.MVector U.MVector (Min a) where + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicOverlaps #-} + {-# INLINE basicUnsafeNew #-} + {-# INLINE basicUnsafeRead #-} + {-# INLINE basicUnsafeWrite #-} + basicLength = + (coerce :: (U.MVector s a -> Int) -> U.MVector s (Min a) -> Int) + M.basicLength + basicUnsafeSlice = + (coerce :: (Int -> Int -> U.MVector s a -> U.MVector s a) -> Int -> Int -> U.MVector s (Min a) -> U.MVector s (Min a)) + M.basicUnsafeSlice + basicOverlaps = + (coerce :: (U.MVector s a -> U.MVector s a -> Bool) -> U.MVector s (Min a) -> U.MVector s (Min a) -> Bool) + M.basicOverlaps + basicUnsafeNew n = + fmap + (coerce :: U.MVector s a -> U.MVector s (Min a)) + (M.basicUnsafeNew n) + basicUnsafeRead (MV_Min xs) i = + fmap (coerce :: a -> Min a) (M.basicUnsafeRead xs i) + basicUnsafeWrite = + (coerce :: (U.MVector s a -> Int -> a -> m ()) -> U.MVector s (Min a) -> Int -> Min a -> m ()) + M.basicUnsafeWrite + basicInitialize = + (coerce :: (U.MVector s a -> m ()) -> U.MVector s (Min a) -> m ()) + M.basicInitialize + +instance U.Unbox a => + G.Vector U.Vector (Min a) where + {-# INLINE basicUnsafeFreeze #-} + {-# INLINE basicUnsafeThaw #-} + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeFreeze (MV_Min xs) = + fmap + (coerce :: U.Vector a -> U.Vector (Min a)) + (G.basicUnsafeFreeze xs) + basicUnsafeThaw (V_Min xs) = + fmap + (coerce :: U.MVector s a -> U.MVector s (Min a)) + (G.basicUnsafeThaw xs) + basicLength = + (coerce :: (U.Vector a -> Int) -> U.Vector (Min a) -> Int) + G.basicLength + basicUnsafeSlice = + (coerce :: (Int -> Int -> U.Vector a -> U.Vector a) -> Int -> Int -> U.Vector (Min a) -> U.Vector (Min a)) + G.basicUnsafeSlice + basicUnsafeIndexM (V_Min xs) i = + fmap (coerce :: a -> Min a) (G.basicUnsafeIndexM xs i) + +newtype instance U.Vector (Max a) = V_Max (U.Vector a) +newtype instance U.MVector s (Max a) = MV_Max (U.MVector s a) + +instance U.Unbox a => + M.MVector U.MVector (Max a) where + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicOverlaps #-} + {-# INLINE basicUnsafeNew #-} + {-# INLINE basicUnsafeRead #-} + {-# INLINE basicUnsafeWrite #-} + basicLength = + (coerce :: (U.MVector s a -> Int) -> U.MVector s (Max a) -> Int) + M.basicLength + basicUnsafeSlice = + (coerce :: (Int -> Int -> U.MVector s a -> U.MVector s a) -> Int -> Int -> U.MVector s (Max a) -> U.MVector s (Max a)) + M.basicUnsafeSlice + basicOverlaps = + (coerce :: (U.MVector s a -> U.MVector s a -> Bool) -> U.MVector s (Max a) -> U.MVector s (Max a) -> Bool) + M.basicOverlaps + basicUnsafeNew n = + fmap + (coerce :: U.MVector s a -> U.MVector s (Max a)) + (M.basicUnsafeNew n) + basicUnsafeRead (MV_Max xs) i = + fmap (coerce :: a -> Max a) (M.basicUnsafeRead xs i) + basicUnsafeWrite = + (coerce :: (U.MVector s a -> Int -> a -> m ()) -> U.MVector s (Max a) -> Int -> Max a -> m ()) + M.basicUnsafeWrite + basicInitialize = + (coerce :: (U.MVector s a -> m ()) -> U.MVector s (Max a) -> m ()) + M.basicInitialize + +instance U.Unbox a => + G.Vector U.Vector (Max a) where + {-# INLINE basicUnsafeFreeze #-} + {-# INLINE basicUnsafeThaw #-} + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeFreeze (MV_Max xs) = + fmap + (coerce :: U.Vector a -> U.Vector (Max a)) + (G.basicUnsafeFreeze xs) + basicUnsafeThaw (V_Max xs) = + fmap + (coerce :: U.MVector s a -> U.MVector s (Max a)) + (G.basicUnsafeThaw xs) + basicLength = + (coerce :: (U.Vector a -> Int) -> U.Vector (Max a) -> Int) + G.basicLength + basicUnsafeSlice = + (coerce :: (Int -> Int -> U.Vector a -> U.Vector a) -> Int -> Int -> U.Vector (Max a) -> U.Vector (Max a)) + G.basicUnsafeSlice + basicUnsafeIndexM (V_Max xs) i = + fmap (coerce :: a -> Max a) (G.basicUnsafeIndexM xs i) -------------------------------------------------------------------------------- -- (->) instance -------------------------------------------------------------------------------- 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 @@ -8,7 +8,6 @@ ,runFree) where -import Data.Coerce import Data.Semiring import Data.Map.Strict (Map) @@ -16,6 +15,8 @@ import Numeric.Natural +import Data.Semiring.Newtype + -- | The free semiring newtype Free a = Free { getFree :: Map [a] Natural @@ -37,7 +38,7 @@ -- | Run a 'Free'. runFree :: Semiring s => (a -> s) -> Free a -> s -runFree f = getAdd .# Map.foldMapWithKey ((rep #. Add) . mul . map f) . getFree +runFree f = getAdd #. Map.foldMapWithKey ((rep .# Add) . mul . map f) . getFree {-# INLINE runFree #-} -- | Run a 'Free', interpreting it in the underlying semiring. @@ -45,19 +46,10 @@ lowerFree = runFree id {-# INLINE lowerFree #-} +-- | Create a 'Free' with one item. 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 -(.#) _ = coerce -{-# INLINE (.#) #-} instance Foldable Free where foldMap f (Free xs) = Map.foldMapWithKey (rep . foldMap f) xs diff --git a/src/Data/Semiring/Infinite.hs b/src/Data/Semiring/Infinite.hs --- a/src/Data/Semiring/Infinite.hs +++ b/src/Data/Semiring/Infinite.hs @@ -27,8 +27,15 @@ import Data.Coerce import Data.Monoid -import Data.Semiring +import Data.Semiring +import Data.Semiring.Newtype + +import Control.DeepSeq + +import Data.Functor.Classes +import Text.Read + -- | Adds negative infinity to a type. Useful for expressing detectable infinity -- in types like 'Integer', etc. data NegativeInfinite a @@ -91,8 +98,9 @@ (<+>) = (coerce :: CoerceBinary (PositiveInfinite (Add a)) (PositiveInfinite a)) mappend - x <.> y | any isZero x || any isZero y = zero - | otherwise = liftA2 (<.>) x y + x <.> y + | any isZero x || any isZero y = zero + | otherwise = liftA2 (<.>) x y {-# INLINE zero #-} {-# INLINE one #-} {-# INLINE (<+>) #-} @@ -180,25 +188,25 @@ {-# INLINE negativeInfinity #-} negativeInfinity = NegativeInfinity isNegativeInfinity NegativeInfinity = True - isNegativeInfinity _ = False + isNegativeInfinity _ = False instance HasPositiveInfinity (PositiveInfinite a) where {-# INLINE positiveInfinity #-} positiveInfinity = PositiveInfinity isPositiveInfinity PositiveInfinity = True - isPositiveInfinity _ = False + isPositiveInfinity _ = False instance HasNegativeInfinity (Infinite a) where {-# INLINE negativeInfinity #-} negativeInfinity = Negative isNegativeInfinity Negative = True - isNegativeInfinity _ = False + isNegativeInfinity _ = False instance HasPositiveInfinity (Infinite a) where {-# INLINE positiveInfinity #-} positiveInfinity = Positive isPositiveInfinity Positive = True - isPositiveInfinity _ = False + isPositiveInfinity _ = False instance (Enum a, Bounded a, Eq a) => Enum (NegativeInfinite a) where succ = foldr (const . pure . succ) (pure minBound) @@ -285,8 +293,6 @@ signum = foldr (const . pure . signum) (-1) (-) = liftA2 (-) -type CoerceBinary a b = (a -> a -> a) -> (b -> b -> b) - instance Num a => Num (Infinite a) where fromInteger = Finite . fromInteger (+) = (coerce :: CoerceBinary (Infinite (Sum a)) (Infinite a)) mappend @@ -298,7 +304,7 @@ negate Negative = Positive negate (Finite x) = Finite (negate x) abs Negative = Positive - abs x = fmap abs x + abs x = fmap abs x -- Adapted from https://www.schoolofhaskell.com/user/snoyberg/random-code-snippets/storable-instance-of-maybe instance Storable a => Storable (NegativeInfinite a) where @@ -329,13 +335,13 @@ sizeOf x = sizeOf (strip x) + 1 alignment x = alignment (strip x) peek ptr = (peekByteOff ptr . sizeOf . strip . stripPtr) ptr >>= \case - (0 :: Word8) -> Finite <$> peek (stripFPtr ptr) - 1 -> pure Negative + 0 -> pure Negative + (1 :: Word8) -> Finite <$> peek (stripFPtr ptr) _ -> pure Positive poke ptr Positive = pokeByteOff ptr ((sizeOf . strip . stripPtr) ptr) (2 :: Word8) poke ptr Negative - = pokeByteOff ptr ((sizeOf . strip . stripPtr) ptr) (1 :: Word8) + = pokeByteOff ptr ((sizeOf . strip . stripPtr) ptr) (0 :: Word8) poke ptr (Finite a) = poke (stripFPtr ptr) a *> pokeByteOff ptr (sizeOf a) (1 :: Word8) @@ -348,3 +354,130 @@ stripPtr :: Ptr a -> a stripPtr _ = error "stripPtr" + +instance NFData a => + NFData (NegativeInfinite a) where + rnf NegativeInfinity = () + rnf (NegFinite x) = rnf x + +instance NFData a => + NFData (PositiveInfinite a) where + rnf PositiveInfinity = () + rnf (PosFinite x) = rnf x + +instance NFData a => + NFData (Infinite a) where + rnf Negative = () + rnf Positive = () + rnf (Finite x) = rnf x + +instance Eq1 NegativeInfinite where + liftEq eq = go + where + go NegativeInfinity NegativeInfinity = True + go (NegFinite x) (NegFinite y) = eq x y + go _ _ = False + +instance Eq1 PositiveInfinite where + liftEq eq = go + where + go PositiveInfinity PositiveInfinity = True + go (PosFinite x) (PosFinite y) = eq x y + go _ _ = False + +instance Eq1 Infinite where + liftEq eq = go + where + go Positive Positive = True + go Negative Negative = False + go (Finite x) (Finite y) = eq x y + go _ _ = False + +instance Ord1 NegativeInfinite where + liftCompare cmp = go + where + go NegativeInfinity NegativeInfinity = EQ + go (NegFinite x) (NegFinite y) = cmp x y + go NegativeInfinity (NegFinite _) = LT + go (NegFinite _) NegativeInfinity = GT + +instance Ord1 PositiveInfinite where + liftCompare cmp = go + where + go PositiveInfinity PositiveInfinity = EQ + go (PosFinite x) (PosFinite y) = cmp x y + go PositiveInfinity (PosFinite _) = GT + go (PosFinite _) PositiveInfinity = LT + +instance Ord1 Infinite where + liftCompare cmp = go + where + go Positive Positive = EQ + go Positive Negative = GT + go Negative Positive = LT + go Negative Negative = EQ + go Positive (Finite _) = GT + go Negative (Finite _) = LT + go (Finite _) Positive = LT + go (Finite _) Negative = GT + go (Finite x) (Finite y) = cmp x y + +instance Show1 PositiveInfinite where + liftShowsPrec sp _ n = go + where + go PositiveInfinity = showString "PositiveInfinity" + go (PosFinite x) = + showParen (n > 10) $ showString "PosFinite " . sp 11 x + +instance Show1 NegativeInfinite where + liftShowsPrec sp _ n = go + where + go NegativeInfinity = showString "NegativeInfinity" + go (NegFinite x) = + showParen (n > 10) $ showString "NegFinite " . sp 11 x + +instance Show1 Infinite where + liftShowsPrec sp _ n = go + where + go Positive = showString "Positive" + go Negative = showString "Negative" + go (Finite x) = + showParen (n > 10) $ showString "Finite " . sp 11 x + +instance Read1 PositiveInfinite where + liftReadsPrec rp _ = + readPrec_to_S $ + parens $ + (do Ident "PositiveInfinity" <- lexP + pure PositiveInfinity) +++ + prec + 10 + (do Ident "PosFinite" <- lexP + m <- step (readS_to_Prec rp) + pure (PosFinite m)) + +instance Read1 NegativeInfinite where + liftReadsPrec rp _ = + readPrec_to_S $ + parens $ + (do Ident "NegativeInfinity" <- lexP + pure NegativeInfinity) +++ + prec + 10 + (do Ident "NegFinite" <- lexP + m <- step (readS_to_Prec rp) + pure (NegFinite m)) + +instance Read1 Infinite where + liftReadsPrec rp _ = + readPrec_to_S $ + parens $ + (do Ident "Negative" <- lexP + pure Negative) +++ + (do Ident "Positive" <- lexP + pure Positive) +++ + prec + 10 + (do Ident "Finite" <- lexP + m <- step (readS_to_Prec rp) + pure (Finite m)) diff --git a/src/Data/Semiring/Newtype.hs b/src/Data/Semiring/Newtype.hs new file mode 100644 --- /dev/null +++ b/src/Data/Semiring/Newtype.hs @@ -0,0 +1,97 @@ +-- | Various utilities for working with newtype wrappers. + +module Data.Semiring.Newtype where + +import Data.Coerce +import Text.Read +import Control.Monad + +-------------------------------------------------------------------------------- +-- Show1, Read1 +-------------------------------------------------------------------------------- + +-- | A definition for 'Data.Functor.Classes.liftShowsPrec' suitable for +-- newtypes. +-- Given a newtype declared as: +-- +-- @ +-- newtype T a = T { unT :: a } +-- @ +-- +-- The 'Data.Functor.Classes.Show1' definition can be given as: +-- +-- @ +-- instance Show1 T where +-- liftShowsPrec = showsNewtype "T" "unT" +-- @ +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 '}' +{-# INLINE showsNewtype #-} + +-- | A definition for 'Data.Functor.Classes.liftReadsPrec' suitable for +-- newtypes. +-- Given a newtype declared as: +-- +-- @ +-- newtype T a = T { unT :: a } +-- @ +-- +-- The 'Data.Functor.Classes.Read1' definition can be given as: +-- +-- @ +-- instance Read1 T where +-- liftReadsPrec = readsNewtype "T" "unT" +-- @ +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) +{-# INLINE readsNewtype #-} + + +-------------------------------------------------------------------------------- +-- Typealiases to make coercion signatures shorter +-------------------------------------------------------------------------------- + +type Binary a = a -> a -> a +type CoerceBinary a b = Binary a -> Binary b +type WrapBinary f a = Binary a -> BinaryWrapped f a +type BinaryWrapped f a = Binary (f a) + +-------------------------------------------------------------------------------- +-- Coercive composition +-------------------------------------------------------------------------------- + +infixr 9 #. +(#.) :: Coercible b c => (b -> c) -> (a -> b) -> a -> c +(#.) _ = coerce +{-# INLINE (#.) #-} + +infixr 9 .# +(.#) :: Coercible a b => (b -> c) -> (a -> b) -> a -> c +(.#) f _ = coerce f +{-# INLINE (.#) #-} 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 @@ -4,6 +4,8 @@ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-| Module: Data.Semiring.Numeric @@ -22,8 +24,6 @@ ) where import Data.Coerce -import Text.Read -import Control.Monad import Data.Semiring @@ -32,9 +32,13 @@ import Foreign.Storable (Storable) import Data.Functor.Classes +import Data.Semiring.Newtype +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Generic.Mutable as M +import qualified Data.Vector.Unboxed.Base as U -type WrapBinary f a = (a -> a -> a) -> f a -> f a -> f a +import Control.DeepSeq -- | Useful for some constraint problems. -- @@ -43,10 +47,10 @@ --'zero' = 'minBound' --'one' = 'maxBound'@ newtype Bottleneck a = Bottleneck - { getBottleneck :: a - } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num - ,Enum, Typeable, Storable, Fractional, Real, RealFrac - ,Functor, Foldable, Traversable) + { getBottleneck :: a + } deriving (Eq,Ord,Read,Show,Bounded,Generic,Generic1,Num,Enum,Typeable + ,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable + ,NFData) instance (Bounded a, Ord a) => Semiring (Bottleneck a) where (<+>) = (coerce :: WrapBinary Bottleneck a) max @@ -80,10 +84,10 @@ --'zero' = 'zero' --'one' = 'one'@ newtype Division a = Division - { getDivision :: a - } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num - ,Enum, Typeable, Storable, Fractional, Real, RealFrac - ,Functor, Foldable, Traversable,DetectableZero) + { getDivision :: a + } deriving (Eq,Ord,Read,Show,Bounded,Generic,Generic1,Num,Enum,Typeable + ,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable + ,DetectableZero,NFData) -- | Only expects positive numbers instance (Integral a, Semiring a) => Semiring (Division a) where @@ -118,10 +122,10 @@ --'zero' = 'zero' --'one' = 'one'@ newtype Łukasiewicz a = Łukasiewicz - { getŁukasiewicz :: a - } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num - ,Enum, Typeable, Storable, Fractional, Real, RealFrac - ,Functor, Foldable, Traversable) + { getŁukasiewicz :: a + } deriving (Eq,Ord,Read,Show,Bounded,Generic,Generic1,Num,Enum,Typeable + ,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable + ,NFData) instance (Ord a, Num a) => Semiring (Łukasiewicz a) where (<+>) = (coerce :: WrapBinary Łukasiewicz a) max @@ -158,10 +162,10 @@ --'zero' = 'zero' --'one' = 'one'@ newtype Viterbi a = Viterbi - { getViterbi :: a - } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num - ,Enum, Typeable, Storable, Fractional, Real, RealFrac - ,Functor, Foldable, Traversable,DetectableZero) + { getViterbi :: a + } deriving (Eq,Ord,Read,Show,Bounded,Generic,Generic1,Num,Enum,Typeable + ,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable + ,DetectableZero,NFData) instance (Ord a, Semiring a) => Semiring (Viterbi a) where (<+>) = (coerce :: WrapBinary Viterbi a) max @@ -193,10 +197,10 @@ --'one' = 'one' --'star' x = if x < 1 then 1 / (1 - x) else 'positiveInfinity'@ newtype PosFrac a = PosFrac - { getPosFrac :: a - } deriving (Eq, Ord, Read, Show, Generic, Generic1, Num - ,Enum, Typeable, Storable, Fractional, Real, RealFrac - ,Functor, Foldable, Traversable) + { getPosFrac :: a + } deriving (Eq,Ord,Read,Show,Generic,Generic1,Num,Enum,Typeable,Storable + ,Fractional,Real,RealFrac,Functor,Foldable,Traversable + ,DetectableZero,NFData) instance (Bounded a, Semiring a) => Bounded (PosFrac a) where minBound = PosFrac zero @@ -212,9 +216,6 @@ {-# INLINE zero #-} {-# INLINE one #-} -instance (Eq a, Semiring a) => DetectableZero (PosFrac a) where - isZero = (zero==) - instance (Ord a, Fractional a, Semiring a, HasPositiveInfinity a) => StarSemiring (PosFrac a) where star (PosFrac n) @@ -242,10 +243,10 @@ --'star' 0 = 1 --'star' _ = 'positiveInfinity'@ newtype PosInt a = PosInt - { getPosInt :: a - } deriving (Eq, Ord, Read, Show, Generic, Generic1, Num - ,Enum, Typeable, Storable, Fractional, Real, RealFrac - ,Functor, Foldable, Traversable) + { getPosInt :: a + } deriving (Eq,Ord,Read,Show,Generic,Generic1,Num,Enum,Typeable,Storable + ,Fractional,Real,RealFrac,Functor,Foldable,Traversable + ,DetectableZero,NFData) instance (Bounded a, Semiring a) => Bounded (PosInt a) where minBound = PosInt zero @@ -261,9 +262,6 @@ {-# INLINE zero #-} {-# INLINE one #-} -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 @@ -281,24 +279,344 @@ 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 '}' +newtype instance U.Vector (Bottleneck a) = V_Bottleneck (U.Vector a) +newtype instance U.MVector s (Bottleneck a) = MV_Bottleneck (U.MVector s a) -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 U.Unbox a => + M.MVector U.MVector (Bottleneck a) where + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicOverlaps #-} + {-# INLINE basicUnsafeNew #-} + {-# INLINE basicUnsafeRead #-} + {-# INLINE basicUnsafeWrite #-} + basicLength = + (coerce :: (U.MVector s a -> Int) -> U.MVector s (Bottleneck a) -> Int) + M.basicLength + basicUnsafeSlice = + (coerce :: (Int -> Int -> U.MVector s a -> U.MVector s a) -> Int -> Int -> U.MVector s (Bottleneck a) -> U.MVector s (Bottleneck a)) + M.basicUnsafeSlice + basicOverlaps = + (coerce :: (U.MVector s a -> U.MVector s a -> Bool) -> U.MVector s (Bottleneck a) -> U.MVector s (Bottleneck a) -> Bool) + M.basicOverlaps + basicUnsafeNew n = + fmap + (coerce :: U.MVector s a -> U.MVector s (Bottleneck a)) + (M.basicUnsafeNew n) + basicUnsafeRead (MV_Bottleneck xs) i = + fmap (coerce :: a -> Bottleneck a) (M.basicUnsafeRead xs i) + basicUnsafeWrite = + (coerce :: (U.MVector s a -> Int -> a -> m ()) -> U.MVector s (Bottleneck a) -> Int -> Bottleneck a -> m ()) + M.basicUnsafeWrite + basicInitialize = + (coerce :: (U.MVector s a -> m ()) -> U.MVector s (Bottleneck a) -> m ()) + M.basicInitialize + +instance U.Unbox a => + G.Vector U.Vector (Bottleneck a) where + {-# INLINE basicUnsafeFreeze #-} + {-# INLINE basicUnsafeThaw #-} + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeFreeze (MV_Bottleneck xs) = + fmap + (coerce :: U.Vector a -> U.Vector (Bottleneck a)) + (G.basicUnsafeFreeze xs) + basicUnsafeThaw (V_Bottleneck xs) = + fmap + (coerce :: U.MVector s a -> U.MVector s (Bottleneck a)) + (G.basicUnsafeThaw xs) + basicLength = + (coerce :: (U.Vector a -> Int) -> U.Vector (Bottleneck a) -> Int) + G.basicLength + basicUnsafeSlice = + (coerce :: (Int -> Int -> U.Vector a -> U.Vector a) -> Int -> Int -> U.Vector (Bottleneck a) -> U.Vector (Bottleneck a)) + G.basicUnsafeSlice + basicUnsafeIndexM (V_Bottleneck xs) i = + fmap (coerce :: a -> Bottleneck a) (G.basicUnsafeIndexM xs i) + +newtype instance U.Vector (Division a) = V_Division (U.Vector a) +newtype instance U.MVector s (Division a) = MV_Division (U.MVector s a) + +instance U.Unbox a => + M.MVector U.MVector (Division a) where + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicOverlaps #-} + {-# INLINE basicUnsafeNew #-} + {-# INLINE basicUnsafeRead #-} + {-# INLINE basicUnsafeWrite #-} + basicLength = + (coerce :: (U.MVector s a -> Int) -> U.MVector s (Division a) -> Int) + M.basicLength + basicUnsafeSlice = + (coerce :: (Int -> Int -> U.MVector s a -> U.MVector s a) -> Int -> Int -> U.MVector s (Division a) -> U.MVector s (Division a)) + M.basicUnsafeSlice + basicOverlaps = + (coerce :: (U.MVector s a -> U.MVector s a -> Bool) -> U.MVector s (Division a) -> U.MVector s (Division a) -> Bool) + M.basicOverlaps + basicUnsafeNew n = + fmap + (coerce :: U.MVector s a -> U.MVector s (Division a)) + (M.basicUnsafeNew n) + basicUnsafeRead (MV_Division xs) i = + fmap (coerce :: a -> Division a) (M.basicUnsafeRead xs i) + basicUnsafeWrite = + (coerce :: (U.MVector s a -> Int -> a -> m ()) -> U.MVector s (Division a) -> Int -> Division a -> m ()) + M.basicUnsafeWrite + basicInitialize = + (coerce :: (U.MVector s a -> m ()) -> U.MVector s (Division a) -> m ()) + M.basicInitialize + +instance U.Unbox a => + G.Vector U.Vector (Division a) where + {-# INLINE basicUnsafeFreeze #-} + {-# INLINE basicUnsafeThaw #-} + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeFreeze (MV_Division xs) = + fmap + (coerce :: U.Vector a -> U.Vector (Division a)) + (G.basicUnsafeFreeze xs) + basicUnsafeThaw (V_Division xs) = + fmap + (coerce :: U.MVector s a -> U.MVector s (Division a)) + (G.basicUnsafeThaw xs) + basicLength = + (coerce :: (U.Vector a -> Int) -> U.Vector (Division a) -> Int) + G.basicLength + basicUnsafeSlice = + (coerce :: (Int -> Int -> U.Vector a -> U.Vector a) -> Int -> Int -> U.Vector (Division a) -> U.Vector (Division a)) + G.basicUnsafeSlice + basicUnsafeIndexM (V_Division xs) i = + fmap (coerce :: a -> Division a) (G.basicUnsafeIndexM xs i) + +newtype instance U.Vector (Łukasiewicz a) = V_Łukasiewicz (U.Vector a) +newtype instance U.MVector s (Łukasiewicz a) = MV_Łukasiewicz (U.MVector s a) + +instance U.Unbox a => + M.MVector U.MVector (Łukasiewicz a) where + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicOverlaps #-} + {-# INLINE basicUnsafeNew #-} + {-# INLINE basicUnsafeRead #-} + {-# INLINE basicUnsafeWrite #-} + basicLength = + (coerce :: (U.MVector s a -> Int) -> U.MVector s (Łukasiewicz a) -> Int) + M.basicLength + basicUnsafeSlice = + (coerce :: (Int -> Int -> U.MVector s a -> U.MVector s a) -> Int -> Int -> U.MVector s (Łukasiewicz a) -> U.MVector s (Łukasiewicz a)) + M.basicUnsafeSlice + basicOverlaps = + (coerce :: (U.MVector s a -> U.MVector s a -> Bool) -> U.MVector s (Łukasiewicz a) -> U.MVector s (Łukasiewicz a) -> Bool) + M.basicOverlaps + basicUnsafeNew n = + fmap + (coerce :: U.MVector s a -> U.MVector s (Łukasiewicz a)) + (M.basicUnsafeNew n) + basicUnsafeRead (MV_Łukasiewicz xs) i = + fmap (coerce :: a -> Łukasiewicz a) (M.basicUnsafeRead xs i) + basicUnsafeWrite = + (coerce :: (U.MVector s a -> Int -> a -> m ()) -> U.MVector s (Łukasiewicz a) -> Int -> Łukasiewicz a -> m ()) + M.basicUnsafeWrite + basicInitialize = + (coerce :: (U.MVector s a -> m ()) -> U.MVector s (Łukasiewicz a) -> m ()) + M.basicInitialize + +instance U.Unbox a => + G.Vector U.Vector (Łukasiewicz a) where + {-# INLINE basicUnsafeFreeze #-} + {-# INLINE basicUnsafeThaw #-} + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeFreeze (MV_Łukasiewicz xs) = + fmap + (coerce :: U.Vector a -> U.Vector (Łukasiewicz a)) + (G.basicUnsafeFreeze xs) + basicUnsafeThaw (V_Łukasiewicz xs) = + fmap + (coerce :: U.MVector s a -> U.MVector s (Łukasiewicz a)) + (G.basicUnsafeThaw xs) + basicLength = + (coerce :: (U.Vector a -> Int) -> U.Vector (Łukasiewicz a) -> Int) + G.basicLength + basicUnsafeSlice = + (coerce :: (Int -> Int -> U.Vector a -> U.Vector a) -> Int -> Int -> U.Vector (Łukasiewicz a) -> U.Vector (Łukasiewicz a)) + G.basicUnsafeSlice + basicUnsafeIndexM (V_Łukasiewicz xs) i = + fmap (coerce :: a -> Łukasiewicz a) (G.basicUnsafeIndexM xs i) + +newtype instance U.Vector (Viterbi a) = V_Viterbi (U.Vector a) +newtype instance U.MVector s (Viterbi a) = MV_Viterbi (U.MVector s a) + +instance U.Unbox a => + M.MVector U.MVector (Viterbi a) where + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicOverlaps #-} + {-# INLINE basicUnsafeNew #-} + {-# INLINE basicUnsafeRead #-} + {-# INLINE basicUnsafeWrite #-} + basicLength = + (coerce :: (U.MVector s a -> Int) -> U.MVector s (Viterbi a) -> Int) + M.basicLength + basicUnsafeSlice = + (coerce :: (Int -> Int -> U.MVector s a -> U.MVector s a) -> Int -> Int -> U.MVector s (Viterbi a) -> U.MVector s (Viterbi a)) + M.basicUnsafeSlice + basicOverlaps = + (coerce :: (U.MVector s a -> U.MVector s a -> Bool) -> U.MVector s (Viterbi a) -> U.MVector s (Viterbi a) -> Bool) + M.basicOverlaps + basicUnsafeNew n = + fmap + (coerce :: U.MVector s a -> U.MVector s (Viterbi a)) + (M.basicUnsafeNew n) + basicUnsafeRead (MV_Viterbi xs) i = + fmap (coerce :: a -> Viterbi a) (M.basicUnsafeRead xs i) + basicUnsafeWrite = + (coerce :: (U.MVector s a -> Int -> a -> m ()) -> U.MVector s (Viterbi a) -> Int -> Viterbi a -> m ()) + M.basicUnsafeWrite + basicInitialize = + (coerce :: (U.MVector s a -> m ()) -> U.MVector s (Viterbi a) -> m ()) + M.basicInitialize + +instance U.Unbox a => + G.Vector U.Vector (Viterbi a) where + {-# INLINE basicUnsafeFreeze #-} + {-# INLINE basicUnsafeThaw #-} + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeFreeze (MV_Viterbi xs) = + fmap + (coerce :: U.Vector a -> U.Vector (Viterbi a)) + (G.basicUnsafeFreeze xs) + basicUnsafeThaw (V_Viterbi xs) = + fmap + (coerce :: U.MVector s a -> U.MVector s (Viterbi a)) + (G.basicUnsafeThaw xs) + basicLength = + (coerce :: (U.Vector a -> Int) -> U.Vector (Viterbi a) -> Int) + G.basicLength + basicUnsafeSlice = + (coerce :: (Int -> Int -> U.Vector a -> U.Vector a) -> Int -> Int -> U.Vector (Viterbi a) -> U.Vector (Viterbi a)) + G.basicUnsafeSlice + basicUnsafeIndexM (V_Viterbi xs) i = + fmap (coerce :: a -> Viterbi a) (G.basicUnsafeIndexM xs i) + +newtype instance U.Vector (PosFrac a) = V_PosFrac (U.Vector a) +newtype instance U.MVector s (PosFrac a) = MV_PosFrac (U.MVector s a) + +instance U.Unbox a => + M.MVector U.MVector (PosFrac a) where + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicOverlaps #-} + {-# INLINE basicUnsafeNew #-} + {-# INLINE basicUnsafeRead #-} + {-# INLINE basicUnsafeWrite #-} + basicLength = + (coerce :: (U.MVector s a -> Int) -> U.MVector s (PosFrac a) -> Int) + M.basicLength + basicUnsafeSlice = + (coerce :: (Int -> Int -> U.MVector s a -> U.MVector s a) -> Int -> Int -> U.MVector s (PosFrac a) -> U.MVector s (PosFrac a)) + M.basicUnsafeSlice + basicOverlaps = + (coerce :: (U.MVector s a -> U.MVector s a -> Bool) -> U.MVector s (PosFrac a) -> U.MVector s (PosFrac a) -> Bool) + M.basicOverlaps + basicUnsafeNew n = + fmap + (coerce :: U.MVector s a -> U.MVector s (PosFrac a)) + (M.basicUnsafeNew n) + basicUnsafeRead (MV_PosFrac xs) i = + fmap (coerce :: a -> PosFrac a) (M.basicUnsafeRead xs i) + basicUnsafeWrite = + (coerce :: (U.MVector s a -> Int -> a -> m ()) -> U.MVector s (PosFrac a) -> Int -> PosFrac a -> m ()) + M.basicUnsafeWrite + basicInitialize = + (coerce :: (U.MVector s a -> m ()) -> U.MVector s (PosFrac a) -> m ()) + M.basicInitialize + +instance U.Unbox a => + G.Vector U.Vector (PosFrac a) where + {-# INLINE basicUnsafeFreeze #-} + {-# INLINE basicUnsafeThaw #-} + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeFreeze (MV_PosFrac xs) = + fmap + (coerce :: U.Vector a -> U.Vector (PosFrac a)) + (G.basicUnsafeFreeze xs) + basicUnsafeThaw (V_PosFrac xs) = + fmap + (coerce :: U.MVector s a -> U.MVector s (PosFrac a)) + (G.basicUnsafeThaw xs) + basicLength = + (coerce :: (U.Vector a -> Int) -> U.Vector (PosFrac a) -> Int) + G.basicLength + basicUnsafeSlice = + (coerce :: (Int -> Int -> U.Vector a -> U.Vector a) -> Int -> Int -> U.Vector (PosFrac a) -> U.Vector (PosFrac a)) + G.basicUnsafeSlice + basicUnsafeIndexM (V_PosFrac xs) i = + fmap (coerce :: a -> PosFrac a) (G.basicUnsafeIndexM xs i) + +newtype instance U.Vector (PosInt a) = V_PosInt (U.Vector a) +newtype instance U.MVector s (PosInt a) = MV_PosInt (U.MVector s a) + +instance U.Unbox a => + M.MVector U.MVector (PosInt a) where + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicOverlaps #-} + {-# INLINE basicUnsafeNew #-} + {-# INLINE basicUnsafeRead #-} + {-# INLINE basicUnsafeWrite #-} + basicLength = + (coerce :: (U.MVector s a -> Int) -> U.MVector s (PosInt a) -> Int) + M.basicLength + basicUnsafeSlice = + (coerce :: (Int -> Int -> U.MVector s a -> U.MVector s a) -> Int -> Int -> U.MVector s (PosInt a) -> U.MVector s (PosInt a)) + M.basicUnsafeSlice + basicOverlaps = + (coerce :: (U.MVector s a -> U.MVector s a -> Bool) -> U.MVector s (PosInt a) -> U.MVector s (PosInt a) -> Bool) + M.basicOverlaps + basicUnsafeNew n = + fmap + (coerce :: U.MVector s a -> U.MVector s (PosInt a)) + (M.basicUnsafeNew n) + basicUnsafeRead (MV_PosInt xs) i = + fmap (coerce :: a -> PosInt a) (M.basicUnsafeRead xs i) + basicUnsafeWrite = + (coerce :: (U.MVector s a -> Int -> a -> m ()) -> U.MVector s (PosInt a) -> Int -> PosInt a -> m ()) + M.basicUnsafeWrite + basicInitialize = + (coerce :: (U.MVector s a -> m ()) -> U.MVector s (PosInt a) -> m ()) + M.basicInitialize + +instance U.Unbox a => + G.Vector U.Vector (PosInt a) where + {-# INLINE basicUnsafeFreeze #-} + {-# INLINE basicUnsafeThaw #-} + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeFreeze (MV_PosInt xs) = + fmap + (coerce :: U.Vector a -> U.Vector (PosInt a)) + (G.basicUnsafeFreeze xs) + basicUnsafeThaw (V_PosInt xs) = + fmap + (coerce :: U.MVector s a -> U.MVector s (PosInt a)) + (G.basicUnsafeThaw xs) + basicLength = + (coerce :: (U.Vector a -> Int) -> U.Vector (PosInt a) -> Int) + G.basicLength + basicUnsafeSlice = + (coerce :: (Int -> Int -> U.Vector a -> U.Vector a) -> Int -> Int -> U.Vector (PosInt a) -> U.Vector (PosInt a)) + G.basicUnsafeSlice + basicUnsafeIndexM (V_PosInt xs) i = + fmap (coerce :: a -> PosInt a) (G.basicUnsafeIndexM xs i) diff --git a/src/Test/Semiring.hs b/src/Test/Semiring.hs --- a/src/Test/Semiring.hs +++ b/src/Test/Semiring.hs @@ -507,7 +507,7 @@ -- | Multiplication law for ordered 'Semiring's. -- --- @x '<=' y => x '<.>' z '<=' y '<.>' z '&&' z '<.>' x '<=' z '<.>' y@ +-- @x '<=' y && 'zero' '<=' z => x '<.>' z '<=' y '<.>' z '&&' z '<.>' x '<=' z '<.>' y@ ordMulLaw :: (Ord a, Semiring a, Show a) => a -> a -> a -> Either String String @@ -528,7 +528,7 @@ else " not") ++ " followed." , " Law:" - , " x <= y => x <.> z <= y <.> z && z <.> x <= z <.> y" + , " x <= y && zero <= z => x <.> z <= y <.> z && z <.> x <= z <.> y" , " x = " ++ show x , " y = " ++ show y , " z = " ++ show z] diff --git a/test/ApproxLog.hs b/test/ApproxLog.hs new file mode 100644 --- /dev/null +++ b/test/ApproxLog.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module ApproxLog where + +import Test.QuickCheck as QC +import Test.SmallCheck.Series as SC + +import Data.Semiring + +import Numeric.Log +import Numeric.Log.Signed + +import CompUtils + +newtype ApproxLog a = + ApproxLog (Log a) + deriving (Show,Num,Fractional,Real,RealFrac,Floating,Semiring) + +instance (Arbitrary a, Precise a, RealFloat a) => + Arbitrary (ApproxLog a) where + arbitrary = fmap (ApproxLog #. fromRational .# QC.getNonNegative) arbitrary + +instance (Serial m a, Precise a, RealFloat a) => + Serial m (ApproxLog a) where + series = fmap (ApproxLog #. fromRational .# SC.getNonNegative) series + +instance (RealFloat a, Ord a) => + Eq (ApproxLog a) where + ApproxLog (Exp x) == ApproxLog (Exp y) = + isInfinite x && isInfinite y || + x == y || abs ((exp x-exp y) / exp x) < 0.01 + +instance (RealFloat a, Ord a) => Ord (ApproxLog a) where + compare (ApproxLog x) (ApproxLog y) + | ApproxLog x == ApproxLog y = EQ + | otherwise = compare x y + +newtype SApproxLog a = + SApproxLog (SignedLog a) + deriving (Show,Num,Fractional,Real,RealFrac,Floating,Semiring) + +instance (Arbitrary a, Precise a, RealFloat a) => + Arbitrary (SApproxLog a) where + arbitrary = fmap (SApproxLog #. fromRational .# QC.getNonNegative) arbitrary + +instance (Serial m a, Precise a, RealFloat a) => + Serial m (SApproxLog a) where + series = fmap (SApproxLog #. fromRational .# SC.getNonNegative) series + +instance (RealFloat a, Ord a) => + Eq (SApproxLog a) where + SApproxLog (SLExp xb x) == SApproxLog (SLExp yb y) = xb == yb && ( + isInfinite x && isInfinite y || + x == y || abs ((exp x-exp y) / exp x) < 0.01) + +instance (RealFloat a, Ord a) => Ord (SApproxLog a) where + compare (SApproxLog x) (SApproxLog y) + | SApproxLog x == SApproxLog y = EQ + | otherwise = compare x y diff --git a/test/CompUtils.hs b/test/CompUtils.hs new file mode 100644 --- /dev/null +++ b/test/CompUtils.hs @@ -0,0 +1,18 @@ +module CompUtils where + +import Data.Coerce + +(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d +(f .: g) x y = f (g x y) + +infixr 9 #. +(#.) :: Coercible b c => (b -> c) -> (a -> b) -> a -> c +(#.) _ = coerce + +infixr 9 .# +(.#) :: Coercible a b => (b -> c) -> (a -> b) -> a -> c +(.#) f _ = coerce f + +infixl 4 <#$> +(<#$>) :: Coercible (f a) (f b) => (a -> b) -> f a -> f b +(<#$>) _ = coerce diff --git a/test/Fraction.hs b/test/Fraction.hs new file mode 100644 --- /dev/null +++ b/test/Fraction.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Fraction where + +import Data.Semiring + +import Test.SmallCheck.Series + +import Control.Applicative + +newtype Fraction = + Fraction Double + deriving (Show,Num,Fractional,Real,RealFrac,Floating,RealFloat,Semiring) + +instance DetectableZero Fraction where isZero = (0==) + +instance Eq Fraction where + Fraction x == Fraction y = abs (x - y) < 0.011 + +instance Ord Fraction where + compare (Fraction x) (Fraction y) + | Fraction x == Fraction y = EQ + | otherwise = compare x y + +instance Monad m => Serial m Fraction where + series = fmap Fraction $ generate (\d -> if d >= 0 then pure 0 else empty) <|> rest where + rest = generate $ \d -> take d (1 : go 0 1) + go lower upper = let mid = (lower + upper) / 2 in + mid : interleave (go lower mid) (go mid upper) + interleave (x:xs) (y:ys) = x : y : interleave xs ys + interleave _ _ = undefined diff --git a/test/Func.hs b/test/Func.hs new file mode 100644 --- /dev/null +++ b/test/Func.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Func where + +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map + +import Data.Semiring + +import Test.QuickCheck + +import Data.Function +import Data.Monoid + +import CompUtils + +data Func a b = Func + { def :: b + , vals :: IntMap b + } deriving (Eq,Ord) + +(#$) :: Enum a => Func a b -> a -> b +(#$) f x = IntMap.findWithDefault (def f) (fromEnum x) (vals f) + +instance (Enum a, Show a, Show b) => + Show (Func a b) where + showsPrec _ (Func c xs :: Func a b) = + showChar '{' . IntMap.foldrWithKey f b xs + where + f x y a = + shows (toEnum x :: a) . + showString " -> " . shows y . showString ", " . a + b = showString "_ -> " . shows c . showChar '}' + +fromFunc :: (Enum a, Bounded a, Ord b) => (a -> b) -> Func a b +fromFunc f = + uncurry Func . fmap IntMap.fromList . remMostFreq $ + [ (fromEnum x, f x) + | x <- [minBound .. maxBound] ] + where + remMostFreq xs = (mf, filter ((mf/=) . snd) xs) where + Just mf = mostFrequent (map snd xs) + +mostFrequent :: Ord a => [a] -> Maybe a +mostFrequent xs = foldr f (const . fmap fst) xs Nothing (Map.empty :: Map a Int) where + f e a Nothing _ = a (Just (e, 1)) (Map.singleton e 1) + f e a (Just (b,n)) m + | d > n = a (Just (e,d)) nm + | otherwise = a (Just (b,n)) nm where + (nv,nm) = Map.insertLookupWithKey (const (+)) e 1 m + d = maybe 1 succ nv + +instance (Enum a, Bounded a, Ord b, Semiring b) => Semiring (Func a b) where + zero = fromFunc zero + one = fromFunc one + (<+>) = fromFunc .: (<+>) `on` (#$) + (<.>) = fromFunc .: (<.>) `on` (#$) + +instance (Bounded a, Enum a, Ord b, Arbitrary b, CoArbitrary a) => + Arbitrary (Func a b) where + arbitrary = fmap fromFunc arbitrary + shrink f = fmap fromFunc (shrink (f #$)) + +newtype EndoFunc a = EndoFunc + { getEndoFunc :: Endo a + } deriving (Semiring,DetectableZero) + +instance (Enum a, Bounded a, Ord a) => Eq (EndoFunc a) where + (==) = (==) `on` (fromFunc .# appEndo .# getEndoFunc) + +instance (Enum a, Bounded a, Ord a, Show a) => Show (EndoFunc a) where + showsPrec n = showsPrec n . fromFunc .# appEndo .# getEndoFunc + +instance (Arbitrary a, CoArbitrary a) => + Arbitrary (EndoFunc a) where + arbitrary = (EndoFunc . Endo) <#$> arbitrary + shrink (EndoFunc (Endo f)) = (EndoFunc . Endo) <#$> shrink f diff --git a/test/LimitSize.hs b/test/LimitSize.hs new file mode 100644 --- /dev/null +++ b/test/LimitSize.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module LimitSize where + +import Test.QuickCheck +import Test.SmallCheck.Series + +import Data.Semiring + +import GHC.TypeLits +import Data.Function +import Data.Proxy + +newtype LimitSize (n :: Nat) a = + LimitSize [a] + deriving (Arbitrary,Semiring,DetectableZero,StarSemiring) + +takeFirst + :: KnownNat n + => LimitSize n a -> [a] +takeFirst (LimitSize xs :: LimitSize n a) = + take (fromInteger (natVal (Proxy :: Proxy n))) xs + +instance Serial m a => + Serial m (LimitSize n a) where + series = fmap LimitSize series + +instance (Eq a, KnownNat n) => + Eq (LimitSize n a) where + (==) = (==) `on` takeFirst + +instance (Show a, KnownNat n) => + Show (LimitSize n a) where + showsPrec n = showsPrec n . takeFirst diff --git a/test/Orphans.hs b/test/Orphans.hs new file mode 100644 --- /dev/null +++ b/test/Orphans.hs @@ -0,0 +1,107 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Orphans where + +import Test.QuickCheck hiding (Positive(..), generate) +import Test.SmallCheck.Series hiding (Positive(..)) +import qualified Test.SmallCheck.Series as SC + +import Data.Semiring +import Data.Semiring.Infinite +import Data.Semiring.Free +import Data.Semiring.Numeric +import qualified Data.Vector as Vector +import Numeric.Natural +import Numeric.Sized.WordOfSize +import Data.Monoid +import Numeric.Log + +import CompUtils + +import Data.Bool +import GHC.TypeLits + + +instance Arbitrary a => Arbitrary (Add a) where + arbitrary = Add <#$> arbitrary + shrink = map Add #. shrink .# getAdd + +instance CoArbitrary a => CoArbitrary (Add a) where + coarbitrary = coarbitrary .# getAdd + +instance Arbitrary a => Arbitrary (PositiveInfinite a) where + arbitrary = fmap (maybe PositiveInfinity PosFinite) arbitrary + +instance Arbitrary a => Arbitrary (NegativeInfinite a) where + arbitrary = fmap (maybe NegativeInfinity NegFinite) arbitrary + +instance Arbitrary a => Arbitrary (Infinite a) where + arbitrary = fmap (either (bool Positive Negative) Finite) arbitrary + +instance Arbitrary a => Arbitrary (Vector.Vector a) where + arbitrary = fmap Vector.fromList arbitrary + shrink = fmap Vector.fromList . shrink . Vector.toList + +instance Testable (Either String String) where + property = either (`counterexample` False) (const (property True)) + +instance Arbitrary (f (g a)) => Arbitrary (Matrix f g a) where + arbitrary = fmap Matrix arbitrary + shrink (Matrix xs) = fmap Matrix (shrink xs) + +instance (Monad m, KnownNat n) => Serial m (WordOfSize n) where + series = generate (`take` [minBound..maxBound]) + +instance KnownNat n => Arbitrary (WordOfSize n) where + arbitrary = arbitraryBoundedEnum + +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 + +instance (Monad m, Serial m a) => Serial m (NegativeInfinite a) where + series = fmap (maybe NegativeInfinity NegFinite) series + +instance (Monad m, Serial m a) => Serial m (Infinite a) where + series = fmap (either (bool Positive Negative) Finite) series + +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 (Serial m a, Monad m, Num a, Ord a) => Serial m (Division a) where + series = fmap (Division . SC.getPositive) 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 => Serial m (Log a) where + series = fmap Exp series diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,43 +1,28 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Main (main) where -import Control.Applicative - -import Control.Arrow (first) -import Data.Function -import Data.Bool import Data.Proxy -import Data.Foldable import Data.Monoid -import Data.IntMap.Strict (IntMap) -import qualified Data.IntMap.Strict as IntMap - import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import qualified Data.Vector as Vector +import qualified Data.Vector as Vector +import qualified Data.Vector.Storable as Storable import Data.Semiring import Data.Semiring.Free import Data.Semiring.Infinite import Data.Semiring.Numeric -import GHC.TypeLits import Numeric.Natural import Numeric.Sized.WordOfSize @@ -45,15 +30,20 @@ import Test.QuickCheck hiding (Positive (..), generate, (.&.)) 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 +import ApproxLog +import Fraction +import Func +import LimitSize +import Orphans () +import Vectors + ------------------------------------------------------------------------ semiringLawsSC :: (Show r, Eq r, Semiring r, Serial IO r) => f r -> TestTree @@ -90,10 +80,10 @@ [ SC.testProperty "starLaw" (starLaw :: r -> Either String String) , SC.testProperty "plusLaw" (plusLaw :: r -> Either String String)] --- 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)] +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)] zeroLawsQC :: (Show r, Eq r, DetectableZero r, Arbitrary r) => f r -> TestTree zeroLawsQC (_ :: f r) = testGroup "Zero laws" @@ -110,6 +100,20 @@ [ SC.testProperty "zeroLaw" (zeroLaw :: r -> Either String String) , SC.testProperty "zeroIsZero" (zeroIsZero (Proxy :: Proxy r))] +storableQC :: (Show r, Eq r, Arbitrary r, Storable.Storable r) => f r -> TestTree +storableQC (_ :: f r) = + testGroup + "Storable implementation" + [ QC.testProperty + "unstore . store == id" + (\(xs :: [r]) -> + (Storable.toList |.| Storable.fromList) xs === xs)] + +infixr 9 |.| +(|.|) :: (b -> c) -> (a -> b) -> a -> c +(|.|) f g x = f (g x) +{-# NOINLINE (|.|) #-} + type Tup2 a = (a,a) type Tup3 a = (a,a,a) type Tup4 a = (a,a,a,a) @@ -122,467 +126,224 @@ refListMul :: Semiring a => [a] -> [a] -> [a] -refListMul [] _ = [] -refListMul _ [] = [] -refListMul (x:xs) (y:ys) = - (x <.> y) : - (map (x <.>) ys <+> map (<.> y) xs <+> (zero : refListMul xs ys)) +refListMul [] _ = [] +refListMul _ [] = [] +refListMul (x:xs) yys@(y:ys) = (x <.> y) : map (x <.>) ys <+> xs <.> yys -newtype Polynomial a = - Polynomial [a] - deriving (Show,Arbitrary,Semiring,DetectableZero) +typeclassTests :: TestTree +typeclassTests = + testGroup + "typeclass tests" + [ testGroup + "PositiveInfinite" + [ let p = Proxy :: Proxy (PositiveInfinite Int) + in storableQC p] + , testGroup + "NegativeInfinite" + [ let p = Proxy :: Proxy (NegativeInfinite Int) + in storableQC p] + , testGroup + "Infinite" + [ let p = Proxy :: Proxy (Infinite Int) + in storableQC p]] -instance (Monad m, Serial m a) => Serial m (Polynomial a) where - series = fmap Polynomial series -instance (DetectableZero a, Eq a) => Eq (Polynomial a) where - Polynomial xs' == Polynomial ys' = go xs' ys' where - go [] ys = isZero ys - go xs [] = isZero xs - go (x:xs) (y:ys) = x == y && go xs ys -newtype LimitSize (n :: Nat) a = - LimitSize [a] - deriving (Arbitrary,Semiring,DetectableZero,StarSemiring) - -takeFirst :: KnownNat n => LimitSize n a -> [a] -takeFirst (LimitSize xs :: LimitSize n a) = take (fromInteger (natVal (Proxy :: Proxy n))) xs - -instance (Monad m, Serial m a) => Serial m (LimitSize n a) where - series = fmap LimitSize series - -instance (Eq a, KnownNat n) => Eq (LimitSize n a) where - (==) = (==) `on` takeFirst - -instance (Show a, KnownNat n) => Show (LimitSize n a) where - showsPrec n = showsPrec n . takeFirst +semiringLawTests :: TestTree +semiringLawTests = + testGroup + "Semiring/StarSemiring Laws" + [ let p = Proxy :: Proxy (ApproxLog Double) + in testGroup "Log" [semiringLawsSC p] + , let p = Proxy :: Proxy (SApproxLog Double) + in testGroup "Log" [semiringLawsSC p] + , let p = Proxy :: Proxy (Map String Int) + in testGroup + "Map" + [localOption (QC.QuickCheckMaxSize 10) $ semiringLawsQC p] + , let p0 = Proxy :: Proxy (Matrix V0 V0 Integer) + p1 = Proxy :: Proxy (Matrix V1 V1 Integer) + p2 = Proxy :: Proxy (Matrix V2 V2 Integer) + p5 = Proxy :: Proxy (Matrix V5 V5 Integer) + in testGroup + "Matrix" + [ testGroup "0" [semiringLawsQC p0] + , testGroup "1" [semiringLawsQC p1] + , testGroup "2" [semiringLawsQC p2] + , testGroup "5" [semiringLawsQC p5]] + , let p = Proxy :: Proxy Integer + in testGroup "Integer" [semiringLawsSC p, ordLawsSC p, zeroLawsSC p, ordLawsQC 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)" [semiringLawsQC p, zeroLawsQC 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 [Integer] + in testGroup + "[Integer]" + [ semiringLawsQC p + , starLawsQC + (Proxy :: Proxy (LimitSize 100 (PositiveInfinite Integer))) + , QC.testProperty + "reference implementation of <.>" + (\xs ys -> + (xs <.> ys) === + refListMul xs (ys :: [WordOfSize 2]))] + , let p = Proxy :: Proxy (Vector.Vector Int) + in testGroup + "Vector Int" + [ semiringLawsQC p + , QC.testProperty + "reference implementation of <.>" + (\xs ys -> + (xs <.> ys :: [Int]) === + Vector.toList + (Vector.fromList xs <.> Vector.fromList ys))] + , 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 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]] 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 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)" - [semiringLawsQC p, zeroLawsQC 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 [Integer] - in testGroup - "[Integer]" - [ semiringLawsQC p - , starLawsQC - (Proxy :: Proxy (LimitSize 100 (PositiveInfinite Integer))) - , QC.testProperty - "reference implementation of <.>" - (\xs ys -> - Polynomial (xs <.> ys) === - Polynomial - (refListMul xs (ys :: [WordOfSize 2])))] - , let p = Proxy :: Proxy (Vector.Vector Int) - in testGroup - "Vector Int" - [ semiringLawsQC p - , QC.testProperty - "reference implementation of <.>" - (\xs ys -> - (xs <.> ys :: [Int]) === - Vector.toList - (Vector.fromList xs <.> Vector.fromList ys))] - , 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]] - ------------------------------------------------------------------------- --- Serial wrappers - --- | A type with a serial instance between zero and one -newtype Fraction = - Fraction Double - deriving (Show,Num,Fractional,Real,RealFrac,Floating,RealFloat,Semiring) - -instance DetectableZero Fraction where isZero = (0==) - -newtype Approx a = - Approx a - deriving (Show,Num,Fractional,Real,RealFrac,Floating,RealFloat,Semiring - ,HasPositiveInfinity) - -instance (Arbitrary a, Num a, Ord a) => Arbitrary (Approx a) where - arbitrary = fmap Approx (suchThat arbitrary ((<100).abs)) - -instance Eq Fraction where - Fraction x == Fraction y = abs (x - y) < 0.011 - -instance (RealFloat a, Ord a) => - Eq (Approx a) where - Approx x == Approx y = - isInfinite x && isInfinite y || - x == y || - let n = abs (x - y) - in max (n / abs x) (n / abs y) < 0.011 - -instance (RealFloat a, Ord a) => Ord (Approx a) where - compare (Approx x) (Approx y) - | Approx x == Approx y = EQ - | otherwise = compare x y - -instance Ord Fraction where - compare (Fraction x) (Fraction y) - | Fraction x == Fraction y = EQ - | otherwise = compare x y - -instance Monad m => Serial m Fraction where - series = fmap Fraction $ generate (\d -> if d >= 0 then pure 0 else empty) <|> rest where - rest = generate $ \d -> take d (1 : go 0 1) - go lower upper = let mid = (lower + upper) / 2 in - mid : interleave (go lower mid) (go mid upper) - interleave (x:xs) (y:ys) = x : y : interleave xs ys - interleave _ _ = undefined - -instance (Monad m, KnownNat n) => Serial m (WordOfSize n) where - series = generate (`take` [minBound..maxBound]) - -instance KnownNat n => Arbitrary (WordOfSize n) where - arbitrary = arbitraryBoundedEnum - -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 - -instance (Monad m, Serial m a) => Serial m (NegativeInfinite a) where - series = fmap (maybe NegativeInfinity NegFinite) series - -instance (Monad m, Serial m a) => Serial m (Infinite a) where - series = fmap (either (bool Positive Negative) Finite) series - -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 - --- | A representation of a function -data Func a b = Func b (IntMap b) - deriving (Eq, Ord) - -newtype EndoFunc a = EndoFunc (Endo a) deriving (Semiring, DetectableZero) - -instance (Enum a, Bounded a, Ord a) => Eq (EndoFunc a) where - EndoFunc (Endo f) == EndoFunc (Endo g) = fromFunc f == fromFunc g - -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 - . IntMap.fromList - . filter ((cnst/=) . snd) - -fromList :: (Enum a, Eq b) => b -> [(a,b)] -> Func a b -fromList cnst - = fromList' cnst - . map (first fromEnum) - -fromFunc :: (Enum a, Bounded a, Ord b) => (a -> b) -> Func a b -fromFunc f = fromList cnst (zip xs ys) where - xs = [minBound..maxBound] - ys = map f xs - Just cnst = mostFrequent ys - -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 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 (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 - -instance (Enum a, Show a, Show b) => Show (Func a b) where - showsPrec _ (Func c xs :: Func a b) = showChar '{' . IntMap.foldrWithKey f b xs where - f x y a = shows (toEnum x :: a) . showString " -> " . shows y . showString ", " . a - b = showString "_ -> " . shows c . showChar '}' - -instance (Enum a, Bounded a, Ord b, Semiring b) => Semiring (Func a b) where - zero = fromFunc zero - one = fromFunc one - 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 - -instance Arbitrary a => Arbitrary (PositiveInfinite a) where - arbitrary = fmap (maybe PositiveInfinity PosFinite) arbitrary - -instance Arbitrary a => Arbitrary (NegativeInfinite a) where - arbitrary = fmap (maybe NegativeInfinity NegFinite) arbitrary - -instance Arbitrary a => Arbitrary (Infinite a) where - arbitrary = fmap (either (bool Positive Negative) Finite) arbitrary - -instance Arbitrary a => Arbitrary (Vector.Vector a) where - arbitrary = fmap Vector.fromList arbitrary - shrink = fmap Vector.fromList . shrink . Vector.toList - -instance Testable (Either String String) where - property = either (`counterexample` False) (const (property True)) - -instance Arbitrary (f (g a)) => Arbitrary (Matrix f g a) where - arbitrary = fmap Matrix arbitrary - shrink (Matrix xs) = fmap Matrix (shrink xs) + defaultMain $ testGroup "Tests" [typeclassTests, semiringLawTests] diff --git a/test/Vectors.hs b/test/Vectors.hs new file mode 100644 --- /dev/null +++ b/test/Vectors.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Vectors where + +import Test.QuickCheck +import Test.SmallCheck.Series + +import Data.Functor.Classes + +import CompUtils +import Control.Applicative +import Data.Foldable + +data V0 a = + V0 + deriving (Eq,Ord,Show,Functor,Foldable,Traversable) + +data V1 a = + V1 a + deriving (Eq,Ord,Show,Functor,Foldable,Traversable) + +data V2 a = + V2 a a + deriving (Eq,Ord,Show,Functor,Foldable,Traversable) + +data V3 a = + V3 a a a + deriving (Eq,Ord,Show,Functor,Foldable,Traversable) + +data V4 a = + V4 a a a a + deriving (Eq,Ord,Show,Functor,Foldable,Traversable) + +data V5 a = + V5 a a a a a + deriving (Eq,Ord,Show,Functor,Foldable,Traversable) + +instance Applicative V0 where + pure _ = V0 + V0 <*> V0 = V0 + +instance Applicative V1 where + pure = V1 + V1 f <*> V1 x = V1 (f x) + +instance Applicative V2 where + pure x = V2 x x + V2 f1 f2 <*> V2 x1 x2 = V2 (f1 x1) (f2 x2) + +instance Applicative V3 where + pure x = V3 x x x + V3 f1 f2 f3 <*> V3 x1 x2 x3 = V3 (f1 x1) (f2 x2) (f3 x3) + +instance Applicative V4 where + pure x = V4 x x x x + V4 f1 f2 f3 f4 <*> V4 x1 x2 x3 x4 = V4 (f1 x1) (f2 x2) (f3 x3) (f4 x4) + +instance Applicative V5 where + pure x = V5 x x x x x + V5 f1 f2 f3 f4 f5 <*> V5 x1 x2 x3 x4 x5 = + V5 (f1 x1) (f2 x2) (f3 x3) (f4 x4) (f5 x5) + +instance Arbitrary a => + Arbitrary (V0 a) where + arbitrary = sequenceA (pure arbitrary) + shrink V0 = [] + +instance Arbitrary a => + Arbitrary (V1 a) where + arbitrary = sequenceA (pure arbitrary) + shrink (V1 x) = map V1 (shrink x) + +instance Arbitrary a => + Arbitrary (V2 a) where + arbitrary = sequenceA (pure arbitrary) + shrink (V2 x y) = + [ V2 x' y + | x' <- shrink x ] ++ + [ V2 x y' + | y' <- shrink y ] + +instance Arbitrary a => + Arbitrary (V3 a) where + arbitrary = sequenceA (pure arbitrary) + shrink (V3 x y z) = + [ V3 x' y z + | x' <- shrink x ] ++ + [ V3 x y' z + | y' <- shrink y ] ++ + [ V3 x y z' + | z' <- shrink z ] + +instance Arbitrary a => + Arbitrary (V4 a) where + arbitrary = sequenceA (pure arbitrary) + shrink (V4 w x y z) = + [ V4 w' x y z + | w' <- shrink w ] ++ + [ V4 w x' y z + | x' <- shrink x ] ++ + [ V4 w x y' z + | y' <- shrink y ] ++ + [ V4 w x y z' + | z' <- shrink z ] + +instance Arbitrary a => + Arbitrary (V5 a) where + arbitrary = sequenceA (pure arbitrary) + shrink (V5 v w x y z) = + [ V5 v' w x y z + | v' <- shrink v ] ++ + [ V5 v w' x y z + | w' <- shrink w ] ++ + [ V5 v w x' y z + | x' <- shrink x ] ++ + [ V5 v w x y' z + | y' <- shrink y ] ++ + [ V5 v w x y z' + | z' <- shrink z ] + +instance Serial m a => Serial m (V0 a) where + series = cons0 V0 + +instance Serial m a => Serial m (V1 a) where + series = cons1 V1 + +instance Serial m a => Serial m (V2 a) where + series = cons2 V2 + +instance Serial m a => Serial m (V3 a) where + series = cons3 V3 + +instance Serial m a => Serial m (V4 a) where + series = cons4 V4 + +instance Serial m a => + Serial m (V5 a) where + series = + decDepth $ V5 <$> series <~> series <~> series <~> series <~> series + +instance Eq1 V0 where + liftEq eq = and .: liftA2 eq + +instance Eq1 V1 where + liftEq eq = and .: liftA2 eq + +instance Eq1 V2 where + liftEq eq = and .: liftA2 eq + +instance Eq1 V3 where + liftEq eq = and .: liftA2 eq + +instance Eq1 V4 where + liftEq eq = and .: liftA2 eq + +instance Eq1 V5 where + liftEq eq = and .: liftA2 eq + +instance Ord1 V0 where + liftCompare cmp = fold .: liftA2 cmp + +instance Ord1 V1 where + liftCompare cmp = fold .: liftA2 cmp + +instance Ord1 V2 where + liftCompare cmp = fold .: liftA2 cmp + +instance Ord1 V3 where + liftCompare cmp = fold .: liftA2 cmp + +instance Ord1 V4 where + liftCompare cmp = fold .: liftA2 cmp + +instance Ord1 V5 where + liftCompare cmp = fold .: liftA2 cmp + +instance Show1 V0 where + liftShowsPrec _ sl _ = sl . toList + +instance Show1 V1 where + liftShowsPrec _ sl _ = sl . toList + +instance Show1 V2 where + liftShowsPrec _ sl _ = sl . toList + +instance Show1 V3 where + liftShowsPrec _ sl _ = sl . toList + +instance Show1 V4 where + liftShowsPrec _ sl _ = sl . toList + +instance Show1 V5 where + liftShowsPrec _ sl _ = sl . toList