From 2d92440fa5452638c9d757faa308f4d4f3b29648 Mon Sep 17 00:00:00 2001 From: Tim Pierson Date: Thu, 26 May 2016 22:11:49 -0400 Subject: [PATCH 01/20] added accelerate-cuda and extra-deps --- stack.yaml | 7 +++++++ subhask.cabal | 3 ++- 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/stack.yaml b/stack.yaml index 103d0d2..a9364e9 100644 --- a/stack.yaml +++ b/stack.yaml @@ -5,5 +5,12 @@ extra-deps: [ gamma-0.9.0.2 , continued-fractions-0.9.1.1 , converge-0.1.0.1 + , accelerate-cuda-0.15.1.1 + , cuda-0.7.0.0 + , language-c-quote-0.11.6.2 + , mainland-pretty-0.4.1.4 + , exception-mtl-0.4.0.1 + , symbol-0.2.4 + ] resolver: lts-5.9 diff --git a/subhask.cabal b/subhask.cabal index 4b3c485..64cdded 100644 --- a/subhask.cabal +++ b/subhask.cabal @@ -139,6 +139,7 @@ library erf , gamma , hmatrix , + accelerate-cuda , -- compatibility control flow mtl , @@ -158,7 +159,7 @@ library semigroups , bytes , approximate , - lens + lens default-language: Haskell2010 From ea81340cac183d99023a6f1322e42776a9d789e6 Mon Sep 17 00:00:00 2001 From: timpierson Date: Sat, 4 Jun 2016 19:32:06 -0400 Subject: [PATCH 02/20] initial implementations of Accelerate Vectors are working --- src/SubHask/Algebra/Vector.hs | 142 ++++++++++++++++++++++++++++++++++ stack.yaml | 20 +++-- subhask.cabal | 2 + 3 files changed, 153 insertions(+), 11 deletions(-) diff --git a/src/SubHask/Algebra/Vector.hs b/src/SubHask/Algebra/Vector.hs index 9c7eb92..bb3d080 100644 --- a/src/SubHask/Algebra/Vector.hs +++ b/src/SubHask/Algebra/Vector.hs @@ -18,6 +18,12 @@ module SubHask.Algebra.Vector ( SVector (..) , UVector (..) , ValidUVector + , ACCVector (..) + , Backend (..) + , ValidBackend + , mkAccVector + , runAccVector + , mkAccVectorFromList , Unbox , type (+>) , SMatrix @@ -49,6 +55,10 @@ import qualified Data.Vector.Storable as VS import qualified Numeric.LinearAlgebra as HM import qualified Numeric.LinearAlgebra.HMatrix as HM import qualified Numeric.LinearAlgebra.Data as HM +import qualified Data.Array.Accelerate as A +import qualified Data.Array.Accelerate.Interpreter as I +import qualified Data.Array.Accelerate.CUDA as CUDA + import qualified Prelude as P import SubHask.Algebra @@ -62,6 +72,14 @@ import Data.Csv (FromRecord,FromField,parseRecord) import System.IO.Unsafe import Unsafe.Coerce + +data Backend + = Interpreter + | CUDA + -- | LLVM + -- | Repa + + -- LLVM has a haskell SoC project slated, so check back in 60 days -------------------------------------------------------------------------------- -- rewrite rules for faster static parameters -- @@ -1497,6 +1515,130 @@ instance -------------------------------------------------------------------------------- +-- | Accelerate based Vector +-- | A.Acc is an accelreate computation, A.Array A.DIM1 a is a one dimensional array + +newtype ACCVector (bknd::Backend) (n::k) a = ACCVector (A.Acc (A.Array A.DIM1 a)) + +type instance Scalar (ACCVector bknd n r) = Scalar r +type instance Logic (ACCVector bknd n r) = Logic r + +type instance ACCVector bknd m a >< b = Tensor_ACCVector (ACCVector bknd m a) b +type family Tensor_ACCVector a b where + Tensor_ACCVector (ACCVector bknd n r1) (ACCVector bknd m r2) = ACCVector bknd n r1 +> ACCVector bknd m r2 + Tensor_ACCVector (ACCVector bknd n r1) r1 = ACCVector bknd n r1 -- (r1> [a] -> ACCVector bknd (n::Symbol) a +mkAccVectorFromList l = let + len = P.length l + in ACCVector (A.use (A.fromList (A.Z A.:.len) l)) + +mkAccVector :: (A.Elt a, ValidSVector (n::Symbol) a) => SVector (n::Symbol) a -> ACCVector (bknd::Backend) (n::Symbol) a +mkAccVector v @(SVector_Dynamic fp off n) = let + arr = A.fromList (A.Z A.:. n) $ unsafeInlineIO $ go (n-1) [] + go (-1) xs = return $ xs + go i xs = withForeignPtr fp $ \p -> do + x <- peekElemOff p (off+i) + go (i-1) (x:xs) + in ACCVector (A.use arr) + + +-- acc2SVector fails with: +-- Could not deduce (Scalar a1 ~ Scalar (Scalar a1)) +-- from the context (ValidACCVector n a) +-- bound by the type signature for +-- acc2SVector :: ValidACCVector n a => +-- Backend -> ACCVector n a -> SVector n a + +-- acc2SVector :: ValidACCVector (n::Symbol) a => Backend -> ACCVector (n::Symbol) a -> SVector (n::Symbol) a +-- acc2SVector bknd v = unsafeToModule (runAccVector bknd v) :: SVector (n::Symbol) a + + +class ValidBackend (bknd::Backend) where + -- runAccVector :: (ValidACCVector bknd n a, IsScalar a) => ACCVector (bknd::Backend) n a -> SVector n a + runAccVector :: (ValidACCVector bknd n a, IsScalar a) => ACCVector (bknd::Backend) n a -> [a] + +instance ValidBackend Interpreter where + -- runAccVector (ACCVector a) = unsafeToModule (A.toList (I.run a)) :: SVector n a + runAccVector (ACCVector a) = A.toList (I.run a) + +instance ValidBackend CUDA where + -- runAccVector (ACCVector a) = unsafeToModule (A.toList (CUDA.run a)) :: SVector n a + runAccVector (ACCVector a) = A.toList (CUDA.run a) + +-- we need an is mutable instance even though Acc types are not mutable, how to handle this? +instance Prim a => IsMutable (ACCVector (bknd::Backend) (n::Symbol) a) + +instance (Monoid r, ValidACCVector bknd n r) => Semigroup (ACCVector (bknd::Backend) (n::Symbol) r) where + {-# INLINE (+) #-} + (+) (ACCVector a1) (ACCVector a2) = ACCVector (A.zipWith (P.+) a1 a2) + +-- no worky +-- "Couldn't match type ‘r’ with ‘Actor r’"" +-- instance (Action r, Semigroup r, Prim r) => Action (ACCVector (bknd::Backend) (n::Symbol) r) where +-- {-# INLINE (.+) #-} +-- (.+) (ACCVector v) r = ACCVector (A.map (\x -> x P.+ (A.constant r)) v) + +instance (Monoid r, Cancellative r, ValidACCVector bknd n r) => Cancellative (ACCVector (bknd::Backend) (n::Symbol) r) where + {-# INLINE (-) #-} + (-) (ACCVector a1) (ACCVector a2) = ACCVector (A.zipWith (P.-) a1 a2) + +instance (Monoid r, ValidACCVector bknd n r) => Monoid (ACCVector (bknd::Backend) (n::Symbol) r) where + {-# INLINE zero #-} + zero = mkAccVectorFromList [0] + +instance (Group r, ValidACCVector bknd n r) => Group (ACCVector (bknd::Backend) (n::Symbol) r) where + {-# INLINE negate #-} + negate v = negate v + +instance (Monoid r, Abelian r, ValidACCVector bknd n r) => Abelian (ACCVector (bknd::Backend) (n::Symbol) r) + +instance (FreeModule r, ValidACCVector bknd n r, IsScalar r) => FreeModule (ACCVector (bknd::Backend) (n::Symbol) r) where + {-# INLINE (.*.) #-} + (.*.) (ACCVector a1) (ACCVector a2) = ACCVector (A.zipWith (P.*) a1 a2) + +instance (Module r, ValidACCVector bknd n r, IsScalar r) => Module (ACCVector (bknd::Backend) (n::Symbol) r) where + {-# INLINE (.*) #-} + (.*) (ACCVector v) r = ACCVector (A.map (\x -> x P.* (A.constant r)) v) + +instance (VectorSpace r, ValidACCVector bknd n r, IsScalar r, A.IsFloating r) => VectorSpace (ACCVector (bknd::Backend) (n::Symbol) r) where + {-# INLINE (./) #-} + (./) (ACCVector v) r = ACCVector (A.map (\x -> x P./(A.constant r)) v) + + {-# INLINE (./.) #-} + (./.) (ACCVector a1) (ACCVector a2) = ACCVector (A.zipWith (P./) a1 a2) + + +newtype ACCMatrix (bknd::Backend) (m::k1) (n::k2) a = ACCMatrix (A.Acc (A.Array A.DIM2 a)) + +data ACCMatrix' b (m::k1) (n::k2) r where + Id :: {-#UNPACK#-}!r -> ACCMatrix' b m m r + Diag :: {-#UNPACK#-}!(ACCVector b m r) -> ACCMatrix' b m m r + Mat :: {-#UNPACK#-}!(ACCMatrix b m n r) -> ACCMatrix' b m n r + + +type instance Scalar (ACCMatrix' b r m n) = Scalar r +type instance (ACCMatrix' b r m n)> [a] -> ACCMatrix' bknd n m a +mkAccMatrixFromList l = let + m = P.length l + n = P.length l ! 0 + in Mat (ACCMatrix (A.use (A.fromList (A.Z A.:.m A.:.n) l))) + + + type MatrixField r = ( IsScalar r , VectorSpace r diff --git a/stack.yaml b/stack.yaml index a9364e9..c1bcadf 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,15 +2,13 @@ flags: {} packages: - '.' extra-deps: - [ gamma-0.9.0.2 - , continued-fractions-0.9.1.1 - , converge-0.1.0.1 - , accelerate-cuda-0.15.1.1 - , cuda-0.7.0.0 - , language-c-quote-0.11.6.2 - , mainland-pretty-0.4.1.4 - , exception-mtl-0.4.0.1 - , symbol-0.2.4 - - ] +- accelerate-cuda-0.15.1.1 +- continued-fractions-0.9.1.1 +- converge-0.1.0.1 +- cuda-0.7.0.0 +- exception-mtl-0.4.0.1 +- gamma-0.9.0.2 +- language-c-quote-0.11.6.2 +- mainland-pretty-0.4.1.4 +- symbol-0.2.4 resolver: lts-5.9 diff --git a/subhask.cabal b/subhask.cabal index 64cdded..4e24de6 100644 --- a/subhask.cabal +++ b/subhask.cabal @@ -139,7 +139,9 @@ library erf , gamma , hmatrix , + accelerate , accelerate-cuda , + cuda , -- compatibility control flow mtl , From a31f8c0e1bf3ebcab27177668e2be51b7689b2c4 Mon Sep 17 00:00:00 2001 From: timpierson Date: Wed, 8 Jun 2016 23:37:01 -0400 Subject: [PATCH 03/20] finished initial implementation --- examples/example0005-accelerate_backend.lhs | 42 ++++ src/SubHask/Algebra/Accelerate.hs | 41 ++++ src/SubHask/Algebra/AccelerateBackend.hs | 10 + src/SubHask/Algebra/Matrix.hs | 217 +++++++++++++++++- src/SubHask/Algebra/Vector.hs | 233 +++++++++++++------- stack.yaml | 16 +- subhask.cabal | 4 + 7 files changed, 480 insertions(+), 83 deletions(-) create mode 100644 examples/example0005-accelerate_backend.lhs create mode 100644 src/SubHask/Algebra/Accelerate.hs create mode 100644 src/SubHask/Algebra/AccelerateBackend.hs diff --git a/examples/example0005-accelerate_backend.lhs b/examples/example0005-accelerate_backend.lhs new file mode 100644 index 0000000..adca12d --- /dev/null +++ b/examples/example0005-accelerate_backend.lhs @@ -0,0 +1,42 @@ + +> {-# LANGUAGE NoImplicitPrelude #-} +> {-# LANGUAGE RebindableSyntax #-} +> {-# LANGUAGE OverloadedLists #-} +> {-# LANGUAGE TypeOperators #-} +> {-# LANGUAGE FlexibleContexts #-} +> {-# LANGUAGE GADTs #-} +> {-# LANGUAGE DataKinds #-} +> import qualified Prelude as P +> import SubHask +> import SubHask.Algebra.Vector (ACCVector, UVector, mkAccVector, mkAccVectorFromList) +> import SubHask.Algebra.Matrix (ACCMatrix, Matrix, unsafeToModuleM, mkAccMatrixFromList, mkAccMatrixFromMatrix) +> import SubHask.Algebra.Accelerate (ValidBackend(..)) +> import SubHask.Algebra.AccelerateBackend (Backend(..)) +> import System.IO +> +> v :: ACCVector Interpreter "a" Double +> v = mkAccVectorFromList [0..5] +> +> v' :: ACCVector Interpreter "a" Double +> v' = mkAccVectorFromList [0..5] +> +> +> mmat :: Matrix (UVector "v" Double) Double "a" "b" +> mmat = unsafeToModuleM 2 [0..5] +> +> m :: ACCMatrix Interpreter (ACCVector Interpreter "v" Double ) "a" "b" Double +> m = mkAccMatrixFromMatrix mmat +> +> mm :: ACCMatrix Interpreter (ACCVector Interpreter "v" Double ) "a" "b" Double +> mm = mkAccMatrixFromList 2 [0,1,2,3,4,5,6,7,8,9,10] +> +> main :: IO () +> main = do +> putStrLn $ "v = " ++ show (runAccVector v) +> putStrLn $ "v' = " ++ show (runAccVector v') +> putStrLn $ "v + v = " ++ show (runAccVector (v + v)) +> putStrLn $ "v + v - v = " ++ show (runAccVector (v + v - v')) +> putStrLn $ "v * v / v = " ++ show (runAccVector (v .*. v ./. v')) +> putStrLn $ "v' * 2 = " ++ show (runAccVector (v' .* 2)) +> putStrLn $ "m + m = " ++ show (runAccMatrix (m + m)) +> putStrLn $ "m + mm = " ++ show (runAccMatrix (m + mm)) diff --git a/src/SubHask/Algebra/Accelerate.hs b/src/SubHask/Algebra/Accelerate.hs new file mode 100644 index 0000000..a2994be --- /dev/null +++ b/src/SubHask/Algebra/Accelerate.hs @@ -0,0 +1,41 @@ +module SubHask.Algebra.Accelerate +( + ValidBackend(..) + -- , acc2SVector +) +where + import SubHask.Algebra.AccelerateBackend (Backend(..)) + import SubHask.Algebra.Vector + import SubHask.Algebra.Matrix + import SubHask.Category + import SubHask.Compatibility.Base + import SubHask.SubType + import qualified Data.Array.Accelerate as A + import qualified Data.Array.Accelerate.Interpreter as I + import qualified Data.Array.Accelerate.CUDA as CUDA + -- import qualified Data.Array.Accelerate.LLVM as LLVM + + --needs to reside in the vector module but also needs acces to ValidBackend + -- acc2SVector :: ValidACCVector (b::Backend) n a => ACCVector (b::Backend) n a -> SVector n a + -- acc2SVector (ACCVector v) = unsafeToModule $ A.toList (ACCVector (runAccVector v)) :: SVector n a + + + class ValidBackend (b::Backend) where + runAccVector :: (ValidACCVector (b::Backend) n a, A.IsScalar a) => ACCVector (b::Backend) n a -> [a] + runAccMatrix :: (ValidACCMatrix (b::Backend) v m n r, A.IsScalar a, A.Elt a) => ACCMatrix (b::Backend) v n m a -> [a] + + instance ValidBackend Interpreter where + runAccVector (ACCVector a) = A.toList (I.run a) + runAccMatrix (ACCMatrix a) = A.toList (I.run a) + + instance ValidBackend CUDA where + runAccVector (ACCVector a) = A.toList (CUDA.run a) + runAccMatrix (ACCMatrix a) = A.toList (CUDA.run a) + + -- instance ValidBackend LLVM where + -- runAccVector (ACCVector a) = A.toList (LLVM.run a) + -- runAccMatrix (ACCMatrix a) = A.toList (LLVM.run a) + + -- instance ValidBackend Repa where + -- runAccVector (ACCVector a) = A.toList (Repa.run a) + -- runAccMatrix (ACCMatrix a) = A.toList (Repa.run a) diff --git a/src/SubHask/Algebra/AccelerateBackend.hs b/src/SubHask/Algebra/AccelerateBackend.hs new file mode 100644 index 0000000..6100486 --- /dev/null +++ b/src/SubHask/Algebra/AccelerateBackend.hs @@ -0,0 +1,10 @@ +module SubHask.Algebra.AccelerateBackend +( + Backend(..) +) +where + data Backend + = Interpreter + | CUDA + | LLVM + -- LLVM has an SoC project slated, so check back in 60 days for non-parial functionality diff --git a/src/SubHask/Algebra/Matrix.hs b/src/SubHask/Algebra/Matrix.hs index 58a11ae..530cbd5 100644 --- a/src/SubHask/Algebra/Matrix.hs +++ b/src/SubHask/Algebra/Matrix.hs @@ -7,12 +7,17 @@ module SubHask.Algebra.Matrix ( Matrix (..) , unsafeToModuleM , ValidMatrix + , ACCMatrix (..) + , ValidACCMatrix + , ACCMatrix'(..) , mmult , transpose , row , col , (!!) , Matrix'(..) + , mkAccMatrixFromList + , mkAccMatrixFromMatrix ) where @@ -24,6 +29,13 @@ import SubHask.Algebra import SubHask.Category import SubHask.Internal.Prelude +import qualified Data.Array.Accelerate as A +import qualified Data.Array.Accelerate.CUDA as CUDA +import qualified Data.Array.Accelerate.Interpreter as I +import SubHask.Algebra.Vector (ACCVector) +import SubHask.Algebra.AccelerateBackend (Backend) +import qualified Prelude as P + data family Matrix vect r (a::k) (b::k) type ValidMatrix vect r = @@ -36,7 +48,7 @@ type ValidMatrix vect r = type instance Scalar (Matrix vect r m n) = Scalar r type instance Logic (Matrix vect r m n) = Logic r -type instance Matrix vect r m n >< a = Matrix vect (r>< a = Matrix vect (r> IsMutable (ACCMatrix bknd v m n r) + + + + -- name collision, how to instance these? + -- {-# INLINE rowLength #-} + -- rowLength :: ACCMatrix b v m n r -> Integer + -- rowLength arr = snd (A.arrayShape arr) + -- {-# INLINE colLength #-} + -- colLength :: ACCMatrix b v m n r -> Integer + -- colLength arr = fst (A.arrayShape arr) + -- {-# INLINE (!!) #-} + -- (!!) (ACCMatrix v) (i,j) = v A.! A.index2 (i,j) + + +-- algebra +instance + (P.Num (A.Exp r), Prim r, Monoid r, ValidACCMatrix b v m n r) => + Semigroup (ACCMatrix b v m n r) where + {-# INLINE (+) #-} + (+) (ACCMatrix m1) (ACCMatrix m2) = ACCMatrix (A.zipWith (P.+) m1 m2) + +instance + (P.Num (A.Exp r), Monoid r, Cancellative r, Prim r, ValidACCMatrix b v m n r) + => Cancellative (ACCMatrix b v (n::Symbol) (m::Symbol) r) where + {-# INLINE (-) #-} ; + (-) (ACCMatrix m1) (ACCMatrix m2) = ACCMatrix (A.zipWith (P.-) m1 m2) + +--Need the correct dim for this fill +instance + (P.Num (A.Exp r), Monoid r, Prim r, ValidACCMatrix b v m n r) => + Monoid (ACCMatrix b v (n::Symbol) (m::Symbol) r) where + -- {-# INLINE zero #-} + -- zero = ACCMatrix (A.fill (A.index2 2 4) 0) + +instance + (Monoid r, Abelian r, Prim r, ValidACCMatrix b v m n r) => + Abelian (ACCMatrix b v (n::Symbol) (m::Symbol) r) + +instance + (Module r, Prim r, ValidACCMatrix b v m n r) => + Module (ACCMatrix b v (n::Symbol) (m::Symbol) r) where + {-# INLINE (.*) #-} ; (.*) (ACCMatrix v) r = ACCMatrix( A.map (\x -> x P.* A.constant r) v) + +type instance Actor (ACCMatrix b v (n::Symbol) (m::Symbol) r) = Actor r + + +instance -- had to add Monoid r, to this instance + (P.Num (A.Exp r), Group r, Prim r, ValidACCMatrix b v m n r) => + Group (ACCMatrix b v (n::Symbol) (m::Symbol) r) where + {-# INLINE negate #-} + negate (ACCMatrix v) = ACCMatrix( A.map (\x -> x P.* A.constant (P.negate 1)) v) + +--Could not deduce (r ~ Actor r) +instance + (Action r, Semigroup r, Prim r, ValidACCMatrix b v m n r) => + Action (ACCMatrix b v (n::Symbol) (m::Symbol) r) + -- where + -- {-# INLINE (.+) #-} + -- (.+) (ACCMatrix v) r = ACCMatrix( A.map (\x -> x P.+ A.constant r) v) +instance + (FreeModule r, Prim r, ValidACCMatrix b v m n r) => + FreeModule (ACCMatrix b v (n::Symbol) (m::Symbol) r) where + {-# INLINE (.*.) #-} + (.*.) (ACCMatrix v1) (ACCMatrix v2) = ACCMatrix(A.zipWith (P.*) v1 v2) + ones = undefined + +instance + (P.Fractional (A.Exp r), VectorSpace r, Prim r, ValidACCMatrix b v m n r) => + VectorSpace (ACCMatrix b v (n::Symbol) (m::Symbol) r) where + {-# INLINE (./) #-} + (./) (ACCMatrix v) r = ACCMatrix(A.map (\x -> x A./ (A.constant r)) v) + {-# INLINE (./.) #-} + (./.) (ACCMatrix v1) (ACCMatrix v2) = ACCMatrix(A.zipWith (A./) v1 v2) + +instance + (ValidACCMatrix b v m n r, Monoid r, ValidLogic r, Prim r, IsScalar r) + => IxContainer (ACCMatrix b v (n::Symbol) (m::Symbol) r) where + + -- {-# INLINE (!) #-} + -- (!) (ACCMatrix m) i = let + -- l = A.size m + -- in ACCMatrix m!!(i `div` l, i `mod` l) + +-- {-# INLINE row #-} +-- row :: (ValidACCMatrix b v m n r +-- ) => ACCMatrix b v (n::Symbol) (m::Symbol) r -> Int -> vect +-- row m i = A.slice m (A.Z A.:. (i::Int) A.:. A.All) +-- +-- {-# INLINE col #-} +-- col :: +-- ( ValidACCMatrix b v m n r +-- ) => ACCMatrix b v (n::Symbol) (m::Symbol) r -> Int -> vect +-- col m j = A.slice m (A.Z A.:. A.All A.:. (j::Int)) +-- +-- +-- --taken from http://www.cse.unsw.edu.au/~chak/papers/repa.pdf +-- {-# INLINE mmult #-} +-- mmult :: +-- ( ValidACCMatrix b v m n r +-- ) +-- => ACCMatrix b v (n::Symbol) (x0::Symbol) r +-- -> ACCMatrix b v (x0::Symbol) (m::Symbol) r +-- -> ACCMatrix b v (n::Symbol) (m::Symbol) r +-- mmult arr brr = A.sum (A.zipWith (*) arrRepl brrRepl) +-- where +-- trr = A.transpose brr +-- arrRepl = A.replicate (A.Z A.:. A.All A.:. colsB A.:. A.All) arr +-- brrRepl = A.replicate (A.Z A.:. rowsA A.:. A.All A.:. A.All) trr +-- (A.Z A.:. colsA A.:. rowsA) = A.shape arr +-- (A.Z A.:. colsB A.:. rowsB) = A.shape brr +-- +-- {-# INLINE transpose #-} +-- transpose :: +-- ( ValidACCMatrix b v m n r +-- ) +-- => ACCMatrix b v (m::Symbol) (n::Symbol) r +-- -> ACCMatrix b v (m::Symbol) (n::Symbol) r +-- transpose m = A.transpose m + +data ACCMatrix' b v (m::Symbol) (n::Symbol) r where + ACCZero :: + (ValidACCMatrix b v m n r) => + ACCMatrix' b v (m::Symbol) (n::Symbol) r + + ACCId :: + (ValidACCMatrix b v m n r) => + {-#UNPACK#-}!(Scalar r) -> ACCMatrix' b v (m::Symbol) (n::Symbol) r + + ACCMat :: + (ValidACCMatrix b v m n r) => + {-#UNPACK#-}!(ACCMatrix b v (m::Symbol) (n::Symbol) r) + -> ACCMatrix' b v (m::Symbol) (n::Symbol) r + +type instance Scalar (ACCMatrix' b v (m::Symbol) (n::Symbol) r) = Scalar r +type instance Logic (ACCMatrix' b v (m::Symbol) (n::Symbol) r) = Bool + +type instance ACCMatrix' b v (m::Symbol) (n::Symbol) r >< n = + ACCTensor_Linear (ACCMatrix' b v (m::Symbol) (n::Symbol) r ) n +type family ACCTensor_Linear m n where + ACCTensor_Linear (ACCMatrix' b v (m::Symbol) (n::Symbol) r) c = + ACCMatrix' b v (m::Symbol) (n::Symbol) r + +-- Categor failes with: +-- The first argument of ‘Category’ should have kind ‘k0 -> k0 -> *’, +-- but ‘ACCMatrix' b v (m :: Symbol) (n :: Symbol) r’ has kind ‘*’ +-- In the instance declaration for +-- ‘Category (ACCMatrix' b v (m :: Symbol) (n :: Symbol) r)’ + +-- instance Category (ACCMatrix' b v (m::Symbol) (n::Symbol) r ) where +-- type ValidCategory (ACCMatrix' b v (m::Symbol) (n::Symbol) r ) o = ValidACCMatrix b v m n r + + -- id = Id 1 + -- + -- Zero . Zero = Zero + -- Zero . (Id _ ) = Zero + -- Zero . (Mat _ ) = Zero + -- + -- (Id _ ) . Zero = Zero + -- (Id r1) . (Id r2) = Id $ r1 * r2 + -- (Id r ) . (Mat m ) = Mat $ m .* r + -- + -- (Mat _) . Zero = Zero + -- (Mat m ) . (Id r ) = Mat $ m .* r + -- (Mat m1) . (Mat m2) = Mat $ mmult m2 m1 + +mkAccMatrixFromList :: A.Elt a => Int -> [a] -> ACCMatrix b v m n a +mkAccMatrixFromList m l = let + ln = P.length l + n = ln `div` m + in ACCMatrix (A.use (A.fromList (A.Z A.:.m A.:.n) l)) + +--FIXME: use accelerate-io functions https://github.com/AccelerateHS/accelerate-io/tree/master/Data/Array/Accelerate/IO +mkAccMatrixFromMatrix :: (ValidMatrix vect r, A.Elt r) => Matrix vect r (m::Symbol) (n::Symbol) -> ACCMatrix b v m n r +mkAccMatrixFromMatrix mat@(Matrix_Dynamic vect ln) = + mkAccMatrixFromList cln l + where + cln = colLength mat + l = P.foldr (\x xs -> vect!x : xs) [] [0..(ln * cln)-1] diff --git a/src/SubHask/Algebra/Vector.hs b/src/SubHask/Algebra/Vector.hs index b8945ab..f3fca06 100644 --- a/src/SubHask/Algebra/Vector.hs +++ b/src/SubHask/Algebra/Vector.hs @@ -18,16 +18,16 @@ module SubHask.Algebra.Vector ( SVector (..) , UVector (..) , ValidUVector + , ValidACCVector + , ValidSVector , ACCVector (..) - , Backend (..) - , ValidBackend - , mkAccVector - , runAccVector - , mkAccVectorFromList , Unbox , type (+>) , SMatrix , unsafeMkSMatrix + , mkAccVector + , mkAccVectorFromList + , unsafeToModule -- * Debug , safeNewByteArray @@ -56,12 +56,13 @@ import qualified Numeric.LinearAlgebra as HM import qualified Numeric.LinearAlgebra.HMatrix as HM import qualified Numeric.LinearAlgebra.Data as HM import qualified Data.Array.Accelerate as A -import qualified Data.Array.Accelerate.Interpreter as I -import qualified Data.Array.Accelerate.CUDA as CUDA + + import qualified Prelude as P import SubHask.Algebra +import SubHask.Algebra.AccelerateBackend (Backend) import SubHask.Category import SubHask.Compatibility.Base import SubHask.Internal.Prelude @@ -72,14 +73,6 @@ import Data.Csv (FromRecord,FromField,parseRecord) import System.IO.Unsafe import Unsafe.Coerce - -data Backend - = Interpreter - | CUDA - -- | LLVM - -- | Repa - - -- LLVM has a haskell SoC project slated, so check back in 60 days -------------------------------------------------------------------------------- -- rewrite rules for faster static parameters -- @@ -1538,80 +1531,44 @@ type instance SetElem (ACCVector (bknd::Backend) n r) b = ACCVector (bknd::Backe type instance Actor (ACCVector (bknd::Backend) n r) = Actor r -mkAccVectorFromList :: A.Elt a => [a] -> ACCVector bknd (n::Symbol) a -mkAccVectorFromList l = let - len = P.length l - in ACCVector (A.use (A.fromList (A.Z A.:.len) l)) - -mkAccVector :: (A.Elt a, ValidSVector (n::Symbol) a) => SVector (n::Symbol) a -> ACCVector (bknd::Backend) (n::Symbol) a -mkAccVector v @(SVector_Dynamic fp off n) = let - arr = A.fromList (A.Z A.:. n) $ unsafeInlineIO $ go (n-1) [] - go (-1) xs = return $ xs - go i xs = withForeignPtr fp $ \p -> do - x <- peekElemOff p (off+i) - go (i-1) (x:xs) - in ACCVector (A.use arr) - - --- acc2SVector fails with: --- Could not deduce (Scalar a1 ~ Scalar (Scalar a1)) --- from the context (ValidACCVector n a) --- bound by the type signature for --- acc2SVector :: ValidACCVector n a => --- Backend -> ACCVector n a -> SVector n a - --- acc2SVector :: ValidACCVector (n::Symbol) a => Backend -> ACCVector (n::Symbol) a -> SVector (n::Symbol) a --- acc2SVector bknd v = unsafeToModule (runAccVector bknd v) :: SVector (n::Symbol) a - - -class ValidBackend (bknd::Backend) where - -- runAccVector :: (ValidACCVector bknd n a, IsScalar a) => ACCVector (bknd::Backend) n a -> SVector n a - runAccVector :: (ValidACCVector bknd n a, IsScalar a) => ACCVector (bknd::Backend) n a -> [a] - -instance ValidBackend Interpreter where - -- runAccVector (ACCVector a) = unsafeToModule (A.toList (I.run a)) :: SVector n a - runAccVector (ACCVector a) = A.toList (I.run a) - -instance ValidBackend CUDA where - -- runAccVector (ACCVector a) = unsafeToModule (A.toList (CUDA.run a)) :: SVector n a - runAccVector (ACCVector a) = A.toList (CUDA.run a) - --- we need an is mutable instance even though Acc types are not mutable, how to handle this? +-- we need an is mutable instance even though Acc types arent made mutable or immutable, how to handle this? instance Prim a => IsMutable (ACCVector (bknd::Backend) (n::Symbol) a) -instance (Monoid r, ValidACCVector bknd n r) => Semigroup (ACCVector (bknd::Backend) (n::Symbol) r) where + +--Not sure about all the Prelude Contexts necessary in these instances +instance (P.Num (A.Exp r), Monoid r, ValidACCVector bknd n r) => Semigroup (ACCVector (bknd::Backend) (n::Symbol) r) where {-# INLINE (+) #-} (+) (ACCVector a1) (ACCVector a2) = ACCVector (A.zipWith (P.+) a1 a2) --- no worky +instance (Action r, Semigroup r, Prim r) => Action (ACCVector (bknd::Backend) (n::Symbol) r) where -- "Couldn't match type ‘r’ with ‘Actor r’"" --- instance (Action r, Semigroup r, Prim r) => Action (ACCVector (bknd::Backend) (n::Symbol) r) where --- {-# INLINE (.+) #-} --- (.+) (ACCVector v) r = ACCVector (A.map (\x -> x P.+ (A.constant r)) v) + -- {-# INLINE (.+) #-} + -- (.+) (ACCVector v) r = ACCVector (A.map (\x -> x P.+ r) v) -instance (Monoid r, Cancellative r, ValidACCVector bknd n r) => Cancellative (ACCVector (bknd::Backend) (n::Symbol) r) where +instance (P.Num (A.Exp r), Monoid r, Cancellative r, ValidACCVector bknd n r) => Cancellative (ACCVector (bknd::Backend) (n::Symbol) r) where {-# INLINE (-) #-} (-) (ACCVector a1) (ACCVector a2) = ACCVector (A.zipWith (P.-) a1 a2) -instance (Monoid r, ValidACCVector bknd n r) => Monoid (ACCVector (bknd::Backend) (n::Symbol) r) where - {-# INLINE zero #-} - zero = mkAccVectorFromList [0] +--How to get the correct dimension for this? +instance (P.Num (A.Exp r), Monoid r, ValidACCVector bknd n r) => Monoid (ACCVector (bknd::Backend) (n::Symbol) r) where + -- {-# INLINE zero #-} + -- zero = ACCVector(A.fill (A.index1 2) (A.lift 0)) -instance (Group r, ValidACCVector bknd n r) => Group (ACCVector (bknd::Backend) (n::Symbol) r) where +instance (P.Num (A.Exp r), Group r, ValidACCVector bknd n r) => Group (ACCVector (bknd::Backend) (n::Symbol) r) where {-# INLINE negate #-} negate v = negate v -instance (Monoid r, Abelian r, ValidACCVector bknd n r) => Abelian (ACCVector (bknd::Backend) (n::Symbol) r) +instance (P.Num (A.Exp r), Monoid r, Abelian r, ValidACCVector bknd n r) => Abelian (ACCVector (bknd::Backend) (n::Symbol) r) -instance (FreeModule r, ValidACCVector bknd n r, IsScalar r) => FreeModule (ACCVector (bknd::Backend) (n::Symbol) r) where +instance (P.Num (A.Exp r), FreeModule r, ValidACCVector bknd n r, IsScalar r) => FreeModule (ACCVector (bknd::Backend) (n::Symbol) r) where {-# INLINE (.*.) #-} (.*.) (ACCVector a1) (ACCVector a2) = ACCVector (A.zipWith (P.*) a1 a2) -instance (Module r, ValidACCVector bknd n r, IsScalar r) => Module (ACCVector (bknd::Backend) (n::Symbol) r) where +instance (P.Num (A.Exp r), Module r, ValidACCVector bknd n r, IsScalar r) => Module (ACCVector (bknd::Backend) (n::Symbol) r) where {-# INLINE (.*) #-} (.*) (ACCVector v) r = ACCVector (A.map (\x -> x P.* (A.constant r)) v) -instance (VectorSpace r, ValidACCVector bknd n r, IsScalar r, A.IsFloating r) => VectorSpace (ACCVector (bknd::Backend) (n::Symbol) r) where +instance (P.Fractional (A.Exp r), VectorSpace r, ValidACCVector bknd n r, IsScalar r, A.IsFloating r) => VectorSpace (ACCVector (bknd::Backend) (n::Symbol) r) where {-# INLINE (./) #-} (./) (ACCVector v) r = ACCVector (A.map (\x -> x P./(A.constant r)) v) @@ -1619,23 +1576,136 @@ instance (VectorSpace r, ValidACCVector bknd n r, IsScalar r, A.IsFloating r) => (./.) (ACCVector a1) (ACCVector a2) = ACCVector (A.zipWith (P./) a1 a2) -newtype ACCMatrix (bknd::Backend) (m::k1) (n::k2) a = ACCMatrix (A.Acc (A.Array A.DIM2 a)) +instance (P.Num (A.Exp r), FreeModule r, ValidLogic r, ValidACCVector b n r, IsScalar r) => FiniteModule (ACCVector b (n::Symbol) r) + +-- this returns an A.Exp Int and not an Int, which makes GHC complain +-- where +-- +-- {-# INLINE dim #-} +-- dim (ACCVector v) = A.length v -data ACCMatrix' b (m::k1) (n::k2) r where - Id :: {-#UNPACK#-}!r -> ACCMatrix' b m m r - Diag :: {-#UNPACK#-}!(ACCVector b m r) -> ACCMatrix' b m m r - Mat :: {-#UNPACK#-}!(ACCMatrix b m n r) -> ACCMatrix' b m n r -type instance Scalar (ACCMatrix' b r m n) = Scalar r -type instance (ACCMatrix' b r m n)> IxContainer (ACCVector b (n::Symbol) r) + where + --(!) also returns A.Exp r where r is expected ... + -- {-# INLINE (!) #-} + -- (!) (ACCVector v) i = v A.! (A.index1 (A.lift i)) + -- {-# INLINABLE toIxList #-} + -- toIxList v = P.zip [0..] $ go (dim v-1) [] + -- where + -- go (-1) xs = xs + -- go i xs = go (i-1) (v!i : xs) + -- fails on f with: + -- Couldn't match type ‘Int’ with ‘A.Exp A.DIM1’ + -- Expected type: A.Exp A.DIM1 -> A.Exp r -> A.Exp b1 + -- Actual type: Index (ACCVector b n r) + -- -> Elem (ACCVector b n r) -> b1 + -- {-# INLINABLE imap #-} + -- imap f (ACCVector v) = ACCVector (A.zipWith f (A.generate (A.shape v) P.id) v) + + type ValidElem (ACCVector b n r) e = (ClassicalLogic e, IsScalar e, FiniteModule e, ValidACCVector b n e) + + +instance (Eq r, Monoid r, ValidACCVector b n r) => Eq_ (ACCVector b (n::Symbol) r) where + -- returns A.Exp Bool . . . . + -- {-# INLINE (==) #-} + -- (ACCVector v2) == (ACCVector v1) = (A.lift v1) A.==* (A.lift v2) + +--Will acc arrays support Logic r~Bool? +instance + ( ValidACCVector b n r + , P.Num (A.Exp r) + , ExpField r + , Normed r + , Ord_ r + , Logic r~Bool + , IsScalar r + , VectorSpace r + ) => Metric (ACCVector b (n::Symbol) r) + -- where + + -- also seems to wan to deduce r ~ A.Acc (Scalar r) + -- {-# INLINE[2] distance #-} + -- distance (ACCVector v1) (ACCVector v2) = {-# SCC distance_ACCVector #-}let + -- dmag = A.zipWith (P.-) v1 v2 + -- dsq = A.zipWith (P.*) dmag dmag + -- drt = A.sqrt (A.sum dsq) + -- in drt + + --what is distanceUB tring to do? + -- {-# INLINE[2] distanceUB #-} + -- distanceUB v1 v2 ub = {-# SCC distanceUB_ACCVectorr #-}let + -- ub2 = ub*ub + -- dmag = A.zipWith (P.-) v1 v2 + -- dsq = A.zipWith (P.*) dsq dsq + -- drt = A.map A.sqrt dsq + -- in expression + +instance (VectorSpace r, ValidACCVector b n r, IsScalar r, ExpField r) => Normed (ACCVector b (n::Symbol) r) where + -- {-# INLINE size #-} + -- size (ACCVector v1) = let + -- sq = A.zipWith (P.*) v1 v1 + -- s = A.fold (P.+) 0.0 sq + -- in A.sqrt s + + +-- Could not deduce (P.Floating (A.Exp r)) +-- arising from the superclasses of an instance declaration +-- from the context (VectorSpace r, +-- ValidACCVector b n r, +-- IsScalar r, +-- ExpField r, +-- Real r) +-- bound by the instance declaration +-- instance +-- ( VectorSpace r +-- , ValidACCVector b n r +-- , IsScalar r +-- , ExpField r +-- , Real r +-- ) => Banach (ACCVector b (n::Symbol) r) + +-- Could not deduce TensorAlgebra +-- instance +-- ( VectorSpace r +-- , ValidACCVector b n r +-- , IsScalar r +-- , ExpField r +-- , Real r +-- , OrdField r +-- , MatrixField r +-- , P.Num r +-- ) => Hilbert (ACCVector b (n::Symbol) r) + -- could not deduce r ~ ... + -- where + -- {-# INLINE (<>) #-} + -- (<>) (ACCVector v1) (ACCVector v2) = A.fold (+) 0 (A.zipWith (*) v1 v2) + +--FIXME: Replace all intermediary lists with correct use of acclerate-io +mkAccVectorFromList :: A.Elt a => [a] -> ACCVector bknd (n::Symbol) a +mkAccVectorFromList l = let + len = P.length l + in ACCVector (A.use (A.fromList (A.Z A.:.len) l)) +mkAccVector :: (A.Elt a, ValidSVector (n::Symbol) a) => SVector (n::Symbol) a -> ACCVector (bknd::Backend) (n::Symbol) a +mkAccVector v @(SVector_Dynamic fp off n) = let + arr = A.fromList (A.Z A.:. n) $ unsafeInlineIO $ go (n-1) [] + go (-1) xs = return $ xs + go i xs = withForeignPtr fp $ \p -> do + x <- peekElemOff p (off+i) + go (i-1) (x:xs) + in ACCVector (A.use arr) -mkAccMatrixFromList :: A.Elt a => [a] -> ACCMatrix' bknd n m a -mkAccMatrixFromList l = let - m = P.length l - n = P.length l ! 0 - in Mat (ACCMatrix (A.use (A.fromList (A.Z A.:.m A.:.n) l))) +-- Do I handle the matrixField types here? Which instances? @@ -1646,7 +1716,8 @@ type MatrixField r = , HM.Field r , HM.Container HM.Vector r , HM.Product r - ) + ) + {- data Matrix r (m::k1) (n::k2) where Zero :: Matrix r m n diff --git a/stack.yaml b/stack.yaml index c1bcadf..e0b9db8 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,8 +1,21 @@ flags: {} packages: - '.' +- location: + git: https://github.com/AccelerateHS/accelerate + commit: 01d1d2da0b5147041af61e95936262e6eff3f881 + extra-dep: true +- location: + git: https://github.com/AccelerateHS/accelerate-cuda + commit: b33150316aa8b8dd611cfc59f08429bd64fdb747 + extra-dep: true +# stack can't resolve this, complains about missing cabal file +# - location: +# git: https://github.com/AccelerateHS/accelerate-llvm +# commit: 987bff46f146b718a1da60c194eceff4b91a843f +# extra-dep: true extra-deps: -- accelerate-cuda-0.15.1.1 +- accelerate-2.0.0.0 - continued-fractions-0.9.1.1 - converge-0.1.0.1 - cuda-0.7.0.0 @@ -11,4 +24,5 @@ extra-deps: - language-c-quote-0.11.6.2 - mainland-pretty-0.4.1.4 - symbol-0.2.4 +- unique-0 resolver: lts-5.9 diff --git a/subhask.cabal b/subhask.cabal index ff454f2..faa057d 100644 --- a/subhask.cabal +++ b/subhask.cabal @@ -42,6 +42,9 @@ library SubHask.Algebra.Ring SubHask.Algebra.Vector SubHask.Algebra.Vector.FFI + SubHask.Algebra.Accelerate + SubHask.Algebra.AccelerateBackend + SubHask.Category SubHask.Category.Finite @@ -143,6 +146,7 @@ library accelerate , accelerate-cuda , cuda , + -- accelerate-llvm , -- compatibility control flow mtl , From c628dd3d67a42635803bf0a47b272c186fdd217a Mon Sep 17 00:00:00 2001 From: timpierson Date: Thu, 9 Jun 2016 22:47:20 -0400 Subject: [PATCH 04/20] updating packages --- stack.yaml | 21 ++++++++++++++------- subhask.cabal | 3 ++- 2 files changed, 16 insertions(+), 8 deletions(-) diff --git a/stack.yaml b/stack.yaml index e0b9db8..e29f346 100644 --- a/stack.yaml +++ b/stack.yaml @@ -3,25 +3,32 @@ packages: - '.' - location: git: https://github.com/AccelerateHS/accelerate - commit: 01d1d2da0b5147041af61e95936262e6eff3f881 + commit: aed12138a9788ff5d6289d214c84ff6108dc04bd extra-dep: true - location: git: https://github.com/AccelerateHS/accelerate-cuda - commit: b33150316aa8b8dd611cfc59f08429bd64fdb747 + commit: 05acd3adca9fd89a8ac19184afbed47d1b7d1505 + extra-dep: true +- location: + git: https://github.com/AccelerateHS/accelerate-llvm + commit: 987bff46f146b718a1da60c194eceff4b91a843f + subdirs: + - accelerate-llvm + - accelerate-llvm-native + - accelerate-llvm-ptx extra-dep: true -# stack can't resolve this, complains about missing cabal file -# - location: -# git: https://github.com/AccelerateHS/accelerate-llvm -# commit: 987bff46f146b718a1da60c194eceff4b91a843f -# extra-dep: true extra-deps: - accelerate-2.0.0.0 +- chaselev-deque-0.5.0.5 - continued-fractions-0.9.1.1 - converge-0.1.0.1 - cuda-0.7.0.0 - exception-mtl-0.4.0.1 - gamma-0.9.0.2 - language-c-quote-0.11.6.2 +- libffi-0.1 +- llvm-general-3.5.1.2 +- llvm-general-pure-3.5.1.0 - mainland-pretty-0.4.1.4 - symbol-0.2.4 - unique-0 diff --git a/subhask.cabal b/subhask.cabal index faa057d..ea230a3 100644 --- a/subhask.cabal +++ b/subhask.cabal @@ -146,7 +146,8 @@ library accelerate , accelerate-cuda , cuda , - -- accelerate-llvm , + llvm-general , + accelerate-llvm , -- compatibility control flow mtl , From 72e541c238c3c29c365253bb0a0bbc43a1f31f52 Mon Sep 17 00:00:00 2001 From: Tim Pierson Date: Thu, 9 Jun 2016 23:16:29 -0400 Subject: [PATCH 05/20] removing llvm --- examples/example0005-accelerate_backend.lhs | 10 ++++------ stack.yaml | 12 ------------ subhask.cabal | 3 +-- 3 files changed, 5 insertions(+), 20 deletions(-) diff --git a/examples/example0005-accelerate_backend.lhs b/examples/example0005-accelerate_backend.lhs index adca12d..9ccec3f 100644 --- a/examples/example0005-accelerate_backend.lhs +++ b/examples/example0005-accelerate_backend.lhs @@ -14,20 +14,20 @@ > import SubHask.Algebra.AccelerateBackend (Backend(..)) > import System.IO > -> v :: ACCVector Interpreter "a" Double +> v :: ACCVector CUDA "a" Double > v = mkAccVectorFromList [0..5] > -> v' :: ACCVector Interpreter "a" Double +> v' :: ACCVector CUDA "a" Double > v' = mkAccVectorFromList [0..5] > > > mmat :: Matrix (UVector "v" Double) Double "a" "b" > mmat = unsafeToModuleM 2 [0..5] > -> m :: ACCMatrix Interpreter (ACCVector Interpreter "v" Double ) "a" "b" Double +> m :: ACCMatrix CUDA (ACCVector CUDA "v" Double ) "a" "b" Double > m = mkAccMatrixFromMatrix mmat > -> mm :: ACCMatrix Interpreter (ACCVector Interpreter "v" Double ) "a" "b" Double +> mm :: ACCMatrix CUDA (ACCVector CUDA "v" Double ) "a" "b" Double > mm = mkAccMatrixFromList 2 [0,1,2,3,4,5,6,7,8,9,10] > > main :: IO () @@ -38,5 +38,3 @@ > putStrLn $ "v + v - v = " ++ show (runAccVector (v + v - v')) > putStrLn $ "v * v / v = " ++ show (runAccVector (v .*. v ./. v')) > putStrLn $ "v' * 2 = " ++ show (runAccVector (v' .* 2)) -> putStrLn $ "m + m = " ++ show (runAccMatrix (m + m)) -> putStrLn $ "m + mm = " ++ show (runAccMatrix (m + mm)) diff --git a/stack.yaml b/stack.yaml index e29f346..f614dd4 100644 --- a/stack.yaml +++ b/stack.yaml @@ -9,26 +9,14 @@ packages: git: https://github.com/AccelerateHS/accelerate-cuda commit: 05acd3adca9fd89a8ac19184afbed47d1b7d1505 extra-dep: true -- location: - git: https://github.com/AccelerateHS/accelerate-llvm - commit: 987bff46f146b718a1da60c194eceff4b91a843f - subdirs: - - accelerate-llvm - - accelerate-llvm-native - - accelerate-llvm-ptx - extra-dep: true extra-deps: - accelerate-2.0.0.0 -- chaselev-deque-0.5.0.5 - continued-fractions-0.9.1.1 - converge-0.1.0.1 - cuda-0.7.0.0 - exception-mtl-0.4.0.1 - gamma-0.9.0.2 - language-c-quote-0.11.6.2 -- libffi-0.1 -- llvm-general-3.5.1.2 -- llvm-general-pure-3.5.1.0 - mainland-pretty-0.4.1.4 - symbol-0.2.4 - unique-0 diff --git a/subhask.cabal b/subhask.cabal index ea230a3..faa057d 100644 --- a/subhask.cabal +++ b/subhask.cabal @@ -146,8 +146,7 @@ library accelerate , accelerate-cuda , cuda , - llvm-general , - accelerate-llvm , + -- accelerate-llvm , -- compatibility control flow mtl , From 94aee6f0dda410d7d2ed6d680cc0464218e714d8 Mon Sep 17 00:00:00 2001 From: Tim Pierson Date: Mon, 13 Jun 2016 11:01:12 -0400 Subject: [PATCH 06/20] acclerate-llvm is building --- README.md | 7 +- src/SubHask/Algebra/Accelerate.hs | 41 --- src/SubHask/Algebra/Accelerate/Accelerate.hs | 55 ++++ .../Algebra/Accelerate/AccelerateBackend.hs | 11 + src/SubHask/Algebra/Accelerate/Matrix.hs | 233 +++++++++++++++++ src/SubHask/Algebra/Accelerate/Vector.hs | 247 ++++++++++++++++++ src/SubHask/Algebra/AccelerateBackend.hs | 10 - src/SubHask/Algebra/Matrix.hs | 215 --------------- src/SubHask/Algebra/Vector.hs | 212 --------------- stack.yaml | 67 ++++- subhask.cabal | 7 +- 11 files changed, 614 insertions(+), 491 deletions(-) delete mode 100644 src/SubHask/Algebra/Accelerate.hs create mode 100644 src/SubHask/Algebra/Accelerate/Accelerate.hs create mode 100644 src/SubHask/Algebra/Accelerate/AccelerateBackend.hs create mode 100644 src/SubHask/Algebra/Accelerate/Matrix.hs create mode 100644 src/SubHask/Algebra/Accelerate/Vector.hs delete mode 100644 src/SubHask/Algebra/AccelerateBackend.hs diff --git a/README.md b/README.md index c30f1b0..bf064e7 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# SubHask +# SubHask SubHask is a radical rewrite of the Haskell [Prelude](https://www.haskell.org/onlinereport/standard-prelude.html). @@ -61,10 +61,13 @@ To install on Linux or Mac, run the following commands: $ cd llvm-3.5.2 $ mkdir build $ cd build - $ cmake .. + $ ../configure --enable-shared --enable-optimized $ make -j5 $ sudo make install ``` +(Configuring with `cmake` won't export the correct shared libraries that llvm-general +expects. If you want more debugging capability of the llvm code, removed the `--enable-optimized` flag) + 1. Any version of BLAS and LAPACK. How to install these packages varies for different operating systems. diff --git a/src/SubHask/Algebra/Accelerate.hs b/src/SubHask/Algebra/Accelerate.hs deleted file mode 100644 index a2994be..0000000 --- a/src/SubHask/Algebra/Accelerate.hs +++ /dev/null @@ -1,41 +0,0 @@ -module SubHask.Algebra.Accelerate -( - ValidBackend(..) - -- , acc2SVector -) -where - import SubHask.Algebra.AccelerateBackend (Backend(..)) - import SubHask.Algebra.Vector - import SubHask.Algebra.Matrix - import SubHask.Category - import SubHask.Compatibility.Base - import SubHask.SubType - import qualified Data.Array.Accelerate as A - import qualified Data.Array.Accelerate.Interpreter as I - import qualified Data.Array.Accelerate.CUDA as CUDA - -- import qualified Data.Array.Accelerate.LLVM as LLVM - - --needs to reside in the vector module but also needs acces to ValidBackend - -- acc2SVector :: ValidACCVector (b::Backend) n a => ACCVector (b::Backend) n a -> SVector n a - -- acc2SVector (ACCVector v) = unsafeToModule $ A.toList (ACCVector (runAccVector v)) :: SVector n a - - - class ValidBackend (b::Backend) where - runAccVector :: (ValidACCVector (b::Backend) n a, A.IsScalar a) => ACCVector (b::Backend) n a -> [a] - runAccMatrix :: (ValidACCMatrix (b::Backend) v m n r, A.IsScalar a, A.Elt a) => ACCMatrix (b::Backend) v n m a -> [a] - - instance ValidBackend Interpreter where - runAccVector (ACCVector a) = A.toList (I.run a) - runAccMatrix (ACCMatrix a) = A.toList (I.run a) - - instance ValidBackend CUDA where - runAccVector (ACCVector a) = A.toList (CUDA.run a) - runAccMatrix (ACCMatrix a) = A.toList (CUDA.run a) - - -- instance ValidBackend LLVM where - -- runAccVector (ACCVector a) = A.toList (LLVM.run a) - -- runAccMatrix (ACCMatrix a) = A.toList (LLVM.run a) - - -- instance ValidBackend Repa where - -- runAccVector (ACCVector a) = A.toList (Repa.run a) - -- runAccMatrix (ACCMatrix a) = A.toList (Repa.run a) diff --git a/src/SubHask/Algebra/Accelerate/Accelerate.hs b/src/SubHask/Algebra/Accelerate/Accelerate.hs new file mode 100644 index 0000000..e84a2bf --- /dev/null +++ b/src/SubHask/Algebra/Accelerate/Accelerate.hs @@ -0,0 +1,55 @@ +module SubHask.Algebra.Accelerate.AccelerateBackend +( + ValidBackend(..) + , mkAccVector + , mkAccVectorFromList + , mkAccMatrixFromList + , mkAccMatrixFromMatrix + , acc2SVector +) +where + +import SubHask.Algebra.Accelerate.AccelerateBackend (Backend(..)) + +-- import qualified Data.Array.Accelerate.LLVM as LLVM +--FIXME: Replace all intermediary lists with correct use of acclerate-io +mkAccVectorFromList :: A.Elt a => [a] -> ACCVector bknd (n::Symbol) a +mkAccVectorFromList l = let + len = P.length l + in ACCVector (A.use (A.fromList (A.Z A.:.len) l)) + +mkAccVector :: (A.Elt a, ValidSVector (n::Symbol) a) => SVector (n::Symbol) a -> ACCVector (bknd::Backend) (n::Symbol) a +mkAccVector v @(SVector_Dynamic fp off n) = let + arr = A.fromList (A.Z A.:. n) $ unsafeInlineIO $ go (n-1) [] + go (-1) xs = return $ xs + go i xs = withForeignPtr fp $ \p -> do + x <- peekElemOff p (off+i) + go (i-1) (x:xs) + in ACCVector (A.use arr) + +--needs to reside in the vector module but also needs acces to ValidBackend +acc2SVector :: ValidACCVector (b::Backend) n a => ACCVector (b::Backend) n a -> SVector n a +acc2SVector (ACCVector v) = unsafeToModule $ A.toList (ACCVector (runAccVector v)) :: SVector n a + + + + +class ValidBackend (b::Backend) where + runAccVector :: (ValidACCVector (b::Backend) n a, A.IsScalar a) => ACCVector (b::Backend) n a -> [a] + runAccMatrix :: (ValidACCMatrix (b::Backend) v m n r, A.IsScalar a, A.Elt a) => ACCMatrix (b::Backend) v n m a -> [a] + +instance ValidBackend Interpreter where + runAccVector (ACCVector a) = A.toList (I.run a) + runAccMatrix (ACCMatrix a) = A.toList (I.run a) + +instance ValidBackend CUDA where + runAccVector (ACCVector a) = A.toList (CUDA.run a) + runAccMatrix (ACCMatrix a) = A.toList (CUDA.run a) + +-- instance ValidBackend LLVM where +-- runAccVector (ACCVector a) = A.toList (LLVM.run a) +-- runAccMatrix (ACCMatrix a) = A.toList (LLVM.run a) + +-- instance ValidBackend Repa where +-- runAccVector (ACCVector a) = A.toList (Repa.run a) +-- runAccMatrix (ACCMatrix a) = A.toList (Repa.run a) diff --git a/src/SubHask/Algebra/Accelerate/AccelerateBackend.hs b/src/SubHask/Algebra/Accelerate/AccelerateBackend.hs new file mode 100644 index 0000000..9498169 --- /dev/null +++ b/src/SubHask/Algebra/Accelerate/AccelerateBackend.hs @@ -0,0 +1,11 @@ +module SubHask.Algebra.Accelerate.AccelerateBackend +( + Backend(..), +) +where + +data Backend + = Interpreter + | CUDA + | LLVM + -- LLVM has an SoC project slated, so check back in 60 days for non-parial functionality diff --git a/src/SubHask/Algebra/Accelerate/Matrix.hs b/src/SubHask/Algebra/Accelerate/Matrix.hs new file mode 100644 index 0000000..cc60279 --- /dev/null +++ b/src/SubHask/Algebra/Accelerate/Matrix.hs @@ -0,0 +1,233 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# OPTIONS_GHC -fno-warn-missing-methods #-} +{-# LANGUAGE OverloadedStrings #-} + +module SubHask.Algebra.Accelerate.Matrix + ( + ValidMatrix + , ACCMatrix (..) + , ValidACCMatrix + , ACCMatrix'(..) + , mmult + , transpose + , row + , col + , (!!) + , mkAccMatrixFromList + , mkAccMatrixFromMatrix + ) + where + +import qualified Data.Array.Accelerate as A +import qualified Data.Array.Accelerate.CUDA as CUDA +import qualified Data.Array.Accelerate.Interpreter as I +import SubHask.Algebra.Accelerate.Vector (ACCVector) +import SubHask.Algebra.Accelerate.AccelerateBackend (Backend) + +import Data.Primitive hiding (sizeOf) +import Control.Monad.Primitive +import Control.Monad + +import SubHask.Algebra +import SubHask.Category +import SubHask.Internal.Prelude + + +import qualified Prelude as P + + +newtype ACCMatrix (bknd::Backend) vect (m::k) (n::k) a = ACCMatrix (A.Acc (A.Array A.DIM2 a)) + +type ValidACCMatrix b vect m n r = + ( FiniteModule vect + , r ~ Scalar (Elem vect) + , Hilbert vect + , VectorSpace r + , Prim r + , A.Elt r -- A.Elt is the scalar element type; I don't know if this shoud be here but the instance signitures below seem to want it. + , P.Num r + , P.Num (A.Exp r) + ) + +type instance Scalar (ACCMatrix b v m n r) = Scalar r +type instance ACCMatrix b v m n r > IsMutable (ACCMatrix bknd v m n r) + + + +{-# INLINE rowLength #-} +rowLength :: ACCMatrix b v m n r -> Integer +rowLength arr = snd (A.arrayShape arr) +{-# INLINE colLength #-} +colLength :: ACCMatrix b v m n r -> Integer +colLength arr = fst (A.arrayShape arr) +{-# INLINE (!!) #-} +(!!) (ACCMatrix v) (i,j) = v A.! A.index2 (i,j) + + +-- algebra +instance + (P.Num (A.Exp r), Prim r, Monoid r, ValidACCMatrix b v m n r) => + Semigroup (ACCMatrix b v m n r) where + {-# INLINE (+) #-} + (+) (ACCMatrix m1) (ACCMatrix m2) = ACCMatrix (A.zipWith (P.+) m1 m2) + +instance + (P.Num (A.Exp r), Monoid r, Cancellative r, Prim r, ValidACCMatrix b v m n r) + => Cancellative (ACCMatrix b v (n::Symbol) (m::Symbol) r) where + {-# INLINE (-) #-} ; + (-) (ACCMatrix m1) (ACCMatrix m2) = ACCMatrix (A.zipWith (P.-) m1 m2) + +--Need the correct dim for this fill +instance + (P.Num (A.Exp r), Monoid r, Prim r, ValidACCMatrix b v m n r) => + Monoid (ACCMatrix b v (n::Symbol) (m::Symbol) r) where + {-# INLINE zero #-} + zero = ACCMatrix (A.fill (A.index2 2 4) 0) + +instance + (Monoid r, Abelian r, Prim r, ValidACCMatrix b v m n r) => + Abelian (ACCMatrix b v (n::Symbol) (m::Symbol) r) + +instance + (Module r, Prim r, ValidACCMatrix b v m n r) => + Module (ACCMatrix b v (n::Symbol) (m::Symbol) r) where + {-# INLINE (.*) #-} ; (.*) (ACCMatrix v) r = ACCMatrix( A.map (\x -> x P.* A.constant r) v) + +type instance Actor (ACCMatrix b v (n::Symbol) (m::Symbol) r) = Actor r + + +instance -- had to add Monoid r, to this instance + (P.Num (A.Exp r), Group r, Prim r, ValidACCMatrix b v m n r) => + Group (ACCMatrix b v (n::Symbol) (m::Symbol) r) where + {-# INLINE negate #-} + negate (ACCMatrix v) = ACCMatrix( A.map (\x -> x P.* A.constant (P.negate 1)) v) + +--Could not deduce (r ~ Actor r) +instance + (Action r, Semigroup r, Prim r, ValidACCMatrix b v m n r) => + Action (ACCMatrix b v (n::Symbol) (m::Symbol) r) + where + {-# INLINE (.+) #-} + (.+) (ACCMatrix v) r = ACCMatrix( A.map (\x -> x P.+ A.constant r) v) + +instance + (FreeModule r, Prim r, ValidACCMatrix b v m n r) => + FreeModule (ACCMatrix b v (n::Symbol) (m::Symbol) r) where + {-# INLINE (.*.) #-} + (.*.) (ACCMatrix v1) (ACCMatrix v2) = ACCMatrix(A.zipWith (P.*) v1 v2) + ones = undefined + +instance + (P.Fractional (A.Exp r), VectorSpace r, Prim r, ValidACCMatrix b v m n r) => + VectorSpace (ACCMatrix b v (n::Symbol) (m::Symbol) r) where + {-# INLINE (./) #-} + (./) (ACCMatrix v) r = ACCMatrix(A.map (\x -> x A./ (A.constant r)) v) + {-# INLINE (./.) #-} + (./.) (ACCMatrix v1) (ACCMatrix v2) = ACCMatrix(A.zipWith (A./) v1 v2) + +instance + (ValidACCMatrix b v m n r, Monoid r, ValidLogic r, Prim r, IsScalar r) + => IxContainer (ACCMatrix b v (n::Symbol) (m::Symbol) r) where + + {-# INLINE (!) #-} + (!) (ACCMatrix m) i = let + l = A.size m + in ACCMatrix m!!(i `div` l, i `mod` l) + +{-# INLINE row #-} +row :: (ValidACCMatrix b v m n r + ) => ACCMatrix b v (n::Symbol) (m::Symbol) r -> Int -> vect + row m i = A.slice m (A.Z A.:. (i::Int) A.:. A.All) + +{-# INLINE col #-} +col :: + ( ValidACCMatrix b v m n r + ) => ACCMatrix b v (n::Symbol) (m::Symbol) r -> Int -> vect +col m j = A.slice m (A.Z A.:. A.All A.:. (j::Int)) + + +--taken from http://www.cse.unsw.edu.au/~chak/papers/repa.pdf +{-# INLINE mmult #-} +mmult :: + ( ValidACCMatrix b v m n r + ) + => ACCMatrix b v (n::Symbol) (x0::Symbol) r + -> ACCMatrix b v (x0::Symbol) (m::Symbol) r + -> ACCMatrix b v (n::Symbol) (m::Symbol) r +mmult arr brr = A.sum (A.zipWith (*) arrRepl brrRepl) + where + trr = A.transpose brr + arrRepl = A.replicate (A.Z A.:. A.All A.:. colsB A.:. A.All) arr + brrRepl = A.replicate (A.Z A.:. rowsA A.:. A.All A.:. A.All) trr + (A.Z A.:. colsA A.:. rowsA) = A.shape arr + (A.Z A.:. colsB A.:. rowsB) = A.shape brr + +{-# INLINE transpose #-} +transpose :: + ( ValidACCMatrix b v m n r + ) + => ACCMatrix b v (m::Symbol) (n::Symbol) r + -> ACCMatrix b v (m::Symbol) (n::Symbol) r +transpose m = A.transpose m + +data ACCMatrix' b v (m::Symbol) (n::Symbol) r where + ACCZero :: + (ValidACCMatrix b v m n r) => + ACCMatrix' b v (m::Symbol) (n::Symbol) r + + ACCId :: + (ValidACCMatrix b v m n r) => + {-#UNPACK#-}!(Scalar r) -> ACCMatrix' b v (m::Symbol) (n::Symbol) r + + ACCMat :: + (ValidACCMatrix b v m n r) => + {-#UNPACK#-}!(ACCMatrix b v (m::Symbol) (n::Symbol) r) + -> ACCMatrix' b v (m::Symbol) (n::Symbol) r + +type instance Scalar (ACCMatrix' b v (m::Symbol) (n::Symbol) r) = Scalar r +type instance Logic (ACCMatrix' b v (m::Symbol) (n::Symbol) r) = Bool + +type instance ACCMatrix' b v (m::Symbol) (n::Symbol) r >< n = + ACCTensor_Linear (ACCMatrix' b v (m::Symbol) (n::Symbol) r ) n +type family ACCTensor_Linear m n where + ACCTensor_Linear (ACCMatrix' b v (m::Symbol) (n::Symbol) r) c = + ACCMatrix' b v (m::Symbol) (n::Symbol) r + +instance Category (ACCMatrix' b v (m::Symbol) (n::Symbol) r ) where + type ValidCategory (ACCMatrix' b v (m::Symbol) (n::Symbol) r ) o = ValidACCMatrix b v m n r + + id = Id 1 + + Zero . Zero = Zero + Zero . (Id _ ) = Zero + Zero . (Mat _ ) = Zero + + (Id _ ) . Zero = Zero + (Id r1) . (Id r2) = Id $ r1 * r2 + (Id r ) . (Mat m ) = Mat $ m .* r + + (Mat _) . Zero = Zero + (Mat m ) . (Id r ) = Mat $ m .* r + (Mat m1) . (Mat m2) = Mat $ mmult m2 m1 + +mkAccMatrixFromList :: A.Elt a => Int -> [a] -> ACCMatrix b v m n a +mkAccMatrixFromList m l = let + ln = P.length l + n = ln `div` m + in ACCMatrix (A.use (A.fromList (A.Z A.:.m A.:.n) l)) + +--FIXME: use accelerate-io functions https://github.com/AccelerateHS/accelerate-io/tree/master/Data/Array/Accelerate/IO +mkAccMatrixFromMatrix :: (ValidMatrix vect r, A.Elt r) => Matrix vect r (m::Symbol) (n::Symbol) -> ACCMatrix b v m n r +mkAccMatrixFromMatrix mat@(Matrix_Dynamic vect ln) = + mkAccMatrixFromList cln l + where + cln = colLength mat + l = P.foldr (\x xs -> vect!x : xs) [] [0..(ln * cln)-1] diff --git a/src/SubHask/Algebra/Accelerate/Vector.hs b/src/SubHask/Algebra/Accelerate/Vector.hs new file mode 100644 index 0000000..3093294 --- /dev/null +++ b/src/SubHask/Algebra/Accelerate/Vector.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module SubHask.Algebra.Accelerate.Vector + ( + ValidACCVector + , ValidSVector + , ACCVector (..) + , mkAccVector + , mkAccVectorFromList + ) + where + +import qualified Prelude as P + +import Control.Monad.Primitive +import Control.Monad +import Data.Primitive hiding (sizeOf) +import Debug.Trace +import qualified Data.Primitive as Prim +import Foreign.Ptr +import Foreign.ForeignPtr +import Foreign.Marshal.Utils + +import qualified Data.Array.Accelerate as A + +import SubHask.Algebra +import SubHask.Algebra.Accelerate.AccelerateBackend (Backend) +import SubHask.Category +import SubHask.Algebra.Vector (SVector, type (+>)) +import SubHask.Compatibility.Base +import SubHask.Internal.Prelude +import SubHask.SubType + +import System.IO.Unsafe +import Unsafe.Coerce + + + + +-------------------------------------------------------------------------------- + +-- | Accelerate based Vector +-- | A.Acc is an accelreate computation, A.Array A.DIM1 a is a one dimensional array + +newtype ACCVector (bknd::Backend) (n::k) a = ACCVector (A.Array A.DIM1 a) + +type instance Scalar (ACCVector bknd n r) = Scalar r +type instance Logic (ACCVector bknd n r) = Logic r + +-- type instance ACCVector bknd m a >< b = A.Exp (Tensor_ACCVector (ACCVector bknd m a) b) +-- type family Tensor_ACCVector a b where +-- Tensor_ACCVector (ACCVector bknd n r1) (ACCVector bknd m r2) = ACCVector bknd n r1 +> ACCVector bknd m r2 +-- Tensor_ACCVector (ACCVector bknd n r1) r1 = ACCVector bknd n r1 -- (r1> IsMutable (ACCVector (bknd::Backend) (n::Symbol) a) + +instance (Monoid r, ValidACCVector b n r) => Semigroup (ACCVector (b::Backend) (n::Symbol) r) where + {-# INLINE (+) #-} + (+) (ACCVector v1) (ACCVector v2)=ACCVector (A.zipWith (A.+) v1 v2) + +instance (ValidACCVector bknd n r, Action r, Semigroup r, Prim r) => Action (ACCVector (bknd::Backend) (n::Symbol) r) where + {-# INLINE (.+) #-} + (.+) (ACCVector v) r = ACCVector (A.map (P.+ r) v) + +instance (Monoid r, Cancellative r, ValidACCVector bknd n r) => Cancellative (ACCVector (bknd::Backend) (n::Symbol) r) where + {-# INLINE (-) #-} + (-) (ACCVector a1) (ACCVector a2) = ACCVector (A.zipWith (P.-) a1 a2) + +--The zero method wants a Ring r in the case of "0" +--or Field r in the case of "0.0" Not exactly sure how to handle this. +instance (Monoid r, ValidACCVector bknd n r) => Monoid (ACCVector (bknd::Backend) (n::Symbol) r) where + -- {-# INLINE zero #-} + -- zero = ACCVector(A.fill (A.index1 (A.constant 1)) (A.constant (0::r))) + -- zero = ACCVector(A.use (A.fromList (A.Z A.:.1) [(0::r)])) + + +instance (Group r, ValidACCVector bknd n r) => Group (ACCVector (bknd::Backend) (n::Symbol) r) where + {-# INLINE negate #-} + negate = negate + +instance (Monoid r, Abelian r, ValidACCVector bknd n r) => Abelian (ACCVector (bknd::Backend) (n::Symbol) r) + +instance (FreeModule r, ValidACCVector bknd n r, IsScalar r) => FreeModule (ACCVector (bknd::Backend) (n::Symbol) r) where + {-# INLINE (.*.) #-} + (.*.) (ACCVector a1) (ACCVector a2) = ACCVector( A.zipWith (P.*) a1 a2) + +instance (Module r, ValidACCVector bknd n r, IsScalar r) => Module (ACCVector (bknd::Backend) (n::Symbol) r) where + {-# INLINE (.*) #-} + (.*) (ACCVector v) r = ACCVector (A.map (P.* (A.constant r)) v) + +instance (VectorSpace r, ValidACCVector bknd n r, IsScalar r) => VectorSpace (ACCVector (bknd::Backend) (n::Symbol) r) where + {-# INLINE (./) #-} + (./) (ACCVector v) r = ACCVector (A.map (P./ (A.constant r)) v) + + {-# INLINE (./.) #-} + (./.) (ACCVector a1) (ACCVector a2) = ACCVector (A.zipWith (P./) a1 a2) + + +--Full error from FiniteModule instance: + -- Could not deduce (r ~ A.Exp r) + -- from the context (FreeModule r, + -- ValidLogic r, + -- ValidACCVector b n r, + -- IsScalar r) + -- bound by the instance declaration + -- at src/SubHask/Algebra/Accelerate/Vector.hs:123:10-115 + -- ‘r’ is a rigid type variable bound by + -- the instance declaration + -- at src/SubHask/Algebra/Accelerate/Vector.hs:123:10 + -- In the instance declaration for ‘FiniteModule (ACCVector b n r)’ + + +instance (FreeModule r, ValidLogic r, ValidACCVector b n r, IsScalar r) => FiniteModule (A.Exp (ACCVector b (n::Symbol) r)) + where + {-# INLINE dim #-} + dim (ACCVector v) = A.size v + + + +instance + ( P.Num (A.Exp r) + , Monoid r + , ValidLogic r + , ValidACCVector b n r + , IsScalar r + , FreeModule r + ) => IxContainer (ACCVector b (n::Symbol) r) + where + + {-# INLINE (!) #-} + (!) (ACCVector v) i = v A.! (A.index1 (A.lift i)) + + --Couldn't match type ‘A.Exp Bool’ with ‘Bool’ + {-# INLINABLE imap #-} + imap f (ACCVector v) = let + shp = A.shape v + idxs = A.generate shp P.id + mpd = A.zipWith f idxs v :: f (A.Exp r) -> f (A.Exp r) -> f (A.Exp r) + in ACCVector mpd + + type ValidElem (ACCVector b n r) e = (ClassicalLogic e, IsScalar e, FiniteModule e, ValidACCVector b n e) + +instance (Eq r, Monoid r, ValidACCVector b n r) => Eq_ (ACCVector b (n::Symbol) r) where + {-# INLINE (==) #-} + (ACCVector v2) == (ACCVector v1) = let + l = (A.lift v1) A.==* (A.lift v2) + in l + +instance + ( ValidACCVector b n r + , P.Num (A.Exp r) + , ExpField r + , Normed r + , Ord_ r + , Logic r~ Bool + , IsScalar r + , VectorSpace r + ) => Metric (ACCVector b (n::Symbol) r) + + where + {-# INLINE[2] distance #-} + distance (ACCVector v1) (ACCVector v2) = {-# SCC distance_ACCVector #-}let + dmag = A.zipWith (P.-) v1 v2 + dsq = A.zipWith (P.*) dmag dmag + drt = A.sqrt (A.sum dsq) + in A.lift (A.the drt) + +instance (VectorSpace r, ValidACCVector b n r, IsScalar r, ExpField r) => Normed (ACCVector b (n::Symbol) r) where + {-# INLINE size #-} + size (ACCVector v1) = let + sq = A.zipWith (P.*) v1 v1 + s = A.fold (P.+) (A.constant 0.0) sq + in A.the (A.sqrt s) + +instance + ( VectorSpace r + , ValidACCVector b n r + , IsScalar r + , ExpField r + , Real r + ) => Banach (ACCVector b (n::Symbol) r) + +instance + ( FiniteModule (ACCVector b (n::Symbol) r) + , VectorSpace (ACCVector b (n::Symbol) r) + , MatrixField r + ) => TensorAlgebra (ACCVector b (n::Symbol) r) + where + (ACCVector v1)><(ACCVector v2) = let + r = A.size v1 + c = A.size v2 + arr = A.map (\i -> A.lift (A.map (\j -> i * j ) v1)) v2 + m = A.reshape (A.Z A.:. r A.:. c) arr + in m + +instance + ( VectorSpace r + , ValidACCVector b n r + , IsScalar r + , ExpField r + , Real r + , OrdField r + , MatrixField r + , P.Num r + ) => Hilbert (ACCVector b (n::Symbol) r) + where + {-# INLINE (<>) #-} + (<>) (ACCVector v1) (ACCVector v2) = let + singleton = A.fold (+) 0 (A.zipWith (*) v1 v2) + in A.the singleton + +-- In Alegebra.Vector.hs this is defined in terms of HMatrix +-- recreated here to satisfy constraints +type MatrixField r = + ( IsScalar r + , VectorSpace r + , Field r + ) diff --git a/src/SubHask/Algebra/AccelerateBackend.hs b/src/SubHask/Algebra/AccelerateBackend.hs deleted file mode 100644 index 6100486..0000000 --- a/src/SubHask/Algebra/AccelerateBackend.hs +++ /dev/null @@ -1,10 +0,0 @@ -module SubHask.Algebra.AccelerateBackend -( - Backend(..) -) -where - data Backend - = Interpreter - | CUDA - | LLVM - -- LLVM has an SoC project slated, so check back in 60 days for non-parial functionality diff --git a/src/SubHask/Algebra/Matrix.hs b/src/SubHask/Algebra/Matrix.hs index 530cbd5..1948f52 100644 --- a/src/SubHask/Algebra/Matrix.hs +++ b/src/SubHask/Algebra/Matrix.hs @@ -7,17 +7,12 @@ module SubHask.Algebra.Matrix ( Matrix (..) , unsafeToModuleM , ValidMatrix - , ACCMatrix (..) - , ValidACCMatrix - , ACCMatrix'(..) , mmult , transpose , row , col , (!!) , Matrix'(..) - , mkAccMatrixFromList - , mkAccMatrixFromMatrix ) where @@ -29,13 +24,6 @@ import SubHask.Algebra import SubHask.Category import SubHask.Internal.Prelude -import qualified Data.Array.Accelerate as A -import qualified Data.Array.Accelerate.CUDA as CUDA -import qualified Data.Array.Accelerate.Interpreter as I -import SubHask.Algebra.Vector (ACCVector) -import SubHask.Algebra.AccelerateBackend (Backend) -import qualified Prelude as P - data family Matrix vect r (a::k) (b::k) type ValidMatrix vect r = @@ -308,206 +296,3 @@ instance Category (Matrix' vect r) where (Mat _) . Zero = Zero (Mat m ) . (Id r ) = Mat $ m .* r (Mat m1) . (Mat m2) = Mat $ mmult m2 m1 - - - -newtype ACCMatrix (bknd::Backend) vect (m::k) (n::k) a = ACCMatrix (A.Acc (A.Array A.DIM2 a)) - -type ValidACCMatrix b vect m n r = - ( FiniteModule vect - , r ~ Scalar (Elem vect) - , Hilbert vect - , VectorSpace r - , Prim r - , A.Elt r -- A.Elt is the scalar element type; I don't know if this shoud be here but the instance signitures below seem to want it. - , P.Num r - , P.Num (A.Exp r) - ) - -type instance Scalar (ACCMatrix b v m n r) = Scalar r -type instance ACCMatrix b v m n r > IsMutable (ACCMatrix bknd v m n r) - - - - -- name collision, how to instance these? - -- {-# INLINE rowLength #-} - -- rowLength :: ACCMatrix b v m n r -> Integer - -- rowLength arr = snd (A.arrayShape arr) - -- {-# INLINE colLength #-} - -- colLength :: ACCMatrix b v m n r -> Integer - -- colLength arr = fst (A.arrayShape arr) - -- {-# INLINE (!!) #-} - -- (!!) (ACCMatrix v) (i,j) = v A.! A.index2 (i,j) - - --- algebra -instance - (P.Num (A.Exp r), Prim r, Monoid r, ValidACCMatrix b v m n r) => - Semigroup (ACCMatrix b v m n r) where - {-# INLINE (+) #-} - (+) (ACCMatrix m1) (ACCMatrix m2) = ACCMatrix (A.zipWith (P.+) m1 m2) - -instance - (P.Num (A.Exp r), Monoid r, Cancellative r, Prim r, ValidACCMatrix b v m n r) - => Cancellative (ACCMatrix b v (n::Symbol) (m::Symbol) r) where - {-# INLINE (-) #-} ; - (-) (ACCMatrix m1) (ACCMatrix m2) = ACCMatrix (A.zipWith (P.-) m1 m2) - ---Need the correct dim for this fill -instance - (P.Num (A.Exp r), Monoid r, Prim r, ValidACCMatrix b v m n r) => - Monoid (ACCMatrix b v (n::Symbol) (m::Symbol) r) where - -- {-# INLINE zero #-} - -- zero = ACCMatrix (A.fill (A.index2 2 4) 0) - -instance - (Monoid r, Abelian r, Prim r, ValidACCMatrix b v m n r) => - Abelian (ACCMatrix b v (n::Symbol) (m::Symbol) r) - -instance - (Module r, Prim r, ValidACCMatrix b v m n r) => - Module (ACCMatrix b v (n::Symbol) (m::Symbol) r) where - {-# INLINE (.*) #-} ; (.*) (ACCMatrix v) r = ACCMatrix( A.map (\x -> x P.* A.constant r) v) - -type instance Actor (ACCMatrix b v (n::Symbol) (m::Symbol) r) = Actor r - - -instance -- had to add Monoid r, to this instance - (P.Num (A.Exp r), Group r, Prim r, ValidACCMatrix b v m n r) => - Group (ACCMatrix b v (n::Symbol) (m::Symbol) r) where - {-# INLINE negate #-} - negate (ACCMatrix v) = ACCMatrix( A.map (\x -> x P.* A.constant (P.negate 1)) v) - ---Could not deduce (r ~ Actor r) -instance - (Action r, Semigroup r, Prim r, ValidACCMatrix b v m n r) => - Action (ACCMatrix b v (n::Symbol) (m::Symbol) r) - -- where - -- {-# INLINE (.+) #-} - -- (.+) (ACCMatrix v) r = ACCMatrix( A.map (\x -> x P.+ A.constant r) v) -instance - (FreeModule r, Prim r, ValidACCMatrix b v m n r) => - FreeModule (ACCMatrix b v (n::Symbol) (m::Symbol) r) where - {-# INLINE (.*.) #-} - (.*.) (ACCMatrix v1) (ACCMatrix v2) = ACCMatrix(A.zipWith (P.*) v1 v2) - ones = undefined - -instance - (P.Fractional (A.Exp r), VectorSpace r, Prim r, ValidACCMatrix b v m n r) => - VectorSpace (ACCMatrix b v (n::Symbol) (m::Symbol) r) where - {-# INLINE (./) #-} - (./) (ACCMatrix v) r = ACCMatrix(A.map (\x -> x A./ (A.constant r)) v) - {-# INLINE (./.) #-} - (./.) (ACCMatrix v1) (ACCMatrix v2) = ACCMatrix(A.zipWith (A./) v1 v2) - -instance - (ValidACCMatrix b v m n r, Monoid r, ValidLogic r, Prim r, IsScalar r) - => IxContainer (ACCMatrix b v (n::Symbol) (m::Symbol) r) where - - -- {-# INLINE (!) #-} - -- (!) (ACCMatrix m) i = let - -- l = A.size m - -- in ACCMatrix m!!(i `div` l, i `mod` l) - --- {-# INLINE row #-} --- row :: (ValidACCMatrix b v m n r --- ) => ACCMatrix b v (n::Symbol) (m::Symbol) r -> Int -> vect --- row m i = A.slice m (A.Z A.:. (i::Int) A.:. A.All) --- --- {-# INLINE col #-} --- col :: --- ( ValidACCMatrix b v m n r --- ) => ACCMatrix b v (n::Symbol) (m::Symbol) r -> Int -> vect --- col m j = A.slice m (A.Z A.:. A.All A.:. (j::Int)) --- --- --- --taken from http://www.cse.unsw.edu.au/~chak/papers/repa.pdf --- {-# INLINE mmult #-} --- mmult :: --- ( ValidACCMatrix b v m n r --- ) --- => ACCMatrix b v (n::Symbol) (x0::Symbol) r --- -> ACCMatrix b v (x0::Symbol) (m::Symbol) r --- -> ACCMatrix b v (n::Symbol) (m::Symbol) r --- mmult arr brr = A.sum (A.zipWith (*) arrRepl brrRepl) --- where --- trr = A.transpose brr --- arrRepl = A.replicate (A.Z A.:. A.All A.:. colsB A.:. A.All) arr --- brrRepl = A.replicate (A.Z A.:. rowsA A.:. A.All A.:. A.All) trr --- (A.Z A.:. colsA A.:. rowsA) = A.shape arr --- (A.Z A.:. colsB A.:. rowsB) = A.shape brr --- --- {-# INLINE transpose #-} --- transpose :: --- ( ValidACCMatrix b v m n r --- ) --- => ACCMatrix b v (m::Symbol) (n::Symbol) r --- -> ACCMatrix b v (m::Symbol) (n::Symbol) r --- transpose m = A.transpose m - -data ACCMatrix' b v (m::Symbol) (n::Symbol) r where - ACCZero :: - (ValidACCMatrix b v m n r) => - ACCMatrix' b v (m::Symbol) (n::Symbol) r - - ACCId :: - (ValidACCMatrix b v m n r) => - {-#UNPACK#-}!(Scalar r) -> ACCMatrix' b v (m::Symbol) (n::Symbol) r - - ACCMat :: - (ValidACCMatrix b v m n r) => - {-#UNPACK#-}!(ACCMatrix b v (m::Symbol) (n::Symbol) r) - -> ACCMatrix' b v (m::Symbol) (n::Symbol) r - -type instance Scalar (ACCMatrix' b v (m::Symbol) (n::Symbol) r) = Scalar r -type instance Logic (ACCMatrix' b v (m::Symbol) (n::Symbol) r) = Bool - -type instance ACCMatrix' b v (m::Symbol) (n::Symbol) r >< n = - ACCTensor_Linear (ACCMatrix' b v (m::Symbol) (n::Symbol) r ) n -type family ACCTensor_Linear m n where - ACCTensor_Linear (ACCMatrix' b v (m::Symbol) (n::Symbol) r) c = - ACCMatrix' b v (m::Symbol) (n::Symbol) r - --- Categor failes with: --- The first argument of ‘Category’ should have kind ‘k0 -> k0 -> *’, --- but ‘ACCMatrix' b v (m :: Symbol) (n :: Symbol) r’ has kind ‘*’ --- In the instance declaration for --- ‘Category (ACCMatrix' b v (m :: Symbol) (n :: Symbol) r)’ - --- instance Category (ACCMatrix' b v (m::Symbol) (n::Symbol) r ) where --- type ValidCategory (ACCMatrix' b v (m::Symbol) (n::Symbol) r ) o = ValidACCMatrix b v m n r - - -- id = Id 1 - -- - -- Zero . Zero = Zero - -- Zero . (Id _ ) = Zero - -- Zero . (Mat _ ) = Zero - -- - -- (Id _ ) . Zero = Zero - -- (Id r1) . (Id r2) = Id $ r1 * r2 - -- (Id r ) . (Mat m ) = Mat $ m .* r - -- - -- (Mat _) . Zero = Zero - -- (Mat m ) . (Id r ) = Mat $ m .* r - -- (Mat m1) . (Mat m2) = Mat $ mmult m2 m1 - -mkAccMatrixFromList :: A.Elt a => Int -> [a] -> ACCMatrix b v m n a -mkAccMatrixFromList m l = let - ln = P.length l - n = ln `div` m - in ACCMatrix (A.use (A.fromList (A.Z A.:.m A.:.n) l)) - ---FIXME: use accelerate-io functions https://github.com/AccelerateHS/accelerate-io/tree/master/Data/Array/Accelerate/IO -mkAccMatrixFromMatrix :: (ValidMatrix vect r, A.Elt r) => Matrix vect r (m::Symbol) (n::Symbol) -> ACCMatrix b v m n r -mkAccMatrixFromMatrix mat@(Matrix_Dynamic vect ln) = - mkAccMatrixFromList cln l - where - cln = colLength mat - l = P.foldr (\x xs -> vect!x : xs) [] [0..(ln * cln)-1] diff --git a/src/SubHask/Algebra/Vector.hs b/src/SubHask/Algebra/Vector.hs index f3fca06..e349c43 100644 --- a/src/SubHask/Algebra/Vector.hs +++ b/src/SubHask/Algebra/Vector.hs @@ -18,15 +18,10 @@ module SubHask.Algebra.Vector ( SVector (..) , UVector (..) , ValidUVector - , ValidACCVector - , ValidSVector - , ACCVector (..) , Unbox , type (+>) , SMatrix , unsafeMkSMatrix - , mkAccVector - , mkAccVectorFromList , unsafeToModule -- * Debug @@ -55,14 +50,8 @@ import qualified Data.Vector.Storable as VS import qualified Numeric.LinearAlgebra as HM import qualified Numeric.LinearAlgebra.HMatrix as HM import qualified Numeric.LinearAlgebra.Data as HM -import qualified Data.Array.Accelerate as A - - - -import qualified Prelude as P import SubHask.Algebra -import SubHask.Algebra.AccelerateBackend (Backend) import SubHask.Category import SubHask.Compatibility.Base import SubHask.Internal.Prelude @@ -1506,207 +1495,6 @@ instance then tot else goEach (tot+(v1!i * v2!i)) (i-1) --------------------------------------------------------------------------------- - --- | Accelerate based Vector --- | A.Acc is an accelreate computation, A.Array A.DIM1 a is a one dimensional array - -newtype ACCVector (bknd::Backend) (n::k) a = ACCVector (A.Acc (A.Array A.DIM1 a)) - -type instance Scalar (ACCVector bknd n r) = Scalar r -type instance Logic (ACCVector bknd n r) = Logic r - -type instance ACCVector bknd m a >< b = Tensor_ACCVector (ACCVector bknd m a) b -type family Tensor_ACCVector a b where - Tensor_ACCVector (ACCVector bknd n r1) (ACCVector bknd m r2) = ACCVector bknd n r1 +> ACCVector bknd m r2 - Tensor_ACCVector (ACCVector bknd n r1) r1 = ACCVector bknd n r1 -- (r1> IsMutable (ACCVector (bknd::Backend) (n::Symbol) a) - - ---Not sure about all the Prelude Contexts necessary in these instances -instance (P.Num (A.Exp r), Monoid r, ValidACCVector bknd n r) => Semigroup (ACCVector (bknd::Backend) (n::Symbol) r) where - {-# INLINE (+) #-} - (+) (ACCVector a1) (ACCVector a2) = ACCVector (A.zipWith (P.+) a1 a2) - -instance (Action r, Semigroup r, Prim r) => Action (ACCVector (bknd::Backend) (n::Symbol) r) where --- "Couldn't match type ‘r’ with ‘Actor r’"" - -- {-# INLINE (.+) #-} - -- (.+) (ACCVector v) r = ACCVector (A.map (\x -> x P.+ r) v) - -instance (P.Num (A.Exp r), Monoid r, Cancellative r, ValidACCVector bknd n r) => Cancellative (ACCVector (bknd::Backend) (n::Symbol) r) where - {-# INLINE (-) #-} - (-) (ACCVector a1) (ACCVector a2) = ACCVector (A.zipWith (P.-) a1 a2) - ---How to get the correct dimension for this? -instance (P.Num (A.Exp r), Monoid r, ValidACCVector bknd n r) => Monoid (ACCVector (bknd::Backend) (n::Symbol) r) where - -- {-# INLINE zero #-} - -- zero = ACCVector(A.fill (A.index1 2) (A.lift 0)) - -instance (P.Num (A.Exp r), Group r, ValidACCVector bknd n r) => Group (ACCVector (bknd::Backend) (n::Symbol) r) where - {-# INLINE negate #-} - negate v = negate v - -instance (P.Num (A.Exp r), Monoid r, Abelian r, ValidACCVector bknd n r) => Abelian (ACCVector (bknd::Backend) (n::Symbol) r) - -instance (P.Num (A.Exp r), FreeModule r, ValidACCVector bknd n r, IsScalar r) => FreeModule (ACCVector (bknd::Backend) (n::Symbol) r) where - {-# INLINE (.*.) #-} - (.*.) (ACCVector a1) (ACCVector a2) = ACCVector (A.zipWith (P.*) a1 a2) - -instance (P.Num (A.Exp r), Module r, ValidACCVector bknd n r, IsScalar r) => Module (ACCVector (bknd::Backend) (n::Symbol) r) where - {-# INLINE (.*) #-} - (.*) (ACCVector v) r = ACCVector (A.map (\x -> x P.* (A.constant r)) v) - -instance (P.Fractional (A.Exp r), VectorSpace r, ValidACCVector bknd n r, IsScalar r, A.IsFloating r) => VectorSpace (ACCVector (bknd::Backend) (n::Symbol) r) where - {-# INLINE (./) #-} - (./) (ACCVector v) r = ACCVector (A.map (\x -> x P./(A.constant r)) v) - - {-# INLINE (./.) #-} - (./.) (ACCVector a1) (ACCVector a2) = ACCVector (A.zipWith (P./) a1 a2) - - -instance (P.Num (A.Exp r), FreeModule r, ValidLogic r, ValidACCVector b n r, IsScalar r) => FiniteModule (ACCVector b (n::Symbol) r) - --- this returns an A.Exp Int and not an Int, which makes GHC complain --- where --- --- {-# INLINE dim #-} --- dim (ACCVector v) = A.length v - - - -instance - ( P.Num (A.Exp r) - , Monoid r - , ValidLogic r - , ValidACCVector b n r - , A.Elt r - , IsScalar r - , FreeModule r - ) => IxContainer (ACCVector b (n::Symbol) r) - where - --(!) also returns A.Exp r where r is expected ... - -- {-# INLINE (!) #-} - -- (!) (ACCVector v) i = v A.! (A.index1 (A.lift i)) - -- {-# INLINABLE toIxList #-} - -- toIxList v = P.zip [0..] $ go (dim v-1) [] - -- where - -- go (-1) xs = xs - -- go i xs = go (i-1) (v!i : xs) - -- fails on f with: - -- Couldn't match type ‘Int’ with ‘A.Exp A.DIM1’ - -- Expected type: A.Exp A.DIM1 -> A.Exp r -> A.Exp b1 - -- Actual type: Index (ACCVector b n r) - -- -> Elem (ACCVector b n r) -> b1 - -- {-# INLINABLE imap #-} - -- imap f (ACCVector v) = ACCVector (A.zipWith f (A.generate (A.shape v) P.id) v) - - type ValidElem (ACCVector b n r) e = (ClassicalLogic e, IsScalar e, FiniteModule e, ValidACCVector b n e) - - -instance (Eq r, Monoid r, ValidACCVector b n r) => Eq_ (ACCVector b (n::Symbol) r) where - -- returns A.Exp Bool . . . . - -- {-# INLINE (==) #-} - -- (ACCVector v2) == (ACCVector v1) = (A.lift v1) A.==* (A.lift v2) - ---Will acc arrays support Logic r~Bool? -instance - ( ValidACCVector b n r - , P.Num (A.Exp r) - , ExpField r - , Normed r - , Ord_ r - , Logic r~Bool - , IsScalar r - , VectorSpace r - ) => Metric (ACCVector b (n::Symbol) r) - -- where - - -- also seems to wan to deduce r ~ A.Acc (Scalar r) - -- {-# INLINE[2] distance #-} - -- distance (ACCVector v1) (ACCVector v2) = {-# SCC distance_ACCVector #-}let - -- dmag = A.zipWith (P.-) v1 v2 - -- dsq = A.zipWith (P.*) dmag dmag - -- drt = A.sqrt (A.sum dsq) - -- in drt - - --what is distanceUB tring to do? - -- {-# INLINE[2] distanceUB #-} - -- distanceUB v1 v2 ub = {-# SCC distanceUB_ACCVectorr #-}let - -- ub2 = ub*ub - -- dmag = A.zipWith (P.-) v1 v2 - -- dsq = A.zipWith (P.*) dsq dsq - -- drt = A.map A.sqrt dsq - -- in expression - -instance (VectorSpace r, ValidACCVector b n r, IsScalar r, ExpField r) => Normed (ACCVector b (n::Symbol) r) where - -- {-# INLINE size #-} - -- size (ACCVector v1) = let - -- sq = A.zipWith (P.*) v1 v1 - -- s = A.fold (P.+) 0.0 sq - -- in A.sqrt s - - --- Could not deduce (P.Floating (A.Exp r)) --- arising from the superclasses of an instance declaration --- from the context (VectorSpace r, --- ValidACCVector b n r, --- IsScalar r, --- ExpField r, --- Real r) --- bound by the instance declaration --- instance --- ( VectorSpace r --- , ValidACCVector b n r --- , IsScalar r --- , ExpField r --- , Real r --- ) => Banach (ACCVector b (n::Symbol) r) - --- Could not deduce TensorAlgebra --- instance --- ( VectorSpace r --- , ValidACCVector b n r --- , IsScalar r --- , ExpField r --- , Real r --- , OrdField r --- , MatrixField r --- , P.Num r --- ) => Hilbert (ACCVector b (n::Symbol) r) - -- could not deduce r ~ ... - -- where - -- {-# INLINE (<>) #-} - -- (<>) (ACCVector v1) (ACCVector v2) = A.fold (+) 0 (A.zipWith (*) v1 v2) - ---FIXME: Replace all intermediary lists with correct use of acclerate-io -mkAccVectorFromList :: A.Elt a => [a] -> ACCVector bknd (n::Symbol) a -mkAccVectorFromList l = let - len = P.length l - in ACCVector (A.use (A.fromList (A.Z A.:.len) l)) - -mkAccVector :: (A.Elt a, ValidSVector (n::Symbol) a) => SVector (n::Symbol) a -> ACCVector (bknd::Backend) (n::Symbol) a -mkAccVector v @(SVector_Dynamic fp off n) = let - arr = A.fromList (A.Z A.:. n) $ unsafeInlineIO $ go (n-1) [] - go (-1) xs = return $ xs - go i xs = withForeignPtr fp $ \p -> do - x <- peekElemOff p (off+i) - go (i-1) (x:xs) - in ACCVector (A.use arr) - --- Do I handle the matrixField types here? Which instances? - type MatrixField r = diff --git a/stack.yaml b/stack.yaml index f614dd4..8ff1ce3 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,23 +1,74 @@ -flags: {} + packages: - '.' - location: - git: https://github.com/AccelerateHS/accelerate + git: https://github.com/AccelerateHS/accelerate.git commit: aed12138a9788ff5d6289d214c84ff6108dc04bd extra-dep: true - location: git: https://github.com/AccelerateHS/accelerate-cuda commit: 05acd3adca9fd89a8ac19184afbed47d1b7d1505 extra-dep: true +- location: + git: https://github.com/AccelerateHS/accelerate-llvm.git + commit: 2c26ca7755a3f5acc3a56dd0f4a23565ba620501 + extra-dep: true + subdirs: + - accelerate-llvm + - accelerate-llvm-native + - accelerate-llvm-ptx + +# required on OS X due to https://github.com/bscarlet/llvm-general/issues/155 +- location: + git: https://github.com/bscarlet/llvm-general.git + commit: 1ee693cc7577aab2f3e11ec9bd7f4244a5182c89 + extra-dep: true + subdirs: + - llvm-general + +extra-include-dirs: + - /usr/local/include + - /usr/local/include +extra-lib-dirs: + - /usr/local/lib + extra-deps: -- accelerate-2.0.0.0 -- continued-fractions-0.9.1.1 -- converge-0.1.0.1 -- cuda-0.7.0.0 -- exception-mtl-0.4.0.1 +- 'unique-0' + +# accelerate-llvm +- 'chaselev-deque-0.5.0.5' +- 'llvm-general-pure-3.5.0.0' + +# accelerate-llvm-native +- 'libffi-0.1' + +# accelerate-llvm-ptx +- 'cuda-0.7.0.0' + - gamma-0.9.0.2 - language-c-quote-0.11.6.2 - mainland-pretty-0.4.1.4 +- continued-fractions-0.9.1.1 +- converge-0.1.0.1 +- exception-mtl-0.4.0.1 - symbol-0.2.4 -- unique-0 + + +# Override default flag values for local packages and extra-deps +flags: + accelerate: + unsafe-checks: false + bounds-checks: true + debug: true + internal-checks: false + accelerate-llvm: + debug: true + chase-lev: true + accelerate-llvm-native: + debug: true + accelerate-llvm-ptx: + debug: true + libnvvm: false + llvm-general: + shared-llvm: true resolver: lts-5.9 diff --git a/subhask.cabal b/subhask.cabal index faa057d..7d1caee 100644 --- a/subhask.cabal +++ b/subhask.cabal @@ -42,8 +42,9 @@ library SubHask.Algebra.Ring SubHask.Algebra.Vector SubHask.Algebra.Vector.FFI - SubHask.Algebra.Accelerate - SubHask.Algebra.AccelerateBackend + SubHask.Algebra.Accelerate.AccelerateBackend + SubHask.Algebra.Accelerate.Vector + SubHask.Algebra.Accelerate.Matrix SubHask.Category @@ -146,7 +147,7 @@ library accelerate , accelerate-cuda , cuda , - -- accelerate-llvm , + accelerate-llvm , -- compatibility control flow mtl , From 150d94f27c942d2068c60b7c59079726b8c016e4 Mon Sep 17 00:00:00 2001 From: Tim Pierson Date: Thu, 26 May 2016 22:11:49 -0400 Subject: [PATCH 07/20] added accelerate-cuda and extra-deps initial implementations of Accelerate Vectors are working Algebra.Matrix Remove question about whether Heyting algebras are cancellative semigroups. Also add a comment that they're not cancellative in general, in case the question arises again. (Counterexample: open intervals in R.) Change wording Switch from ^ to && for the subalgebra operation Update README.md finished initial implementation updating packages removing llvm acclerate-llvm is building --- README.md | 8 +- examples/example0004-matrix-test.lhs | 29 ++ examples/example0005-accelerate_backend.lhs | 40 +++ src/SubHask/Algebra.hs | 6 +- src/SubHask/Algebra/Accelerate/Accelerate.hs | 55 ++++ .../Algebra/Accelerate/AccelerateBackend.hs | 11 + src/SubHask/Algebra/Accelerate/Matrix.hs | 233 ++++++++++++++ src/SubHask/Algebra/Accelerate/Vector.hs | 247 +++++++++++++++ src/SubHask/Algebra/Matrix.hs | 298 ++++++++++++++++++ src/SubHask/Algebra/Vector.hs | 4 +- stack.yaml | 75 ++++- subhask.cabal | 11 +- 12 files changed, 1003 insertions(+), 14 deletions(-) create mode 100644 examples/example0004-matrix-test.lhs create mode 100644 examples/example0005-accelerate_backend.lhs create mode 100644 src/SubHask/Algebra/Accelerate/Accelerate.hs create mode 100644 src/SubHask/Algebra/Accelerate/AccelerateBackend.hs create mode 100644 src/SubHask/Algebra/Accelerate/Matrix.hs create mode 100644 src/SubHask/Algebra/Accelerate/Vector.hs create mode 100644 src/SubHask/Algebra/Matrix.hs diff --git a/README.md b/README.md index 7b6fcb0..bf064e7 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,5 @@ -# SubHask ![](https://travis-ci.org/mikeizbicki/subhask.svg) +# SubHask + SubHask is a radical rewrite of the Haskell [Prelude](https://www.haskell.org/onlinereport/standard-prelude.html). The goal is to make numerical computing in Haskell *fun* and *fast*. @@ -60,10 +61,13 @@ To install on Linux or Mac, run the following commands: $ cd llvm-3.5.2 $ mkdir build $ cd build - $ cmake .. + $ ../configure --enable-shared --enable-optimized $ make -j5 $ sudo make install ``` +(Configuring with `cmake` won't export the correct shared libraries that llvm-general +expects. If you want more debugging capability of the llvm code, removed the `--enable-optimized` flag) + 1. Any version of BLAS and LAPACK. How to install these packages varies for different operating systems. diff --git a/examples/example0004-matrix-test.lhs b/examples/example0004-matrix-test.lhs new file mode 100644 index 0000000..333b7d3 --- /dev/null +++ b/examples/example0004-matrix-test.lhs @@ -0,0 +1,29 @@ +Test of SubHAsk.Algebra.Matrix + +> +> import SubHask +> import SubHask.Algebra.Matrix +> import SubHask.Algebra.Vector (UVector) +> import System.IO +> +> m :: Matrix (UVector "v" Double) Double "a" "b" +> m = unsafeToModuleM 3 [0..5] +> +> m' :: Matrix (UVector "v" Double) Double "b" "c" +> m' = unsafeToModuleM 2 [0..5] +> +> main :: IO () +> main = do +> putStrLn $ "m = " ++ show m +> putStrLn $ "m' = " ++ show m' +> putStrLn $ "m + m = " ++ show (m+m) +> putStrLn $ "m + zero = " ++ show (m+zero) +> putStrLn $ "m - m = " ++ show (m-m) +> putStrLn $ "m .*. m = " ++ show (m .*. m) +> putStrLn $ "m ./. m = " ++ show (m ./. m) +> putStrLn $ "m .+ 1 = " ++ show (m .+ 1) +> putStrLn $ "m .* 10 = " ++ show (m .* 10) +> putStrLn $ "mmult m m' = " ++ show (mmult m m') +> putStrLn $ "(Mat m') . (Mat m) = " ++ show (Mat m' . Mat m) +> putStrLn $ "(Mat m) . (Id 2.0) = " ++ show (Mat m . Id 2.0) +> diff --git a/examples/example0005-accelerate_backend.lhs b/examples/example0005-accelerate_backend.lhs new file mode 100644 index 0000000..9ccec3f --- /dev/null +++ b/examples/example0005-accelerate_backend.lhs @@ -0,0 +1,40 @@ + +> {-# LANGUAGE NoImplicitPrelude #-} +> {-# LANGUAGE RebindableSyntax #-} +> {-# LANGUAGE OverloadedLists #-} +> {-# LANGUAGE TypeOperators #-} +> {-# LANGUAGE FlexibleContexts #-} +> {-# LANGUAGE GADTs #-} +> {-# LANGUAGE DataKinds #-} +> import qualified Prelude as P +> import SubHask +> import SubHask.Algebra.Vector (ACCVector, UVector, mkAccVector, mkAccVectorFromList) +> import SubHask.Algebra.Matrix (ACCMatrix, Matrix, unsafeToModuleM, mkAccMatrixFromList, mkAccMatrixFromMatrix) +> import SubHask.Algebra.Accelerate (ValidBackend(..)) +> import SubHask.Algebra.AccelerateBackend (Backend(..)) +> import System.IO +> +> v :: ACCVector CUDA "a" Double +> v = mkAccVectorFromList [0..5] +> +> v' :: ACCVector CUDA "a" Double +> v' = mkAccVectorFromList [0..5] +> +> +> mmat :: Matrix (UVector "v" Double) Double "a" "b" +> mmat = unsafeToModuleM 2 [0..5] +> +> m :: ACCMatrix CUDA (ACCVector CUDA "v" Double ) "a" "b" Double +> m = mkAccMatrixFromMatrix mmat +> +> mm :: ACCMatrix CUDA (ACCVector CUDA "v" Double ) "a" "b" Double +> mm = mkAccMatrixFromList 2 [0,1,2,3,4,5,6,7,8,9,10] +> +> main :: IO () +> main = do +> putStrLn $ "v = " ++ show (runAccVector v) +> putStrLn $ "v' = " ++ show (runAccVector v') +> putStrLn $ "v + v = " ++ show (runAccVector (v + v)) +> putStrLn $ "v + v - v = " ++ show (runAccVector (v + v - v')) +> putStrLn $ "v * v / v = " ++ show (runAccVector (v .*. v ./. v')) +> putStrLn $ "v' * 2 = " ++ show (runAccVector (v' .* 2)) diff --git a/src/SubHask/Algebra.hs b/src/SubHask/Algebra.hs index 9c30d40..d75b2c2 100644 --- a/src/SubHask/Algebra.hs +++ b/src/SubHask/Algebra.hs @@ -928,10 +928,6 @@ instance Complemented b => Complemented (a -> b) where -- | Heyting algebras are lattices that support implication, but not necessarily the law of excluded middle. -- --- FIXME: --- Is every Heyting algebra a cancellative Abelian semigroup? --- If so, should we make that explicit in the class hierarchy? --- -- ==== Laws -- There is a single, simple law that Heyting algebras must satisfy: -- @@ -943,6 +939,8 @@ instance Complemented b => Complemented (a -> b) where -- distributivity -- -- See for more details. +-- +-- Note that while Heyting algebras are abelian semigroups with respect to &&, they are not in general cancellative. class Bounded b => Heyting b where -- | FIXME: think carefully about infix infixl 3 ==> diff --git a/src/SubHask/Algebra/Accelerate/Accelerate.hs b/src/SubHask/Algebra/Accelerate/Accelerate.hs new file mode 100644 index 0000000..e84a2bf --- /dev/null +++ b/src/SubHask/Algebra/Accelerate/Accelerate.hs @@ -0,0 +1,55 @@ +module SubHask.Algebra.Accelerate.AccelerateBackend +( + ValidBackend(..) + , mkAccVector + , mkAccVectorFromList + , mkAccMatrixFromList + , mkAccMatrixFromMatrix + , acc2SVector +) +where + +import SubHask.Algebra.Accelerate.AccelerateBackend (Backend(..)) + +-- import qualified Data.Array.Accelerate.LLVM as LLVM +--FIXME: Replace all intermediary lists with correct use of acclerate-io +mkAccVectorFromList :: A.Elt a => [a] -> ACCVector bknd (n::Symbol) a +mkAccVectorFromList l = let + len = P.length l + in ACCVector (A.use (A.fromList (A.Z A.:.len) l)) + +mkAccVector :: (A.Elt a, ValidSVector (n::Symbol) a) => SVector (n::Symbol) a -> ACCVector (bknd::Backend) (n::Symbol) a +mkAccVector v @(SVector_Dynamic fp off n) = let + arr = A.fromList (A.Z A.:. n) $ unsafeInlineIO $ go (n-1) [] + go (-1) xs = return $ xs + go i xs = withForeignPtr fp $ \p -> do + x <- peekElemOff p (off+i) + go (i-1) (x:xs) + in ACCVector (A.use arr) + +--needs to reside in the vector module but also needs acces to ValidBackend +acc2SVector :: ValidACCVector (b::Backend) n a => ACCVector (b::Backend) n a -> SVector n a +acc2SVector (ACCVector v) = unsafeToModule $ A.toList (ACCVector (runAccVector v)) :: SVector n a + + + + +class ValidBackend (b::Backend) where + runAccVector :: (ValidACCVector (b::Backend) n a, A.IsScalar a) => ACCVector (b::Backend) n a -> [a] + runAccMatrix :: (ValidACCMatrix (b::Backend) v m n r, A.IsScalar a, A.Elt a) => ACCMatrix (b::Backend) v n m a -> [a] + +instance ValidBackend Interpreter where + runAccVector (ACCVector a) = A.toList (I.run a) + runAccMatrix (ACCMatrix a) = A.toList (I.run a) + +instance ValidBackend CUDA where + runAccVector (ACCVector a) = A.toList (CUDA.run a) + runAccMatrix (ACCMatrix a) = A.toList (CUDA.run a) + +-- instance ValidBackend LLVM where +-- runAccVector (ACCVector a) = A.toList (LLVM.run a) +-- runAccMatrix (ACCMatrix a) = A.toList (LLVM.run a) + +-- instance ValidBackend Repa where +-- runAccVector (ACCVector a) = A.toList (Repa.run a) +-- runAccMatrix (ACCMatrix a) = A.toList (Repa.run a) diff --git a/src/SubHask/Algebra/Accelerate/AccelerateBackend.hs b/src/SubHask/Algebra/Accelerate/AccelerateBackend.hs new file mode 100644 index 0000000..9498169 --- /dev/null +++ b/src/SubHask/Algebra/Accelerate/AccelerateBackend.hs @@ -0,0 +1,11 @@ +module SubHask.Algebra.Accelerate.AccelerateBackend +( + Backend(..), +) +where + +data Backend + = Interpreter + | CUDA + | LLVM + -- LLVM has an SoC project slated, so check back in 60 days for non-parial functionality diff --git a/src/SubHask/Algebra/Accelerate/Matrix.hs b/src/SubHask/Algebra/Accelerate/Matrix.hs new file mode 100644 index 0000000..cc60279 --- /dev/null +++ b/src/SubHask/Algebra/Accelerate/Matrix.hs @@ -0,0 +1,233 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# OPTIONS_GHC -fno-warn-missing-methods #-} +{-# LANGUAGE OverloadedStrings #-} + +module SubHask.Algebra.Accelerate.Matrix + ( + ValidMatrix + , ACCMatrix (..) + , ValidACCMatrix + , ACCMatrix'(..) + , mmult + , transpose + , row + , col + , (!!) + , mkAccMatrixFromList + , mkAccMatrixFromMatrix + ) + where + +import qualified Data.Array.Accelerate as A +import qualified Data.Array.Accelerate.CUDA as CUDA +import qualified Data.Array.Accelerate.Interpreter as I +import SubHask.Algebra.Accelerate.Vector (ACCVector) +import SubHask.Algebra.Accelerate.AccelerateBackend (Backend) + +import Data.Primitive hiding (sizeOf) +import Control.Monad.Primitive +import Control.Monad + +import SubHask.Algebra +import SubHask.Category +import SubHask.Internal.Prelude + + +import qualified Prelude as P + + +newtype ACCMatrix (bknd::Backend) vect (m::k) (n::k) a = ACCMatrix (A.Acc (A.Array A.DIM2 a)) + +type ValidACCMatrix b vect m n r = + ( FiniteModule vect + , r ~ Scalar (Elem vect) + , Hilbert vect + , VectorSpace r + , Prim r + , A.Elt r -- A.Elt is the scalar element type; I don't know if this shoud be here but the instance signitures below seem to want it. + , P.Num r + , P.Num (A.Exp r) + ) + +type instance Scalar (ACCMatrix b v m n r) = Scalar r +type instance ACCMatrix b v m n r > IsMutable (ACCMatrix bknd v m n r) + + + +{-# INLINE rowLength #-} +rowLength :: ACCMatrix b v m n r -> Integer +rowLength arr = snd (A.arrayShape arr) +{-# INLINE colLength #-} +colLength :: ACCMatrix b v m n r -> Integer +colLength arr = fst (A.arrayShape arr) +{-# INLINE (!!) #-} +(!!) (ACCMatrix v) (i,j) = v A.! A.index2 (i,j) + + +-- algebra +instance + (P.Num (A.Exp r), Prim r, Monoid r, ValidACCMatrix b v m n r) => + Semigroup (ACCMatrix b v m n r) where + {-# INLINE (+) #-} + (+) (ACCMatrix m1) (ACCMatrix m2) = ACCMatrix (A.zipWith (P.+) m1 m2) + +instance + (P.Num (A.Exp r), Monoid r, Cancellative r, Prim r, ValidACCMatrix b v m n r) + => Cancellative (ACCMatrix b v (n::Symbol) (m::Symbol) r) where + {-# INLINE (-) #-} ; + (-) (ACCMatrix m1) (ACCMatrix m2) = ACCMatrix (A.zipWith (P.-) m1 m2) + +--Need the correct dim for this fill +instance + (P.Num (A.Exp r), Monoid r, Prim r, ValidACCMatrix b v m n r) => + Monoid (ACCMatrix b v (n::Symbol) (m::Symbol) r) where + {-# INLINE zero #-} + zero = ACCMatrix (A.fill (A.index2 2 4) 0) + +instance + (Monoid r, Abelian r, Prim r, ValidACCMatrix b v m n r) => + Abelian (ACCMatrix b v (n::Symbol) (m::Symbol) r) + +instance + (Module r, Prim r, ValidACCMatrix b v m n r) => + Module (ACCMatrix b v (n::Symbol) (m::Symbol) r) where + {-# INLINE (.*) #-} ; (.*) (ACCMatrix v) r = ACCMatrix( A.map (\x -> x P.* A.constant r) v) + +type instance Actor (ACCMatrix b v (n::Symbol) (m::Symbol) r) = Actor r + + +instance -- had to add Monoid r, to this instance + (P.Num (A.Exp r), Group r, Prim r, ValidACCMatrix b v m n r) => + Group (ACCMatrix b v (n::Symbol) (m::Symbol) r) where + {-# INLINE negate #-} + negate (ACCMatrix v) = ACCMatrix( A.map (\x -> x P.* A.constant (P.negate 1)) v) + +--Could not deduce (r ~ Actor r) +instance + (Action r, Semigroup r, Prim r, ValidACCMatrix b v m n r) => + Action (ACCMatrix b v (n::Symbol) (m::Symbol) r) + where + {-# INLINE (.+) #-} + (.+) (ACCMatrix v) r = ACCMatrix( A.map (\x -> x P.+ A.constant r) v) + +instance + (FreeModule r, Prim r, ValidACCMatrix b v m n r) => + FreeModule (ACCMatrix b v (n::Symbol) (m::Symbol) r) where + {-# INLINE (.*.) #-} + (.*.) (ACCMatrix v1) (ACCMatrix v2) = ACCMatrix(A.zipWith (P.*) v1 v2) + ones = undefined + +instance + (P.Fractional (A.Exp r), VectorSpace r, Prim r, ValidACCMatrix b v m n r) => + VectorSpace (ACCMatrix b v (n::Symbol) (m::Symbol) r) where + {-# INLINE (./) #-} + (./) (ACCMatrix v) r = ACCMatrix(A.map (\x -> x A./ (A.constant r)) v) + {-# INLINE (./.) #-} + (./.) (ACCMatrix v1) (ACCMatrix v2) = ACCMatrix(A.zipWith (A./) v1 v2) + +instance + (ValidACCMatrix b v m n r, Monoid r, ValidLogic r, Prim r, IsScalar r) + => IxContainer (ACCMatrix b v (n::Symbol) (m::Symbol) r) where + + {-# INLINE (!) #-} + (!) (ACCMatrix m) i = let + l = A.size m + in ACCMatrix m!!(i `div` l, i `mod` l) + +{-# INLINE row #-} +row :: (ValidACCMatrix b v m n r + ) => ACCMatrix b v (n::Symbol) (m::Symbol) r -> Int -> vect + row m i = A.slice m (A.Z A.:. (i::Int) A.:. A.All) + +{-# INLINE col #-} +col :: + ( ValidACCMatrix b v m n r + ) => ACCMatrix b v (n::Symbol) (m::Symbol) r -> Int -> vect +col m j = A.slice m (A.Z A.:. A.All A.:. (j::Int)) + + +--taken from http://www.cse.unsw.edu.au/~chak/papers/repa.pdf +{-# INLINE mmult #-} +mmult :: + ( ValidACCMatrix b v m n r + ) + => ACCMatrix b v (n::Symbol) (x0::Symbol) r + -> ACCMatrix b v (x0::Symbol) (m::Symbol) r + -> ACCMatrix b v (n::Symbol) (m::Symbol) r +mmult arr brr = A.sum (A.zipWith (*) arrRepl brrRepl) + where + trr = A.transpose brr + arrRepl = A.replicate (A.Z A.:. A.All A.:. colsB A.:. A.All) arr + brrRepl = A.replicate (A.Z A.:. rowsA A.:. A.All A.:. A.All) trr + (A.Z A.:. colsA A.:. rowsA) = A.shape arr + (A.Z A.:. colsB A.:. rowsB) = A.shape brr + +{-# INLINE transpose #-} +transpose :: + ( ValidACCMatrix b v m n r + ) + => ACCMatrix b v (m::Symbol) (n::Symbol) r + -> ACCMatrix b v (m::Symbol) (n::Symbol) r +transpose m = A.transpose m + +data ACCMatrix' b v (m::Symbol) (n::Symbol) r where + ACCZero :: + (ValidACCMatrix b v m n r) => + ACCMatrix' b v (m::Symbol) (n::Symbol) r + + ACCId :: + (ValidACCMatrix b v m n r) => + {-#UNPACK#-}!(Scalar r) -> ACCMatrix' b v (m::Symbol) (n::Symbol) r + + ACCMat :: + (ValidACCMatrix b v m n r) => + {-#UNPACK#-}!(ACCMatrix b v (m::Symbol) (n::Symbol) r) + -> ACCMatrix' b v (m::Symbol) (n::Symbol) r + +type instance Scalar (ACCMatrix' b v (m::Symbol) (n::Symbol) r) = Scalar r +type instance Logic (ACCMatrix' b v (m::Symbol) (n::Symbol) r) = Bool + +type instance ACCMatrix' b v (m::Symbol) (n::Symbol) r >< n = + ACCTensor_Linear (ACCMatrix' b v (m::Symbol) (n::Symbol) r ) n +type family ACCTensor_Linear m n where + ACCTensor_Linear (ACCMatrix' b v (m::Symbol) (n::Symbol) r) c = + ACCMatrix' b v (m::Symbol) (n::Symbol) r + +instance Category (ACCMatrix' b v (m::Symbol) (n::Symbol) r ) where + type ValidCategory (ACCMatrix' b v (m::Symbol) (n::Symbol) r ) o = ValidACCMatrix b v m n r + + id = Id 1 + + Zero . Zero = Zero + Zero . (Id _ ) = Zero + Zero . (Mat _ ) = Zero + + (Id _ ) . Zero = Zero + (Id r1) . (Id r2) = Id $ r1 * r2 + (Id r ) . (Mat m ) = Mat $ m .* r + + (Mat _) . Zero = Zero + (Mat m ) . (Id r ) = Mat $ m .* r + (Mat m1) . (Mat m2) = Mat $ mmult m2 m1 + +mkAccMatrixFromList :: A.Elt a => Int -> [a] -> ACCMatrix b v m n a +mkAccMatrixFromList m l = let + ln = P.length l + n = ln `div` m + in ACCMatrix (A.use (A.fromList (A.Z A.:.m A.:.n) l)) + +--FIXME: use accelerate-io functions https://github.com/AccelerateHS/accelerate-io/tree/master/Data/Array/Accelerate/IO +mkAccMatrixFromMatrix :: (ValidMatrix vect r, A.Elt r) => Matrix vect r (m::Symbol) (n::Symbol) -> ACCMatrix b v m n r +mkAccMatrixFromMatrix mat@(Matrix_Dynamic vect ln) = + mkAccMatrixFromList cln l + where + cln = colLength mat + l = P.foldr (\x xs -> vect!x : xs) [] [0..(ln * cln)-1] diff --git a/src/SubHask/Algebra/Accelerate/Vector.hs b/src/SubHask/Algebra/Accelerate/Vector.hs new file mode 100644 index 0000000..3093294 --- /dev/null +++ b/src/SubHask/Algebra/Accelerate/Vector.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module SubHask.Algebra.Accelerate.Vector + ( + ValidACCVector + , ValidSVector + , ACCVector (..) + , mkAccVector + , mkAccVectorFromList + ) + where + +import qualified Prelude as P + +import Control.Monad.Primitive +import Control.Monad +import Data.Primitive hiding (sizeOf) +import Debug.Trace +import qualified Data.Primitive as Prim +import Foreign.Ptr +import Foreign.ForeignPtr +import Foreign.Marshal.Utils + +import qualified Data.Array.Accelerate as A + +import SubHask.Algebra +import SubHask.Algebra.Accelerate.AccelerateBackend (Backend) +import SubHask.Category +import SubHask.Algebra.Vector (SVector, type (+>)) +import SubHask.Compatibility.Base +import SubHask.Internal.Prelude +import SubHask.SubType + +import System.IO.Unsafe +import Unsafe.Coerce + + + + +-------------------------------------------------------------------------------- + +-- | Accelerate based Vector +-- | A.Acc is an accelreate computation, A.Array A.DIM1 a is a one dimensional array + +newtype ACCVector (bknd::Backend) (n::k) a = ACCVector (A.Array A.DIM1 a) + +type instance Scalar (ACCVector bknd n r) = Scalar r +type instance Logic (ACCVector bknd n r) = Logic r + +-- type instance ACCVector bknd m a >< b = A.Exp (Tensor_ACCVector (ACCVector bknd m a) b) +-- type family Tensor_ACCVector a b where +-- Tensor_ACCVector (ACCVector bknd n r1) (ACCVector bknd m r2) = ACCVector bknd n r1 +> ACCVector bknd m r2 +-- Tensor_ACCVector (ACCVector bknd n r1) r1 = ACCVector bknd n r1 -- (r1> IsMutable (ACCVector (bknd::Backend) (n::Symbol) a) + +instance (Monoid r, ValidACCVector b n r) => Semigroup (ACCVector (b::Backend) (n::Symbol) r) where + {-# INLINE (+) #-} + (+) (ACCVector v1) (ACCVector v2)=ACCVector (A.zipWith (A.+) v1 v2) + +instance (ValidACCVector bknd n r, Action r, Semigroup r, Prim r) => Action (ACCVector (bknd::Backend) (n::Symbol) r) where + {-# INLINE (.+) #-} + (.+) (ACCVector v) r = ACCVector (A.map (P.+ r) v) + +instance (Monoid r, Cancellative r, ValidACCVector bknd n r) => Cancellative (ACCVector (bknd::Backend) (n::Symbol) r) where + {-# INLINE (-) #-} + (-) (ACCVector a1) (ACCVector a2) = ACCVector (A.zipWith (P.-) a1 a2) + +--The zero method wants a Ring r in the case of "0" +--or Field r in the case of "0.0" Not exactly sure how to handle this. +instance (Monoid r, ValidACCVector bknd n r) => Monoid (ACCVector (bknd::Backend) (n::Symbol) r) where + -- {-# INLINE zero #-} + -- zero = ACCVector(A.fill (A.index1 (A.constant 1)) (A.constant (0::r))) + -- zero = ACCVector(A.use (A.fromList (A.Z A.:.1) [(0::r)])) + + +instance (Group r, ValidACCVector bknd n r) => Group (ACCVector (bknd::Backend) (n::Symbol) r) where + {-# INLINE negate #-} + negate = negate + +instance (Monoid r, Abelian r, ValidACCVector bknd n r) => Abelian (ACCVector (bknd::Backend) (n::Symbol) r) + +instance (FreeModule r, ValidACCVector bknd n r, IsScalar r) => FreeModule (ACCVector (bknd::Backend) (n::Symbol) r) where + {-# INLINE (.*.) #-} + (.*.) (ACCVector a1) (ACCVector a2) = ACCVector( A.zipWith (P.*) a1 a2) + +instance (Module r, ValidACCVector bknd n r, IsScalar r) => Module (ACCVector (bknd::Backend) (n::Symbol) r) where + {-# INLINE (.*) #-} + (.*) (ACCVector v) r = ACCVector (A.map (P.* (A.constant r)) v) + +instance (VectorSpace r, ValidACCVector bknd n r, IsScalar r) => VectorSpace (ACCVector (bknd::Backend) (n::Symbol) r) where + {-# INLINE (./) #-} + (./) (ACCVector v) r = ACCVector (A.map (P./ (A.constant r)) v) + + {-# INLINE (./.) #-} + (./.) (ACCVector a1) (ACCVector a2) = ACCVector (A.zipWith (P./) a1 a2) + + +--Full error from FiniteModule instance: + -- Could not deduce (r ~ A.Exp r) + -- from the context (FreeModule r, + -- ValidLogic r, + -- ValidACCVector b n r, + -- IsScalar r) + -- bound by the instance declaration + -- at src/SubHask/Algebra/Accelerate/Vector.hs:123:10-115 + -- ‘r’ is a rigid type variable bound by + -- the instance declaration + -- at src/SubHask/Algebra/Accelerate/Vector.hs:123:10 + -- In the instance declaration for ‘FiniteModule (ACCVector b n r)’ + + +instance (FreeModule r, ValidLogic r, ValidACCVector b n r, IsScalar r) => FiniteModule (A.Exp (ACCVector b (n::Symbol) r)) + where + {-# INLINE dim #-} + dim (ACCVector v) = A.size v + + + +instance + ( P.Num (A.Exp r) + , Monoid r + , ValidLogic r + , ValidACCVector b n r + , IsScalar r + , FreeModule r + ) => IxContainer (ACCVector b (n::Symbol) r) + where + + {-# INLINE (!) #-} + (!) (ACCVector v) i = v A.! (A.index1 (A.lift i)) + + --Couldn't match type ‘A.Exp Bool’ with ‘Bool’ + {-# INLINABLE imap #-} + imap f (ACCVector v) = let + shp = A.shape v + idxs = A.generate shp P.id + mpd = A.zipWith f idxs v :: f (A.Exp r) -> f (A.Exp r) -> f (A.Exp r) + in ACCVector mpd + + type ValidElem (ACCVector b n r) e = (ClassicalLogic e, IsScalar e, FiniteModule e, ValidACCVector b n e) + +instance (Eq r, Monoid r, ValidACCVector b n r) => Eq_ (ACCVector b (n::Symbol) r) where + {-# INLINE (==) #-} + (ACCVector v2) == (ACCVector v1) = let + l = (A.lift v1) A.==* (A.lift v2) + in l + +instance + ( ValidACCVector b n r + , P.Num (A.Exp r) + , ExpField r + , Normed r + , Ord_ r + , Logic r~ Bool + , IsScalar r + , VectorSpace r + ) => Metric (ACCVector b (n::Symbol) r) + + where + {-# INLINE[2] distance #-} + distance (ACCVector v1) (ACCVector v2) = {-# SCC distance_ACCVector #-}let + dmag = A.zipWith (P.-) v1 v2 + dsq = A.zipWith (P.*) dmag dmag + drt = A.sqrt (A.sum dsq) + in A.lift (A.the drt) + +instance (VectorSpace r, ValidACCVector b n r, IsScalar r, ExpField r) => Normed (ACCVector b (n::Symbol) r) where + {-# INLINE size #-} + size (ACCVector v1) = let + sq = A.zipWith (P.*) v1 v1 + s = A.fold (P.+) (A.constant 0.0) sq + in A.the (A.sqrt s) + +instance + ( VectorSpace r + , ValidACCVector b n r + , IsScalar r + , ExpField r + , Real r + ) => Banach (ACCVector b (n::Symbol) r) + +instance + ( FiniteModule (ACCVector b (n::Symbol) r) + , VectorSpace (ACCVector b (n::Symbol) r) + , MatrixField r + ) => TensorAlgebra (ACCVector b (n::Symbol) r) + where + (ACCVector v1)><(ACCVector v2) = let + r = A.size v1 + c = A.size v2 + arr = A.map (\i -> A.lift (A.map (\j -> i * j ) v1)) v2 + m = A.reshape (A.Z A.:. r A.:. c) arr + in m + +instance + ( VectorSpace r + , ValidACCVector b n r + , IsScalar r + , ExpField r + , Real r + , OrdField r + , MatrixField r + , P.Num r + ) => Hilbert (ACCVector b (n::Symbol) r) + where + {-# INLINE (<>) #-} + (<>) (ACCVector v1) (ACCVector v2) = let + singleton = A.fold (+) 0 (A.zipWith (*) v1 v2) + in A.the singleton + +-- In Alegebra.Vector.hs this is defined in terms of HMatrix +-- recreated here to satisfy constraints +type MatrixField r = + ( IsScalar r + , VectorSpace r + , Field r + ) diff --git a/src/SubHask/Algebra/Matrix.hs b/src/SubHask/Algebra/Matrix.hs new file mode 100644 index 0000000..1948f52 --- /dev/null +++ b/src/SubHask/Algebra/Matrix.hs @@ -0,0 +1,298 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# OPTIONS_GHC -fno-warn-missing-methods #-} +{-# LANGUAGE OverloadedStrings #-} + +module SubHask.Algebra.Matrix + ( Matrix (..) + , unsafeToModuleM + , ValidMatrix + , mmult + , transpose + , row + , col + , (!!) + , Matrix'(..) + ) + where + +import Data.Primitive hiding (sizeOf) +import Control.Monad.Primitive +import Control.Monad + +import SubHask.Algebra +import SubHask.Category +import SubHask.Internal.Prelude + +data family Matrix vect r (a::k) (b::k) + +type ValidMatrix vect r = + ( FiniteModule vect + , r ~ Scalar (Elem vect) + , Hilbert vect + , VectorSpace r + , Prim r + ) + +type instance Scalar (Matrix vect r m n) = Scalar r +type instance Logic (Matrix vect r m n) = Logic r +type instance Matrix vect r m n >< a = Matrix vect (r> Int +rowLength (Matrix_Dynamic _ l) = l + +{-# INLINE colLength #-} +colLength :: (ValidMatrix vect r) => Matrix vect r (a::Symbol) (b::Symbol) -> Int +colLength (Matrix_Dynamic v l) = dim v `div` l + +{-# INLINE (!!) #-} +(!!) :: + (ValidMatrix vect r) => + Matrix vect r (a::Symbol) (b::Symbol) -> (Int, Int) -> r +(!!) (Matrix_Dynamic vect l) (i,j) = vect!(i*l+j) + +instance + (ValidMatrix vect r, Show r) => + Show (Matrix vect r (a::Symbol) (b::Symbol)) where + show m = if isZero rowLength m || isZero rowLength m + then "zero" + else go (rows-1) (cols-1) $ "(" ++ show rows ++ "><" ++ show cols ++ ")\n " + where + cols = rowLength m + rows = colLength m + go :: Int -> Int -> String -> String + go (-1) _ xs = xs ++ "]" + go i (-1) xs = go (i-1) (cols-1) (xs ++ "\n ") + go i j xs = go i (j-1) (xs ++ (if j==(cols-1) && i==(rows-1) then "[ " else ", ") ++ show (m!!(rows-1-i,cols-1-j))) + +-- | FiniteModule attempt +{-# INLINE unsafeToModuleM #-} +unsafeToModuleM :: forall vect r a b. + (ValidMatrix vect r) + => Int + -> [Scalar vect] + -> Matrix vect r (a::Symbol) (b::Symbol) +unsafeToModuleM l xs = Matrix_Dynamic (unsafeToModule xs) l + +--------------------------------------- +-- mutable + +newtype instance Mutable m' (Matrix vect r (a::Symbol) (b::Symbol)) + = Mutable_Matrix (PrimRef m' (Matrix vect r (a::Symbol) (b::Symbol))) + +instance Prim r => IsMutable (Matrix vect r (a::Symbol) (b::Symbol)) where + + freeze mv = copy mv >>= unsafeFreeze + thaw v = unsafeThaw v >>= copy + + unsafeFreeze (Mutable_Matrix ref) = readPrimRef ref + unsafeThaw v = do + ref <- newPrimRef v + return $ Mutable_Matrix ref + + write (Mutable_Matrix ref) m = writePrimRef ref m + +{-# INLINE monopDyn #-} +monopDyn :: forall vect r a b. + ( ValidMatrix vect r + ) + => (r -> r) + -> Matrix vect r (a::Symbol) (b::Symbol) + -> Matrix vect r (a::Symbol) (b::Symbol) +monopDyn f m@(Matrix_Dynamic vect l) = if l==0 + then m + else Matrix_Dynamic (unsafeToModule [f (vect!i) | i <- [0..(dim vect - 1)]]) l + +{-# INLINE binopDyn #-} +binopDyn :: forall vect r (a::Symbol) (b::Symbol). + ( ValidMatrix vect r + , Monoid r + ) + => (r -> r -> r) + -> Matrix vect r (a::Symbol) (b::Symbol) + -> Matrix vect r (a::Symbol) (b::Symbol) + -> Matrix vect r (a::Symbol) (b::Symbol) +binopDyn f m1@(Matrix_Dynamic vect1 l1) m2@(Matrix_Dynamic vect2 l2) = if + | isZero l1 -> m2 + | isZero l2 -> m1 + | otherwise -> + Matrix_Dynamic + (unsafeToModule + [ f (vect1!i) (vect2!i) + | i <- [0..(dim vect1 - 1)] + ]) + l1 + +-- algebra +instance + (Prim r, Monoid r, ValidMatrix vect r) => + Semigroup (Matrix vect r (a::Symbol) (b::Symbol)) where + {-# INLINE (+) #-} ; (+) = binopDyn (+) + +instance + (Monoid r, Cancellative r, Prim r, ValidMatrix vect r) + => Cancellative (Matrix vect r (a::Symbol) (b::Symbol)) where + {-# INLINE (-) #-} ; (-) = binopDyn (-) + +instance + (Monoid r, Prim r, ValidMatrix vect r) => + Monoid (Matrix vect r (a::Symbol) (b::Symbol)) where + {-# INLINE zero #-} + zero = unsafeInlineIO $ do + let vect = unsafeToModule [] + return $ Matrix_Dynamic vect 0 + +instance + (Group r, Prim r, ValidMatrix vect r) => + Group (Matrix vect r (a::Symbol) (b::Symbol)) where + {-# INLINE negate #-} + negate v = monopDyn negate v + +instance + (Monoid r, Abelian r, Prim r, ValidMatrix vect r) => + Abelian (Matrix vect r (a::Symbol) (b::Symbol)) + +instance + (Module r, Prim r, ValidMatrix vect r) => + Module (Matrix vect r (a::Symbol) (b::Symbol)) where + {-# INLINE (.*) #-} ; (.*) v r = monopDyn (.*r) v + +type instance Actor (Matrix vect r (a::Symbol) (b::Symbol)) = Actor r + +instance + (Action r, Semigroup r, Prim r, ValidMatrix vect r) => + Action (Matrix vect r (a::Symbol) (b::Symbol)) where + {-# INLINE (.+) #-} + (.+) v r = monopDyn (.+r) v + +instance + (FreeModule r, Prim r, ValidMatrix vect r) => + FreeModule (Matrix vect r (a::Symbol) (b::Symbol)) where + {-# INLINE (.*.) #-} + (.*.) = binopDyn (.*.) + ones = undefined + +instance + (VectorSpace r, Prim r, ValidMatrix vect r) => + VectorSpace (Matrix vect r (a::Symbol) (b::Symbol)) where + {-# INLINE (./) #-} ; (./) v r = monopDyn (./r) v + {-# INLINE (./.) #-} ; (./.) = binopDyn (./.) + +---------------------------------------- +-- container + +instance + (ValidMatrix vect r, Monoid r, ValidLogic r, Prim r, IsScalar r) + => IxContainer (Matrix vect r (a::Symbol) (b::Symbol)) where + + {-# INLINE (!) #-} + (!) m@(Matrix_Dynamic _ l) i = m!!(i `div` l, i `mod` l) + +instance + (Prim r, FreeModule r, ValidMatrix vect r, ValidLogic r, IsScalar r) + => FiniteModule (Matrix vect r (a::Symbol) (b::Symbol)) where + + {-# INLINE dim #-} + dim m = colLength m * rowLength m + + {-# INLINABLE unsafeToModule #-} + -- unsafeToModule xs = unsafeToModuleM r xs + +{-# INLINE row #-} +row :: (ValidMatrix vect r) => Matrix vect r (a::Symbol) (b::Symbol) -> Int -> vect +row m@(Matrix_Dynamic v l) i = + unsafeToModule + [ v!(i*l+j) + | j <- [0..(rowLength m -1)] + ] + +{-# INLINE col #-} +col :: + ( ValidMatrix vect r + ) => Matrix vect r (a::Symbol) (b::Symbol) -> Int -> vect +col m@(Matrix_Dynamic v l) j = + unsafeToModule + [ v!(i*l+j) + | i <- [0..(colLength m -1)] + ] + +{-# INLINE mmult #-} +mmult :: + ( ValidMatrix vect (Scalar r) + ) + => Matrix vect (Scalar r) (a::Symbol) (x0::Symbol) + -> Matrix vect (Scalar r) (x0::Symbol) (b::Symbol) + -> Matrix vect r (a::Symbol) (b::Symbol) +mmult m1@(Matrix_Dynamic _ _) m2@(Matrix_Dynamic _ cols2) = + Matrix_Dynamic v cols2 + where + v = unsafeToModule + [ m1 `row` i <> m2 `col` j + | i <- [0..cols2-1], j <- [0..cols2-1] + ] + +{-# INLINE transpose #-} +transpose :: + ( ValidMatrix vect r + ) + => Matrix vect (Scalar r) (a::Symbol) (b::Symbol) + -> Matrix vect r (a::Symbol) (b::Symbol) +transpose m = + unsafeToModuleM (colLength m) + [ m!!(j,i) + | i <- [0..(rowLength m - 1)] + , j <- [0..(colLength m -1)] + ] + +data Matrix' vect r (a::Symbol) (b::Symbol) where + Zero :: + (ValidMatrix vect r) => + Matrix' vect r (a::Symbol) (b::Symbol) + + Id :: + (ValidMatrix vect r) => + {-#UNPACK#-}!(Scalar r) -> Matrix' vect r (a::Symbol) (a::Symbol) + + Mat :: + (ValidMatrix vect r) => + {-#UNPACK#-}!(Matrix vect r (a::Symbol) (b::Symbol)) + -> Matrix' vect r (a::Symbol) (b::Symbol) + +type instance Scalar (Matrix' vect r (a::Symbol) (b::Symbol)) = Scalar r +type instance Logic (Matrix' vect r (a::Symbol) (b::Symbol)) = Bool + +type instance Matrix' vect r (a::Symbol) (b::Symbol) >< a = + Tensor_Linear (Matrix' vect r (a::Symbol) (b::Symbol)) a +type family Tensor_Linear a b where + Tensor_Linear (Matrix' vect r (a::Symbol) (b::Symbol)) c = + Matrix' vect r (a::Symbol) (b::Symbol) + +deriving instance ( ValidMatrix vect (Scalar r), Show (Scalar r) ) => + Show (Matrix' vect r (a::Symbol) (b::Symbol)) + +instance Category (Matrix' vect r) where + type ValidCategory (Matrix' vect r) m = ValidMatrix vect r + + id = Id 1 + + Zero . Zero = Zero + Zero . (Id _ ) = Zero + Zero . (Mat _ ) = Zero + + (Id _ ) . Zero = Zero + (Id r1) . (Id r2) = Id $ r1 * r2 + (Id r ) . (Mat m ) = Mat $ m .* r + + (Mat _) . Zero = Zero + (Mat m ) . (Id r ) = Mat $ m .* r + (Mat m1) . (Mat m2) = Mat $ mmult m2 m1 diff --git a/src/SubHask/Algebra/Vector.hs b/src/SubHask/Algebra/Vector.hs index 9c7eb92..e349c43 100644 --- a/src/SubHask/Algebra/Vector.hs +++ b/src/SubHask/Algebra/Vector.hs @@ -22,6 +22,7 @@ module SubHask.Algebra.Vector , type (+>) , SMatrix , unsafeMkSMatrix + , unsafeToModule -- * Debug , safeNewByteArray @@ -50,7 +51,6 @@ import qualified Numeric.LinearAlgebra as HM import qualified Numeric.LinearAlgebra.HMatrix as HM import qualified Numeric.LinearAlgebra.Data as HM -import qualified Prelude as P import SubHask.Algebra import SubHask.Category import SubHask.Compatibility.Base @@ -1495,7 +1495,7 @@ instance then tot else goEach (tot+(v1!i * v2!i)) (i-1) --------------------------------------------------------------------------------- + type MatrixField r = ( IsScalar r diff --git a/stack.yaml b/stack.yaml index 103d0d2..8ff1ce3 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,9 +1,74 @@ -flags: {} + packages: - '.' +- location: + git: https://github.com/AccelerateHS/accelerate.git + commit: aed12138a9788ff5d6289d214c84ff6108dc04bd + extra-dep: true +- location: + git: https://github.com/AccelerateHS/accelerate-cuda + commit: 05acd3adca9fd89a8ac19184afbed47d1b7d1505 + extra-dep: true +- location: + git: https://github.com/AccelerateHS/accelerate-llvm.git + commit: 2c26ca7755a3f5acc3a56dd0f4a23565ba620501 + extra-dep: true + subdirs: + - accelerate-llvm + - accelerate-llvm-native + - accelerate-llvm-ptx + +# required on OS X due to https://github.com/bscarlet/llvm-general/issues/155 +- location: + git: https://github.com/bscarlet/llvm-general.git + commit: 1ee693cc7577aab2f3e11ec9bd7f4244a5182c89 + extra-dep: true + subdirs: + - llvm-general + +extra-include-dirs: + - /usr/local/include + - /usr/local/include +extra-lib-dirs: + - /usr/local/lib + extra-deps: - [ gamma-0.9.0.2 - , continued-fractions-0.9.1.1 - , converge-0.1.0.1 - ] +- 'unique-0' + +# accelerate-llvm +- 'chaselev-deque-0.5.0.5' +- 'llvm-general-pure-3.5.0.0' + +# accelerate-llvm-native +- 'libffi-0.1' + +# accelerate-llvm-ptx +- 'cuda-0.7.0.0' + +- gamma-0.9.0.2 +- language-c-quote-0.11.6.2 +- mainland-pretty-0.4.1.4 +- continued-fractions-0.9.1.1 +- converge-0.1.0.1 +- exception-mtl-0.4.0.1 +- symbol-0.2.4 + + +# Override default flag values for local packages and extra-deps +flags: + accelerate: + unsafe-checks: false + bounds-checks: true + debug: true + internal-checks: false + accelerate-llvm: + debug: true + chase-lev: true + accelerate-llvm-native: + debug: true + accelerate-llvm-ptx: + debug: true + libnvvm: false + llvm-general: + shared-llvm: true resolver: lts-5.9 diff --git a/subhask.cabal b/subhask.cabal index 4b3c485..7d1caee 100644 --- a/subhask.cabal +++ b/subhask.cabal @@ -35,12 +35,17 @@ library SubHask.Algebra.Container SubHask.Algebra.Group SubHask.Algebra.Logic + SubHask.Algebra.Matrix SubHask.Algebra.Metric SubHask.Algebra.Ord SubHask.Algebra.Parallel SubHask.Algebra.Ring SubHask.Algebra.Vector SubHask.Algebra.Vector.FFI + SubHask.Algebra.Accelerate.AccelerateBackend + SubHask.Algebra.Accelerate.Vector + SubHask.Algebra.Accelerate.Matrix + SubHask.Category SubHask.Category.Finite @@ -139,6 +144,10 @@ library erf , gamma , hmatrix , + accelerate , + accelerate-cuda , + cuda , + accelerate-llvm , -- compatibility control flow mtl , @@ -158,7 +167,7 @@ library semigroups , bytes , approximate , - lens + lens default-language: Haskell2010 From bfa470c82332371f4864f426acb73873296e03ac Mon Sep 17 00:00:00 2001 From: timpierson Date: Tue, 21 Jun 2016 20:48:22 -0400 Subject: [PATCH 08/20] Refactored Vector and Matrixinstances --- examples/example0005-accelerate_backend.lhs | 25 ++- src/SubHask/Algebra/Accelerate/Accelerate.hs | 49 +++-- .../Algebra/Accelerate/AccelerateBackend.hs | 1 + src/SubHask/Algebra/Accelerate/Matrix.hs | 181 ++++++++++------- src/SubHask/Algebra/Accelerate/Vector.hs | 192 +++++++++--------- src/SubHask/Algebra/Matrix.hs | 1 + src/SubHask/Algebra/Vector.hs | 1 + subhask.cabal | 1 + 8 files changed, 260 insertions(+), 191 deletions(-) diff --git a/examples/example0005-accelerate_backend.lhs b/examples/example0005-accelerate_backend.lhs index 9ccec3f..1acf081 100644 --- a/examples/example0005-accelerate_backend.lhs +++ b/examples/example0005-accelerate_backend.lhs @@ -8,27 +8,29 @@ > {-# LANGUAGE DataKinds #-} > import qualified Prelude as P > import SubHask -> import SubHask.Algebra.Vector (ACCVector, UVector, mkAccVector, mkAccVectorFromList) -> import SubHask.Algebra.Matrix (ACCMatrix, Matrix, unsafeToModuleM, mkAccMatrixFromList, mkAccMatrixFromMatrix) -> import SubHask.Algebra.Accelerate (ValidBackend(..)) -> import SubHask.Algebra.AccelerateBackend (Backend(..)) +> import SubHask.Algebra.Accelerate.Vector (ACCVector) +> import SubHask.Algebra.Vector (UVector) +> import SubHask.Algebra.Matrix (Matrix, unsafeToModuleM) +> import SubHask.Algebra.Accelerate.Matrix (ACCMatrix, mmult) +> import SubHask.Algebra.Accelerate.Accelerate (ValidBackend(..), mkAccVector, mkAccVectorFromList, mkAccMatrixFromList, mkAccMatrixFromMatrix) +> import SubHask.Algebra.Accelerate.AccelerateBackend (Backend(..)) > import System.IO > -> v :: ACCVector CUDA "a" Double +> v :: ACCVector Interpreter "a" Double > v = mkAccVectorFromList [0..5] > -> v' :: ACCVector CUDA "a" Double +> v' :: ACCVector Interpreter "a" Double > v' = mkAccVectorFromList [0..5] > > > mmat :: Matrix (UVector "v" Double) Double "a" "b" > mmat = unsafeToModuleM 2 [0..5] > -> m :: ACCMatrix CUDA (ACCVector CUDA "v" Double ) "a" "b" Double +> m :: ACCMatrix Interpreter (ACCVector Interpreter "v" Double ) "a" "b" Double > m = mkAccMatrixFromMatrix mmat > -> mm :: ACCMatrix CUDA (ACCVector CUDA "v" Double ) "a" "b" Double -> mm = mkAccMatrixFromList 2 [0,1,2,3,4,5,6,7,8,9,10] +> mm :: ACCMatrix Interpreter (ACCVector Interpreter "v" Double ) "b" "a" Double +> mm = mkAccMatrixFromList 5 [0,1,2,3,4,5,6,7,8,9] > > main :: IO () > main = do @@ -38,3 +40,8 @@ > putStrLn $ "v + v - v = " ++ show (runAccVector (v + v - v')) > putStrLn $ "v * v / v = " ++ show (runAccVector (v .*. v ./. v')) > putStrLn $ "v' * 2 = " ++ show (runAccVector (v' .* 2)) +> putStrLn $ "v' * 2 = " ++ show (runAccVector (v' .* 2)) +> putStrLn $ "m * 2 = " ++ show (runAccMatrix (m .* 2)) +> putStrLn $ "m + 2 = " ++ show (runAccMatrix ((m + 2) - 1 )) +> putStrLn $ "m / 2 = " ++ show (runAccMatrix (m / 2)) +> putStrLn $ "m mmult mm = " ++ show (runAccMatrix (mmult m mm)) diff --git a/src/SubHask/Algebra/Accelerate/Accelerate.hs b/src/SubHask/Algebra/Accelerate/Accelerate.hs index e84a2bf..ab3108d 100644 --- a/src/SubHask/Algebra/Accelerate/Accelerate.hs +++ b/src/SubHask/Algebra/Accelerate/Accelerate.hs @@ -1,17 +1,41 @@ -module SubHask.Algebra.Accelerate.AccelerateBackend +module SubHask.Algebra.Accelerate.Accelerate ( ValidBackend(..) , mkAccVector , mkAccVectorFromList , mkAccMatrixFromList , mkAccMatrixFromMatrix - , acc2SVector + --, acc2SVector ) where -import SubHask.Algebra.Accelerate.AccelerateBackend (Backend(..)) --- import qualified Data.Array.Accelerate.LLVM as LLVM +import Control.Monad.Primitive +import Control.Monad +import SubHask.Algebra.Accelerate.AccelerateBackend (Backend, inAccLand) +import SubHask.Algebra.Accelerate.Vector +import SubHask.Algebra.Accelerate.Matrix +import qualified Data.Array.Accelerate as A +import qualified Data.Array.Accelerate.LLVM.Array.Data as LLVM +import qualified Data.Array.Accelerate.CUDA as CUDA +import qualified Data.Array.Accelerate.Interpreter as I +import SubHask.Category +import SubHask.Compatibility.Base +import SubHask.Internal.Prelude +import SubHask.SubType + +import Foreign.Ptr +import Foreign.ForeignPtr +import Foreign.Marshal.Utils + +import System.IO.Unsafe +import Unsafe.Coerce + +import SubHask.Algebra +import SubHask.Algebra.Vector +import SubHask.Algebra.Matrix +import qualified Prelude as P + --FIXME: Replace all intermediary lists with correct use of acclerate-io mkAccVectorFromList :: A.Elt a => [a] -> ACCVector bknd (n::Symbol) a mkAccVectorFromList l = let @@ -27,16 +51,13 @@ mkAccVector v @(SVector_Dynamic fp off n) = let go (i-1) (x:xs) in ACCVector (A.use arr) ---needs to reside in the vector module but also needs acces to ValidBackend -acc2SVector :: ValidACCVector (b::Backend) n a => ACCVector (b::Backend) n a -> SVector n a -acc2SVector (ACCVector v) = unsafeToModule $ A.toList (ACCVector (runAccVector v)) :: SVector n a - - +-- acc2SVector :: ValidACCVector (b::Backend) n a => ACCVector (b::Backend) n a -> SVector n a +-- acc2SVector (ACCVector v) = unsafeToModule $ (runAccVector v) :: SVector n a class ValidBackend (b::Backend) where runAccVector :: (ValidACCVector (b::Backend) n a, A.IsScalar a) => ACCVector (b::Backend) n a -> [a] - runAccMatrix :: (ValidACCMatrix (b::Backend) v m n r, A.IsScalar a, A.Elt a) => ACCMatrix (b::Backend) v n m a -> [a] + runAccMatrix :: (ValidACCMatrix (b::Backend) v r, A.IsScalar a, A.Elt a) => ACCMatrix (b::Backend) v n m a -> [a] instance ValidBackend Interpreter where runAccVector (ACCVector a) = A.toList (I.run a) @@ -47,9 +68,5 @@ instance ValidBackend CUDA where runAccMatrix (ACCMatrix a) = A.toList (CUDA.run a) -- instance ValidBackend LLVM where --- runAccVector (ACCVector a) = A.toList (LLVM.run a) --- runAccMatrix (ACCMatrix a) = A.toList (LLVM.run a) - --- instance ValidBackend Repa where --- runAccVector (ACCVector a) = A.toList (Repa.run a) --- runAccMatrix (ACCMatrix a) = A.toList (Repa.run a) +-- runAccVector (ACCVector a) = A.toList (LLVM.runArray a) +-- runAccMatrix (ACCMatrix a) = A.toList (LLVM.runArray a) diff --git a/src/SubHask/Algebra/Accelerate/AccelerateBackend.hs b/src/SubHask/Algebra/Accelerate/AccelerateBackend.hs index 9498169..2ace52a 100644 --- a/src/SubHask/Algebra/Accelerate/AccelerateBackend.hs +++ b/src/SubHask/Algebra/Accelerate/AccelerateBackend.hs @@ -4,6 +4,7 @@ module SubHask.Algebra.Accelerate.AccelerateBackend ) where + data Backend = Interpreter | CUDA diff --git a/src/SubHask/Algebra/Accelerate/Matrix.hs b/src/SubHask/Algebra/Accelerate/Matrix.hs index cc60279..dbad2b8 100644 --- a/src/SubHask/Algebra/Accelerate/Matrix.hs +++ b/src/SubHask/Algebra/Accelerate/Matrix.hs @@ -5,14 +5,16 @@ module SubHask.Algebra.Accelerate.Matrix ( - ValidMatrix - , ACCMatrix (..) + --ValidMatrix + ACCMatrix (..) , ValidACCMatrix , ACCMatrix'(..) , mmult , transpose , row , col + , nCols + , nRows , (!!) , mkAccMatrixFromList , mkAccMatrixFromMatrix @@ -22,7 +24,7 @@ module SubHask.Algebra.Accelerate.Matrix import qualified Data.Array.Accelerate as A import qualified Data.Array.Accelerate.CUDA as CUDA import qualified Data.Array.Accelerate.Interpreter as I -import SubHask.Algebra.Accelerate.Vector (ACCVector) +import SubHask.Algebra.Accelerate.Vector (ACCVector(..)) import SubHask.Algebra.Accelerate.AccelerateBackend (Backend) import Data.Primitive hiding (sizeOf) @@ -31,6 +33,7 @@ import Control.Monad import SubHask.Algebra import SubHask.Category +import qualified SubHask.Algebra.Matrix as M (Matrix(..), ValidMatrix, colLength) import SubHask.Internal.Prelude @@ -39,170 +42,195 @@ import qualified Prelude as P newtype ACCMatrix (bknd::Backend) vect (m::k) (n::k) a = ACCMatrix (A.Acc (A.Array A.DIM2 a)) -type ValidACCMatrix b vect m n r = - ( FiniteModule vect +type ValidACCMatrix (bknd::Backend) vect r = + ( + FiniteModule vect , r ~ Scalar (Elem vect) , Hilbert vect , VectorSpace r , Prim r - , A.Elt r -- A.Elt is the scalar element type; I don't know if this shoud be here but the instance signitures below seem to want it. + , A.Elt r , P.Num r , P.Num (A.Exp r) + , Actor r ~ A.Exp r + , Elem r ~ A.Exp r + , P.Integral (A.Exp Int) + , Scalar (A.Exp r) ~ A.Exp r + , (A.Exp r >< A.Exp r) ~ A.Exp r + , Ring (A.Exp Int) + , Ord_ (A.Exp r) + , Normed(A.Exp r) + , Ring(A.Exp r) + , Logic(A.Exp r) ~ Bool + , Field (A.Exp r) + ) type instance Scalar (ACCMatrix b v m n r) = Scalar r type instance ACCMatrix b v m n r > IsMutable (ACCMatrix bknd v m n r) -{-# INLINE rowLength #-} -rowLength :: ACCMatrix b v m n r -> Integer -rowLength arr = snd (A.arrayShape arr) -{-# INLINE colLength #-} -colLength :: ACCMatrix b v m n r -> Integer -colLength arr = fst (A.arrayShape arr) +{-# INLINE nCols #-} +nCols :: (A.Elt r) => ACCMatrix b v m n r -> A.Exp Int +nCols (ACCMatrix arr) = let + (A.Z A.:. cols A.:. rows) = A.unlift (A.shape arr) :: (A.Z A.:. A.Exp Int A.:. A.Exp Int) + in cols +{-# INLINE nRows #-} +nRows :: (A.Elt r) => ACCMatrix b v m n r -> A.Exp Int +nRows (ACCMatrix arr) = let + (A.Z A.:. cols A.:. rows) = A.unlift (A.shape arr) :: (A.Z A.:. A.Exp Int A.:. A.Exp Int) + in rows {-# INLINE (!!) #-} -(!!) (ACCMatrix v) (i,j) = v A.! A.index2 (i,j) +(!!) (ACCMatrix m) (i,j) = m A.! A.index2 i j -- algebra instance - (P.Num (A.Exp r), Prim r, Monoid r, ValidACCMatrix b v m n r) => + (Prim r, Monoid r, ValidACCMatrix b v r) => Semigroup (ACCMatrix b v m n r) where {-# INLINE (+) #-} (+) (ACCMatrix m1) (ACCMatrix m2) = ACCMatrix (A.zipWith (P.+) m1 m2) instance - (P.Num (A.Exp r), Monoid r, Cancellative r, Prim r, ValidACCMatrix b v m n r) + (Monoid r, Cancellative r, Prim r, ValidACCMatrix b v r) => Cancellative (ACCMatrix b v (n::Symbol) (m::Symbol) r) where {-# INLINE (-) #-} ; (-) (ACCMatrix m1) (ACCMatrix m2) = ACCMatrix (A.zipWith (P.-) m1 m2) --Need the correct dim for this fill +--also not sure to to handle the types of the index and zero value; +--the Ring() constraints made it happy for Ints instance - (P.Num (A.Exp r), Monoid r, Prim r, ValidACCMatrix b v m n r) => + (Monoid r, Prim r, ValidACCMatrix b v r) => Monoid (ACCMatrix b v (n::Symbol) (m::Symbol) r) where {-# INLINE zero #-} zero = ACCMatrix (A.fill (A.index2 2 4) 0) instance - (Monoid r, Abelian r, Prim r, ValidACCMatrix b v m n r) => + (Monoid r, Abelian r, Prim r, ValidACCMatrix b v r) => Abelian (ACCMatrix b v (n::Symbol) (m::Symbol) r) instance - (Module r, Prim r, ValidACCMatrix b v m n r) => + (Module r, Prim r, ValidACCMatrix b v r) => Module (ACCMatrix b v (n::Symbol) (m::Symbol) r) where - {-# INLINE (.*) #-} ; (.*) (ACCMatrix v) r = ACCMatrix( A.map (\x -> x P.* A.constant r) v) - -type instance Actor (ACCMatrix b v (n::Symbol) (m::Symbol) r) = Actor r - + {-# INLINE (.*) #-} + (.*) (ACCMatrix v) r = ACCMatrix( A.map (\x -> x P.* A.constant r) v) instance -- had to add Monoid r, to this instance - (P.Num (A.Exp r), Group r, Prim r, ValidACCMatrix b v m n r) => + (Group r, Prim r, ValidACCMatrix b v r) => Group (ACCMatrix b v (n::Symbol) (m::Symbol) r) where {-# INLINE negate #-} negate (ACCMatrix v) = ACCMatrix( A.map (\x -> x P.* A.constant (P.negate 1)) v) ---Could not deduce (r ~ Actor r) +--Could not deduce (r ~ A.Exp r) instance - (Action r, Semigroup r, Prim r, ValidACCMatrix b v m n r) => + (Actor(A.Exp r) ~ (A.Exp r), Semigroup (Actor(A.Exp r)), Action r, Semigroup r, Prim r, ValidACCMatrix b v r) => Action (ACCMatrix b v (n::Symbol) (m::Symbol) r) where + (.+) :: ACCMatrix b v m n r -> A.Exp r -> ACCMatrix b v m n r {-# INLINE (.+) #-} - (.+) (ACCMatrix v) r = ACCMatrix( A.map (\x -> x P.+ A.constant r) v) + (.+) (ACCMatrix v) r = ACCMatrix( A.map (P.+ r) v) instance - (FreeModule r, Prim r, ValidACCMatrix b v m n r) => + (FreeModule r, Prim r, ValidACCMatrix b v r) => FreeModule (ACCMatrix b v (n::Symbol) (m::Symbol) r) where {-# INLINE (.*.) #-} (.*.) (ACCMatrix v1) (ACCMatrix v2) = ACCMatrix(A.zipWith (P.*) v1 v2) ones = undefined instance - (P.Fractional (A.Exp r), VectorSpace r, Prim r, ValidACCMatrix b v m n r) => + (P.Fractional (A.Exp r), VectorSpace r, Prim r, ValidACCMatrix b v r) => VectorSpace (ACCMatrix b v (n::Symbol) (m::Symbol) r) where + (./) :: ACCMatrix b v m n r -> A.Exp r -> ACCMatrix b v m n r {-# INLINE (./) #-} - (./) (ACCMatrix v) r = ACCMatrix(A.map (\x -> x A./ (A.constant r)) v) + (./) (ACCMatrix v) r = ACCMatrix(A.map ( P./ r) v) {-# INLINE (./.) #-} (./.) (ACCMatrix v1) (ACCMatrix v2) = ACCMatrix(A.zipWith (A./) v1 v2) instance - (ValidACCMatrix b v m n r, Monoid r, ValidLogic r, Prim r, IsScalar r) + (Index r ~ A.Exp r, Complemented (A.Acc(A.Scalar Bool)), Integral(A.Exp Int), Ring (A.Exp r), Ring (A.Exp Int), Complemented r, ValidACCMatrix b v r, Monoid r, ValidLogic r, Prim r, IsScalar r) => IxContainer (ACCMatrix b v (n::Symbol) (m::Symbol) r) where {-# INLINE (!) #-} + (!) :: ACCMatrix b v m n r -> A.Exp r -> A.Exp r--A.Acc (Scalar r) (!) (ACCMatrix m) i = let l = A.size m - in ACCMatrix m!!(i `div` l, i `mod` l) - -{-# INLINE row #-} -row :: (ValidACCMatrix b v m n r - ) => ACCMatrix b v (n::Symbol) (m::Symbol) r -> Int -> vect - row m i = A.slice m (A.Z A.:. (i::Int) A.:. A.All) + rval = m!!(i `div` l, i `mod` l) + in A.the rval {-# INLINE col #-} -col :: - ( ValidACCMatrix b v m n r - ) => ACCMatrix b v (n::Symbol) (m::Symbol) r -> Int -> vect -col m j = A.slice m (A.Z A.:. A.All A.:. (j::Int)) +col :: (ValidACCMatrix b v r + ) => ACCMatrix b v (n::Symbol) (m::Symbol) r -> Int -> ACCVector b n r +col (ACCMatrix m) i = ACCVector (A.slice m (A.lift (A.Z A.:. i A.:. A.All))) +{-# INLINE row #-} +row :: + ( ValidACCMatrix b v r + ) => ACCMatrix b v (n::Symbol) (m::Symbol) r -> Int -> ACCVector b m r +row (ACCMatrix m) j = ACCVector (A.slice m (A.lift (A.Z A.:. A.All A.:. j))) --taken from http://www.cse.unsw.edu.au/~chak/papers/repa.pdf {-# INLINE mmult #-} mmult :: - ( ValidACCMatrix b v m n r + ( ValidACCMatrix b v r + , Field (A.Exp r) ) => ACCMatrix b v (n::Symbol) (x0::Symbol) r -> ACCMatrix b v (x0::Symbol) (m::Symbol) r -> ACCMatrix b v (n::Symbol) (m::Symbol) r -mmult arr brr = A.sum (A.zipWith (*) arrRepl brrRepl) +mmult (ACCMatrix arr) (ACCMatrix brr) = ACCMatrix out where trr = A.transpose brr - arrRepl = A.replicate (A.Z A.:. A.All A.:. colsB A.:. A.All) arr - brrRepl = A.replicate (A.Z A.:. rowsA A.:. A.All A.:. A.All) trr - (A.Z A.:. colsA A.:. rowsA) = A.shape arr - (A.Z A.:. colsB A.:. rowsB) = A.shape brr + (A.Z A.:. colsA A.:. rowsA) = A.unlift (A.shape arr) :: (A.Z A.:. A.Exp Int A.:. A.Exp Int) + (A.Z A.:. colsB A.:. rowsB) = A.unlift (A.shape brr) :: (A.Z A.:. A.Exp Int A.:. A.Exp Int) + arrRepl = A.replicate (A.lift $ A.Z A.:. A.All A.:. colsB A.:. A.All) arr + brrRepl = A.replicate (A.lift $ A.Z A.:. rowsA A.:. A.All A.:. A.All) trr + out = A.fold (P.+) 0.0 $ (A.zipWith (P.*) arrRepl brrRepl) + {-# INLINE transpose #-} transpose :: - ( ValidACCMatrix b v m n r + ( ValidACCMatrix b v r ) => ACCMatrix b v (m::Symbol) (n::Symbol) r -> ACCMatrix b v (m::Symbol) (n::Symbol) r -transpose m = A.transpose m +transpose (ACCMatrix m) = ACCMatrix (A.transpose (A.unlift m)) -data ACCMatrix' b v (m::Symbol) (n::Symbol) r where - ACCZero :: - (ValidACCMatrix b v m n r) => - ACCMatrix' b v (m::Symbol) (n::Symbol) r +data ACCMatrix' b v r (m::Symbol) (n::Symbol) where + Zero :: + (ValidACCMatrix b v r) => + ACCMatrix' b v r (m::Symbol) (n::Symbol) - ACCId :: - (ValidACCMatrix b v m n r) => - {-#UNPACK#-}!(Scalar r) -> ACCMatrix' b v (m::Symbol) (n::Symbol) r + Id :: + (ValidACCMatrix b v r) => + {-#UNPACK#-}!(Scalar r) -> ACCMatrix' b v r (m::Symbol) (n::Symbol) - ACCMat :: - (ValidACCMatrix b v m n r) => + Mat :: + (ValidACCMatrix b v r) => {-#UNPACK#-}!(ACCMatrix b v (m::Symbol) (n::Symbol) r) - -> ACCMatrix' b v (m::Symbol) (n::Symbol) r + -> ACCMatrix' b v r (m::Symbol) (n::Symbol) -type instance Scalar (ACCMatrix' b v (m::Symbol) (n::Symbol) r) = Scalar r -type instance Logic (ACCMatrix' b v (m::Symbol) (n::Symbol) r) = Bool +type instance Scalar (ACCMatrix' b v r (m::Symbol) (n::Symbol)) = Scalar r +type instance Logic (ACCMatrix' b v r (m::Symbol) (n::Symbol)) = Logic r--Bool -type instance ACCMatrix' b v (m::Symbol) (n::Symbol) r >< n = - ACCTensor_Linear (ACCMatrix' b v (m::Symbol) (n::Symbol) r ) n +type instance ACCMatrix' b v r (m::Symbol) (n::Symbol) >< m = + ACCTensor_Linear (ACCMatrix' b v r (m::Symbol) (n::Symbol)) m type family ACCTensor_Linear m n where - ACCTensor_Linear (ACCMatrix' b v (m::Symbol) (n::Symbol) r) c = - ACCMatrix' b v (m::Symbol) (n::Symbol) r + ACCTensor_Linear (ACCMatrix' b v r (m::Symbol) (n::Symbol)) c = + ACCMatrix' b v r (m::Symbol) (n::Symbol) -instance Category (ACCMatrix' b v (m::Symbol) (n::Symbol) r ) where - type ValidCategory (ACCMatrix' b v (m::Symbol) (n::Symbol) r ) o = ValidACCMatrix b v m n r +instance Category (ACCMatrix' b v r) where + type ValidCategory (ACCMatrix' b v r ) m = ValidACCMatrix b v r id = Id 1 @@ -212,11 +240,14 @@ instance Category (ACCMatrix' b v (m::Symbol) (n::Symbol) r ) where (Id _ ) . Zero = Zero (Id r1) . (Id r2) = Id $ r1 * r2 - (Id r ) . (Mat m ) = Mat $ m .* r + -- Could not deduce (b ~ c) + --(Id (r::Scalar r)) . (Mat (m::ACCMatrix b v (m::Symbol) (n::Symbol) r)) = Mat $ m .* A.constant r (Mat _) . Zero = Zero - (Mat m ) . (Id r ) = Mat $ m .* r - (Mat m1) . (Mat m2) = Mat $ mmult m2 m1 + --Could not deduce (b ~ a) + --(Mat m ) . (Id r ) = Mat $ m .* A.constant r + --Could not deduce (b1 ~ b2) + --(Mat m1) . (Mat m2) = Mat $ mmult m2 m1 mkAccMatrixFromList :: A.Elt a => Int -> [a] -> ACCMatrix b v m n a mkAccMatrixFromList m l = let @@ -225,9 +256,9 @@ mkAccMatrixFromList m l = let in ACCMatrix (A.use (A.fromList (A.Z A.:.m A.:.n) l)) --FIXME: use accelerate-io functions https://github.com/AccelerateHS/accelerate-io/tree/master/Data/Array/Accelerate/IO -mkAccMatrixFromMatrix :: (ValidMatrix vect r, A.Elt r) => Matrix vect r (m::Symbol) (n::Symbol) -> ACCMatrix b v m n r -mkAccMatrixFromMatrix mat@(Matrix_Dynamic vect ln) = +mkAccMatrixFromMatrix :: (M.ValidMatrix vect r, A.Elt r) => M.Matrix vect r (m::Symbol) (n::Symbol) -> ACCMatrix b v m n r +mkAccMatrixFromMatrix mat@(M.Matrix_Dynamic vect ln) = mkAccMatrixFromList cln l where - cln = colLength mat + cln = M.colLength mat l = P.foldr (\x xs -> vect!x : xs) [] [0..(ln * cln)-1] diff --git a/src/SubHask/Algebra/Accelerate/Vector.hs b/src/SubHask/Algebra/Accelerate/Vector.hs index 3093294..2c32d5e 100644 --- a/src/SubHask/Algebra/Accelerate/Vector.hs +++ b/src/SubHask/Algebra/Accelerate/Vector.hs @@ -1,13 +1,7 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - module SubHask.Algebra.Accelerate.Vector ( ValidACCVector - , ValidSVector , ACCVector (..) - , mkAccVector - , mkAccVectorFromList ) where @@ -43,148 +37,154 @@ import Unsafe.Coerce -- | Accelerate based Vector -- | A.Acc is an accelreate computation, A.Array A.DIM1 a is a one dimensional array -newtype ACCVector (bknd::Backend) (n::k) a = ACCVector (A.Array A.DIM1 a) +newtype ACCVector (bknd::Backend) (n::k) a = ACCVector (A.Acc (A.Array A.DIM1 a)) -type instance Scalar (ACCVector bknd n r) = Scalar r -type instance Logic (ACCVector bknd n r) = Logic r +type instance Scalar (ACCVector bknd n r) = A.Exp r--Scalar r +type instance Logic (ACCVector bknd n r) = A.Exp Bool--Logic r --- type instance ACCVector bknd m a >< b = A.Exp (Tensor_ACCVector (ACCVector bknd m a) b) --- type family Tensor_ACCVector a b where --- Tensor_ACCVector (ACCVector bknd n r1) (ACCVector bknd m r2) = ACCVector bknd n r1 +> ACCVector bknd m r2 --- Tensor_ACCVector (ACCVector bknd n r1) r1 = ACCVector bknd n r1 -- (r1>< b = Tensor_ACCVector (ACCVector bknd m a) b +type family Tensor_ACCVector a b where + Tensor_ACCVector (ACCVector bknd n r1) (ACCVector bknd m r2) = ACCVector bknd n r1 +> ACCVector bknd m r2 + Tensor_ACCVector (ACCVector bknd n r1) r1 = ACCVector bknd n r1 -- (r1>< A.Exp a) ~ A.Exp a + -- , ACCVector (bknd::Backend) n a ~ ACCVector (bknd::Backend) n (A.Exp a) , Prim a , A.Elt a - , A.IsNum a + --, Elem a ~ A.Exp a + --, A.IsNum a + , Tensor_ACCVector (ACCVector bknd n a) a + ~ ACCVector bknd n a + , Tensor_ACCVector (ACCVector bknd n a) (A.Exp a) + ~ ACCVector bknd n a -- , A.Eq (A.Array A.DIM1 a) -- , A.Lift A.Exp (A.Acc (A.Array A.DIM1 a)) , P.Num (A.Exp a) + --, P.Floating (A.Exp a) + --, A.IsFloating a + , Scalar (Scalar (A.Exp a)) ~ A.Exp a + -- , Scalar a ~ Scalar (Scalar a) + -- , Scalar a ~ a + -- , Scalar (A.Exp a) ~ Scalar (Scalar (A.Exp a)) + -- , Scalar (A.Exp a) ~ (A.Exp a) + --, Logic (A.Exp Bool) ~ A.Exp Bool + --, Logic (A.Exp a) ~ A.Exp Bool + -- , Logic (A.Exp a) ~ Bool + , Normed (A.Exp a) + , Ord (A.Exp a) + , Ring (A.Exp a) + , Field (A.Exp a) + , P.Fractional (A.Exp a) , P.Floating (A.Exp a) - , A.IsFloating a - , Scalar a ~ Scalar (Scalar a) - -- , Scalar a ~ Scalar (A.Exp a) - -- , Logic a ~ Logic (A.Exp a) - -- , Actor a ~ A.Exp a - -- , Index a ~ A.Exp a - -- , Elem a ~ A.Exp a - -- , Scalar (Scalar a)~ A.Exp (Scalar (Scalar a)) - , A.Plain a ~ a - -- , P.Floating (A.Acc (A.Scalar a)) + , Actor a ~ A.Exp a + , A.Eq (A.Array A.DIM1 a) + , A.Lift A.Exp (A.Acc (A.Array A.DIM1 a)) + --, P.Floating (A.Acc (A.Scalar a)) ) -type instance Index (ACCVector bknd n r) = Int -type instance Elem (ACCVector bknd n r) = Elem r +type instance Index (ACCVector bknd n r) = A.Exp Int --Index r +type instance Elem (ACCVector bknd n r) = A.Exp r type instance SetElem (ACCVector (bknd::Backend) n r) b = ACCVector (bknd::Backend) n b -type instance Actor (ACCVector (bknd::Backend) n r) = Actor r +type instance Actor (ACCVector (bknd::Backend) n r) = A.Exp r -instance Prim a => IsMutable (ACCVector (bknd::Backend) (n::Symbol) a) +instance (KnownNat n, Prim a) => IsMutable (ACCVector (bknd::Backend) (n::Nat) a) -instance (Monoid r, ValidACCVector b n r) => Semigroup (ACCVector (b::Backend) (n::Symbol) r) where +instance (KnownNat n, Monoid r, ValidACCVector b n r) => Semigroup (ACCVector (b::Backend) (n::Nat) r) where {-# INLINE (+) #-} (+) (ACCVector v1) (ACCVector v2)=ACCVector (A.zipWith (A.+) v1 v2) -instance (ValidACCVector bknd n r, Action r, Semigroup r, Prim r) => Action (ACCVector (bknd::Backend) (n::Symbol) r) where +instance (KnownNat n, ValidACCVector bknd n r, Action r, Semigroup r, Prim r) => Action (ACCVector (bknd::Backend) (n::Nat) r) where {-# INLINE (.+) #-} - (.+) (ACCVector v) r = ACCVector (A.map (P.+ r) v) + (.+) (ACCVector v) r = ACCVector (A.map (P.+ r) v) -instance (Monoid r, Cancellative r, ValidACCVector bknd n r) => Cancellative (ACCVector (bknd::Backend) (n::Symbol) r) where +instance (KnownNat n, Monoid r, Cancellative r, ValidACCVector bknd n r) => Cancellative (ACCVector (bknd::Backend) (n::Nat) r) where {-# INLINE (-) #-} (-) (ACCVector a1) (ACCVector a2) = ACCVector (A.zipWith (P.-) a1 a2) ---The zero method wants a Ring r in the case of "0" ---or Field r in the case of "0.0" Not exactly sure how to handle this. -instance (Monoid r, ValidACCVector bknd n r) => Monoid (ACCVector (bknd::Backend) (n::Symbol) r) where - -- {-# INLINE zero #-} - -- zero = ACCVector(A.fill (A.index1 (A.constant 1)) (A.constant (0::r))) - -- zero = ACCVector(A.use (A.fromList (A.Z A.:.1) [(0::r)])) - +--The zero method wants a Ring r in the case where zero is the integer "0" +--or Field r in the case of "0.0" +--In either case, the Group instance wants the same constraint. Not exactly sure how to handle this. +instance (KnownNat n, Monoid r, ValidACCVector bknd n r) => Monoid (ACCVector (bknd::Backend) (n::Nat) r) where +-- {-# INLINE zero #-} +-- zero = ACCVector(A.use (A.fromList (A.Z A.:.1) [(0::r)])) -instance (Group r, ValidACCVector bknd n r) => Group (ACCVector (bknd::Backend) (n::Symbol) r) where +instance (KnownNat n, Group r, ValidACCVector bknd n r) => Group (ACCVector (bknd::Backend) (n::Nat) r) where {-# INLINE negate #-} negate = negate -instance (Monoid r, Abelian r, ValidACCVector bknd n r) => Abelian (ACCVector (bknd::Backend) (n::Symbol) r) +instance (KnownNat n, Monoid r, Abelian r, ValidACCVector bknd n r) => Abelian (ACCVector (bknd::Backend) (n::Nat) r) -instance (FreeModule r, ValidACCVector bknd n r, IsScalar r) => FreeModule (ACCVector (bknd::Backend) (n::Symbol) r) where +instance (KnownNat n, FreeModule r, ValidACCVector bknd n r, IsScalar r) => FreeModule (ACCVector (bknd::Backend) (n::Nat) r) where {-# INLINE (.*.) #-} (.*.) (ACCVector a1) (ACCVector a2) = ACCVector( A.zipWith (P.*) a1 a2) -instance (Module r, ValidACCVector bknd n r, IsScalar r) => Module (ACCVector (bknd::Backend) (n::Symbol) r) where +instance (KnownNat n, Module r, ValidACCVector bknd n r, IsScalar r) => Module (ACCVector (bknd::Backend) (n::Nat) r) where {-# INLINE (.*) #-} - (.*) (ACCVector v) r = ACCVector (A.map (P.* (A.constant r)) v) + (.*) (ACCVector v) r = ACCVector (A.map (P.* r) v) -instance (VectorSpace r, ValidACCVector bknd n r, IsScalar r) => VectorSpace (ACCVector (bknd::Backend) (n::Symbol) r) where +instance (KnownNat n, VectorSpace r, ValidACCVector bknd n r, IsScalar r) => VectorSpace (ACCVector (bknd::Backend) (n::Nat) r) where {-# INLINE (./) #-} - (./) (ACCVector v) r = ACCVector (A.map (P./ (A.constant r)) v) + (./) (ACCVector v) r = ACCVector (A.map (P./ r) v) {-# INLINE (./.) #-} (./.) (ACCVector a1) (ACCVector a2) = ACCVector (A.zipWith (P./) a1 a2) +-- Could not deduce (r ~ Elem r) +-- In the instance declaration for ‘FiniteModule (ACCVector b n r)’ ---Full error from FiniteModule instance: - -- Could not deduce (r ~ A.Exp r) - -- from the context (FreeModule r, - -- ValidLogic r, - -- ValidACCVector b n r, - -- IsScalar r) - -- bound by the instance declaration - -- at src/SubHask/Algebra/Accelerate/Vector.hs:123:10-115 - -- ‘r’ is a rigid type variable bound by - -- the instance declaration - -- at src/SubHask/Algebra/Accelerate/Vector.hs:123:10 - -- In the instance declaration for ‘FiniteModule (ACCVector b n r)’ - - -instance (FreeModule r, ValidLogic r, ValidACCVector b n r, IsScalar r) => FiniteModule (A.Exp (ACCVector b (n::Symbol) r)) +instance (KnownNat n, FreeModule r, ValidLogic r, ValidACCVector b n r, IsScalar r) => FiniteModule (ACCVector b (n::Nat) r) +--Couldn't match expected type ‘Int’ with actual type ‘A.Exp Int’ where + --dim :: ACCVector b (n::Nat) r -> Index(A.Exp Int) {-# INLINE dim #-} dim (ACCVector v) = A.size v - +-- Could not deduce (r ~ Elem r) instance - ( P.Num (A.Exp r) - , Monoid r + ( Monoid r , ValidLogic r , ValidACCVector b n r - , IsScalar r + --, IsScalar r + , KnownNat n , FreeModule r - ) => IxContainer (ACCVector b (n::Symbol) r) + ) => IxContainer (ACCVector b (n::Nat) r) where {-# INLINE (!) #-} - (!) (ACCVector v) i = v A.! (A.index1 (A.lift i)) + (!) (ACCVector v) i = A.the (v A.! A.index1 i) - --Couldn't match type ‘A.Exp Bool’ with ‘Bool’ {-# INLINABLE imap #-} imap f (ACCVector v) = let - shp = A.shape v - idxs = A.generate shp P.id - mpd = A.zipWith f idxs v :: f (A.Exp r) -> f (A.Exp r) -> f (A.Exp r) + mpd = A.imap (\x i -> f i x) v in ACCVector mpd - type ValidElem (ACCVector b n r) e = (ClassicalLogic e, IsScalar e, FiniteModule e, ValidACCVector b n e) + type ValidElem (ACCVector b n r) e = (IsScalar e, FiniteModule e, ValidACCVector b n e) -instance (Eq r, Monoid r, ValidACCVector b n r) => Eq_ (ACCVector b (n::Symbol) r) where +instance (A.Eq r, KnownNat n, Eq r, Monoid r, ValidACCVector b n r) => Eq_ (ACCVector b (n::Nat) r) where + --(==) :: ACCVector b n r -> ACCVector b n r -> A.Acc (A.Scalar Bool) {-# INLINE (==) #-} (ACCVector v2) == (ACCVector v1) = let - l = (A.lift v1) A.==* (A.lift v2) - in l + l = A.zipWith (A.==*) v1 v2 + ele = l A.! A.index1 (A.constant 0) + bl = A.all (A.&&* ele) l + in A.the bl instance ( ValidACCVector b n r - , P.Num (A.Exp r) , ExpField r - , Normed r + --, Normed r , Ord_ r - , Logic r~ Bool , IsScalar r , VectorSpace r - ) => Metric (ACCVector b (n::Symbol) r) + , KnownNat n + ) => Metric (ACCVector b (n::Nat) r) where {-# INLINE[2] distance #-} @@ -192,14 +192,20 @@ instance dmag = A.zipWith (P.-) v1 v2 dsq = A.zipWith (P.*) dmag dmag drt = A.sqrt (A.sum dsq) - in A.lift (A.the drt) + in A.the drt -instance (VectorSpace r, ValidACCVector b n r, IsScalar r, ExpField r) => Normed (ACCVector b (n::Symbol) r) where +instance (P.Floating (A.Acc (A.Array A.DIM0 r)), KnownNat n, VectorSpace r, ValidACCVector b n r, IsScalar r, ExpField r) => Normed (ACCVector b (n::Nat) r) where {-# INLINE size #-} + --Could not deduce (r ~ A.Exp r) + size :: ACCVector b (n::Nat) r -> A.Exp r size (ACCVector v1) = let - sq = A.zipWith (P.*) v1 v1 + sq = A.zipWith (P.*) v1 v1 :: A.Acc (A.Array A.DIM1 r) s = A.fold (P.+) (A.constant 0.0) sq - in A.the (A.sqrt s) + srt = A.sqrt (s::A.Acc (A.Array A.DIM0 r)) + in A.the srt :: A.Exp r + + +-- -- Couldn't match type ‘A.Acc (Scalar Bool)’ with ‘Bool’ instance ( VectorSpace r @@ -207,19 +213,22 @@ instance , IsScalar r , ExpField r , Real r - ) => Banach (ACCVector b (n::Symbol) r) + , KnownNat n + ) => Banach (ACCVector b (n::Nat) r) instance - ( FiniteModule (ACCVector b (n::Symbol) r) - , VectorSpace (ACCVector b (n::Symbol) r) + ( FiniteModule (ACCVector b (n::Nat) r) + , VectorSpace (ACCVector b (n::Nat) r) + , Normed (ACCVector b n r +> ACCVector b n r) + , KnownNat n , MatrixField r - ) => TensorAlgebra (ACCVector b (n::Symbol) r) + ) => TensorAlgebra (ACCVector b (n::Nat) r) where (ACCVector v1)><(ACCVector v2) = let r = A.size v1 c = A.size v2 arr = A.map (\i -> A.lift (A.map (\j -> i * j ) v1)) v2 - m = A.reshape (A.Z A.:. r A.:. c) arr + m = A.reshape (A.index2 r c) arr :: ACCVector bknd n r +> ACCVector bknd m r in m instance @@ -230,13 +239,14 @@ instance , Real r , OrdField r , MatrixField r + , KnownNat n , P.Num r - ) => Hilbert (ACCVector b (n::Symbol) r) + ) => Hilbert (ACCVector b (n::Nat) r) where {-# INLINE (<>) #-} (<>) (ACCVector v1) (ACCVector v2) = let singleton = A.fold (+) 0 (A.zipWith (*) v1 v2) - in A.the singleton + in A.the singleton :: A.Exp r -- In Alegebra.Vector.hs this is defined in terms of HMatrix -- recreated here to satisfy constraints diff --git a/src/SubHask/Algebra/Matrix.hs b/src/SubHask/Algebra/Matrix.hs index 1948f52..8d1e101 100644 --- a/src/SubHask/Algebra/Matrix.hs +++ b/src/SubHask/Algebra/Matrix.hs @@ -12,6 +12,7 @@ module SubHask.Algebra.Matrix , row , col , (!!) + , colLength , Matrix'(..) ) where diff --git a/src/SubHask/Algebra/Vector.hs b/src/SubHask/Algebra/Vector.hs index e349c43..34b2766 100644 --- a/src/SubHask/Algebra/Vector.hs +++ b/src/SubHask/Algebra/Vector.hs @@ -18,6 +18,7 @@ module SubHask.Algebra.Vector ( SVector (..) , UVector (..) , ValidUVector + , ValidSVector , Unbox , type (+>) , SMatrix diff --git a/subhask.cabal b/subhask.cabal index 7d1caee..c2e30f2 100644 --- a/subhask.cabal +++ b/subhask.cabal @@ -42,6 +42,7 @@ library SubHask.Algebra.Ring SubHask.Algebra.Vector SubHask.Algebra.Vector.FFI + SubHask.Algebra.Accelerate.Accelerate SubHask.Algebra.Accelerate.AccelerateBackend SubHask.Algebra.Accelerate.Vector SubHask.Algebra.Accelerate.Matrix From 5e1e9f4206c62c1d5d534a86a2bcedf9b27f65d1 Mon Sep 17 00:00:00 2001 From: timpierson Date: Fri, 24 Jun 2016 23:10:41 -0700 Subject: [PATCH 09/20] moveing to ghc-8.0 --- src/SubHask/Algebra.hs | 11 ++--- src/SubHask/Algebra/Accelerate/Accelerate.hs | 2 +- src/SubHask/Algebra/Accelerate/Vector.hs | 49 ++++++++++--------- src/SubHask/Algebra/Matrix.hs | 1 + stack.yaml | 50 ++++++++++---------- subhask.cabal | 2 +- 6 files changed, 59 insertions(+), 56 deletions(-) diff --git a/src/SubHask/Algebra.hs b/src/SubHask/Algebra.hs index d75b2c2..ebf1116 100644 --- a/src/SubHask/Algebra.hs +++ b/src/SubHask/Algebra.hs @@ -1568,7 +1568,7 @@ instance Field b => Field (a -> b) where -- In particular, all finite fields and the complex numbers are NOT ordered fields. -- -- See for more details. -class (Field r, Ord r, Normed r, IsScalar r) => OrdField r +class (Field r, Ord_ r, Normed r, IsScalar r) => OrdField r instance OrdField Float instance OrdField Double @@ -1831,7 +1831,7 @@ type instance (a -> b) >< c = a -> (b>< (a -> b) = a -> (c> FiniteModule v where -- | Returns the dimension of the object. -- For some objects, this may be known statically, and so the parameter will not be "seq"ed. -- But for others, this may not be known statically, and so the parameter will be "seq"ed. - dim :: v -> Int + dim :: v -> Index v-- Set to index to accommodate Acclerate Exp Int unsafeToModule :: [Scalar v] -> v @@ -2231,7 +2231,7 @@ law_Bregman_triangle :: class ( HasScalar v , Eq_ v - , Boolean (Logic v) + --, Boolean (Logic v) --Disabled for accelerqte Exp v , Logic (Scalar v) ~ Logic v ) => Metric v where @@ -3244,4 +3244,3 @@ mkMutable [t| forall a. DualSG a |] mkMutable [t| forall a. Maybe a |] mkMutable [t| forall a. Maybe' a |] mkMutable [t| forall a b. Labeled' a b |] - diff --git a/src/SubHask/Algebra/Accelerate/Accelerate.hs b/src/SubHask/Algebra/Accelerate/Accelerate.hs index ab3108d..32f985b 100644 --- a/src/SubHask/Algebra/Accelerate/Accelerate.hs +++ b/src/SubHask/Algebra/Accelerate/Accelerate.hs @@ -16,7 +16,7 @@ import SubHask.Algebra.Accelerate.AccelerateBackend (Backend, inAccLand) import SubHask.Algebra.Accelerate.Vector import SubHask.Algebra.Accelerate.Matrix import qualified Data.Array.Accelerate as A -import qualified Data.Array.Accelerate.LLVM.Array.Data as LLVM +-- import qualified Data.Array.Accelerate.LLVM.Array.Data as LLVM import qualified Data.Array.Accelerate.CUDA as CUDA import qualified Data.Array.Accelerate.Interpreter as I import SubHask.Category diff --git a/src/SubHask/Algebra/Accelerate/Vector.hs b/src/SubHask/Algebra/Accelerate/Vector.hs index 2c32d5e..b7b1ad9 100644 --- a/src/SubHask/Algebra/Accelerate/Vector.hs +++ b/src/SubHask/Algebra/Accelerate/Vector.hs @@ -40,20 +40,23 @@ import Unsafe.Coerce newtype ACCVector (bknd::Backend) (n::k) a = ACCVector (A.Acc (A.Array A.DIM1 a)) type instance Scalar (ACCVector bknd n r) = A.Exp r--Scalar r -type instance Logic (ACCVector bknd n r) = A.Exp Bool--Logic r +type instance Logic (ACCVector bknd n r) = A.Exp r--Logic r type instance ACCVector bknd m a >< b = Tensor_ACCVector (ACCVector bknd m a) b type family Tensor_ACCVector a b where Tensor_ACCVector (ACCVector bknd n r1) (ACCVector bknd m r2) = ACCVector bknd n r1 +> ACCVector bknd m r2 Tensor_ACCVector (ACCVector bknd n r1) r1 = ACCVector bknd n r1 -- (r1><(A.Exp r))) + type ValidACCVector bknd n a = ((ACCVector (bknd::Backend) n a>< A.Exp a) ~ A.Exp a + -- , (A.Exp a >< A.Exp a) ~ A.Exp a -- , ACCVector (bknd::Backend) n a ~ ACCVector (bknd::Backend) n (A.Exp a) , Prim a + , IsExpScalar a , A.Elt a --, Elem a ~ A.Exp a --, A.IsNum a @@ -66,21 +69,21 @@ type ValidACCVector bknd n a = ((ACCVector (bknd::Backend) n a> Group (ACCVector (bkn instance (KnownNat n, Monoid r, Abelian r, ValidACCVector bknd n r) => Abelian (ACCVector (bknd::Backend) (n::Nat) r) -instance (KnownNat n, FreeModule r, ValidACCVector bknd n r, IsScalar r) => FreeModule (ACCVector (bknd::Backend) (n::Nat) r) where +instance (KnownNat n, FreeModule r, ValidACCVector bknd n r, IsExpScalar r) => FreeModule (ACCVector (bknd::Backend) (n::Nat) r) where {-# INLINE (.*.) #-} (.*.) (ACCVector a1) (ACCVector a2) = ACCVector( A.zipWith (P.*) a1 a2) -instance (KnownNat n, Module r, ValidACCVector bknd n r, IsScalar r) => Module (ACCVector (bknd::Backend) (n::Nat) r) where +instance (KnownNat n, Module r, ValidACCVector bknd n r) => Module (ACCVector (bknd::Backend) (n::Nat) r) where {-# INLINE (.*) #-} (.*) (ACCVector v) r = ACCVector (A.map (P.* r) v) -instance (KnownNat n, VectorSpace r, ValidACCVector bknd n r, IsScalar r) => VectorSpace (ACCVector (bknd::Backend) (n::Nat) r) where +instance (KnownNat n, VectorSpace r, ValidACCVector bknd n r) => VectorSpace (ACCVector (bknd::Backend) (n::Nat) r) where {-# INLINE (./) #-} (./) (ACCVector v) r = ACCVector (A.map (P./ r) v) @@ -138,7 +141,7 @@ instance (KnownNat n, VectorSpace r, ValidACCVector bknd n r, IsScalar r) => Vec -- Could not deduce (r ~ Elem r) -- In the instance declaration for ‘FiniteModule (ACCVector b n r)’ -instance (KnownNat n, FreeModule r, ValidLogic r, ValidACCVector b n r, IsScalar r) => FiniteModule (ACCVector b (n::Nat) r) +instance (KnownNat n, FreeModule r, ValidLogic r, ValidACCVector b n r) => FiniteModule (ACCVector b (n::Nat) r) --Couldn't match expected type ‘Int’ with actual type ‘A.Exp Int’ where --dim :: ACCVector b (n::Nat) r -> Index(A.Exp Int) @@ -151,7 +154,7 @@ instance ( Monoid r , ValidLogic r , ValidACCVector b n r - --, IsScalar r + , IsExpScalar r , KnownNat n , FreeModule r ) => IxContainer (ACCVector b (n::Nat) r) @@ -165,9 +168,9 @@ instance mpd = A.imap (\x i -> f i x) v in ACCVector mpd - type ValidElem (ACCVector b n r) e = (IsScalar e, FiniteModule e, ValidACCVector b n e) + type ValidElem (ACCVector b n r) e = (FiniteModule e, ValidACCVector b n e) -instance (A.Eq r, KnownNat n, Eq r, Monoid r, ValidACCVector b n r) => Eq_ (ACCVector b (n::Nat) r) where +instance (A.Eq r, KnownNat n, Eq_ r, Monoid r, ValidACCVector b n r) => Eq_ (ACCVector b (n::Nat) r) where --(==) :: ACCVector b n r -> ACCVector b n r -> A.Acc (A.Scalar Bool) {-# INLINE (==) #-} (ACCVector v2) == (ACCVector v1) = let @@ -181,7 +184,7 @@ instance , ExpField r --, Normed r , Ord_ r - , IsScalar r + , IsExpScalar r , VectorSpace r , KnownNat n ) => Metric (ACCVector b (n::Nat) r) @@ -194,7 +197,7 @@ instance drt = A.sqrt (A.sum dsq) in A.the drt -instance (P.Floating (A.Acc (A.Array A.DIM0 r)), KnownNat n, VectorSpace r, ValidACCVector b n r, IsScalar r, ExpField r) => Normed (ACCVector b (n::Nat) r) where +instance (P.Floating (A.Acc (A.Array A.DIM0 r)), KnownNat n, VectorSpace r, ValidACCVector b n r, ExpField r) => Normed (ACCVector b (n::Nat) r) where {-# INLINE size #-} --Could not deduce (r ~ A.Exp r) size :: ACCVector b (n::Nat) r -> A.Exp r @@ -205,12 +208,12 @@ instance (P.Floating (A.Acc (A.Array A.DIM0 r)), KnownNat n, VectorSpace r, Vali in A.the srt :: A.Exp r --- -- Couldn't match type ‘A.Acc (Scalar Bool)’ with ‘Bool’ +-- -- Couldn't match type ‘A.Exp Bool’ with ‘Bool’ instance ( VectorSpace r , ValidACCVector b n r - , IsScalar r + , IsExpScalar r , ExpField r , Real r , KnownNat n @@ -234,7 +237,7 @@ instance instance ( VectorSpace r , ValidACCVector b n r - , IsScalar r + , IsExpScalar r , ExpField r , Real r , OrdField r @@ -251,7 +254,7 @@ instance -- In Alegebra.Vector.hs this is defined in terms of HMatrix -- recreated here to satisfy constraints type MatrixField r = - ( IsScalar r + ( IsExpScalar r , VectorSpace r , Field r ) diff --git a/src/SubHask/Algebra/Matrix.hs b/src/SubHask/Algebra/Matrix.hs index 8d1e101..2d67bbb 100644 --- a/src/SubHask/Algebra/Matrix.hs +++ b/src/SubHask/Algebra/Matrix.hs @@ -33,6 +33,7 @@ type ValidMatrix vect r = , Hilbert vect , VectorSpace r , Prim r + , Index vect ~ Int ) type instance Scalar (Matrix vect r m n) = Scalar r diff --git a/stack.yaml b/stack.yaml index 8ff1ce3..ffe78a7 100644 --- a/stack.yaml +++ b/stack.yaml @@ -9,22 +9,22 @@ packages: git: https://github.com/AccelerateHS/accelerate-cuda commit: 05acd3adca9fd89a8ac19184afbed47d1b7d1505 extra-dep: true -- location: - git: https://github.com/AccelerateHS/accelerate-llvm.git - commit: 2c26ca7755a3f5acc3a56dd0f4a23565ba620501 - extra-dep: true - subdirs: - - accelerate-llvm - - accelerate-llvm-native - - accelerate-llvm-ptx +#- location: +# git: https://github.com/AccelerateHS/accelerate-llvm.git + # commit: 2c26ca7755a3f5acc3a56dd0f4a23565ba620501 + # extra-dep: true + # subdirs: + # - accelerate-llvm + # - accelerate-llvm-native + # - accelerate-llvm-ptx # required on OS X due to https://github.com/bscarlet/llvm-general/issues/155 -- location: - git: https://github.com/bscarlet/llvm-general.git - commit: 1ee693cc7577aab2f3e11ec9bd7f4244a5182c89 - extra-dep: true - subdirs: - - llvm-general +# - location: +# git: https://github.com/bscarlet/llvm-general.git +# commit: 1ee693cc7577aab2f3e11ec9bd7f4244a5182c89 +# extra-dep: true +# subdirs: +# - llvm-general extra-include-dirs: - /usr/local/include @@ -37,7 +37,7 @@ extra-deps: # accelerate-llvm - 'chaselev-deque-0.5.0.5' -- 'llvm-general-pure-3.5.0.0' +# - 'llvm-general-pure-3.5.0.0' # accelerate-llvm-native - 'libffi-0.1' @@ -61,14 +61,14 @@ flags: bounds-checks: true debug: true internal-checks: false - accelerate-llvm: - debug: true - chase-lev: true - accelerate-llvm-native: - debug: true - accelerate-llvm-ptx: - debug: true - libnvvm: false - llvm-general: - shared-llvm: true + # accelerate-llvm: + # debug: true + # chase-lev: true + # accelerate-llvm-native: + # debug: true + # accelerate-llvm-ptx: + # debug: true + # libnvvm: false + # llvm-general: + # shared-llvm: true resolver: lts-5.9 diff --git a/subhask.cabal b/subhask.cabal index c2e30f2..2332954 100644 --- a/subhask.cabal +++ b/subhask.cabal @@ -148,7 +148,7 @@ library accelerate , accelerate-cuda , cuda , - accelerate-llvm , + -- accelerate-llvm , -- compatibility control flow mtl , From ba4057eb9f59ec5d974938f4ea11970082ca1d43 Mon Sep 17 00:00:00 2001 From: timpierson Date: Sun, 26 Jun 2016 10:38:36 -0700 Subject: [PATCH 10/20] Merged ghc-8.0 with accelerate backend --- .travis.yml | 131 ++- README.md | 38 +- .../example0002-monad-instances-for-set.lhs | 10 +- src/SubHask.hs | 4 +- src/SubHask/Algebra.hs | 1008 +++++++---------- src/SubHask/Algebra/Array.hs | 404 ++----- src/SubHask/Algebra/Container.hs | 134 +-- src/SubHask/Algebra/Group.hs | 77 +- src/SubHask/Algebra/Logic.hs | 65 +- src/SubHask/Algebra/Matrix.hs | 43 +- src/SubHask/Algebra/Metric.hs | 24 +- src/SubHask/Algebra/Ord.hs | 25 +- src/SubHask/Algebra/Parallel.hs | 25 +- src/SubHask/Algebra/Random.hs | 14 - src/SubHask/Algebra/Ring.hs | 10 +- src/SubHask/Algebra/Trans/Kernel.hs | 106 -- src/SubHask/Algebra/Vector.hs | 700 +++--------- src/SubHask/Algebra/Vector/FFI.hs | 37 +- src/SubHask/Category.hs | 33 +- src/SubHask/Category/Algebra/HMatrix.hs.old | 298 ----- src/SubHask/Category/Algebra/TypeParams.hs | 61 - src/SubHask/Category/Finite.hs | 73 +- src/SubHask/Category/HMatrix.hs | 25 - src/SubHask/Category/Linear.hs | 30 - src/SubHask/Category/Linear/Objects.hs | 148 --- src/SubHask/Category/Polynomial.hs | 66 +- src/SubHask/Category/Product.hs | 7 - src/SubHask/Category/Slice.hs | 12 - src/SubHask/Category/Trans/Algebra.hs | 144 --- src/SubHask/Category/Trans/Bijective.hs | 44 +- src/SubHask/Category/Trans/Constrained.hs | 31 +- src/SubHask/Category/Trans/Continuous.hs | 14 - src/SubHask/Category/Trans/Derivative.hs | 56 +- src/SubHask/Category/Trans/Linear.hs | 33 - src/SubHask/Category/Trans/Monotonic.hs | 138 +-- src/SubHask/Compatibility/Base.hs | 47 +- src/SubHask/Compatibility/BloomFilter.hs | 8 +- src/SubHask/Compatibility/ByteString.hs | 32 +- src/SubHask/Compatibility/Cassava.hs | 3 +- src/SubHask/Compatibility/Containers.hs | 299 +++-- src/SubHask/Compatibility/HyperLogLog.hs | 2 - src/SubHask/Internal/Box.hs | 4 - src/SubHask/Internal/Prelude.hs | 20 +- src/SubHask/Monad.hs | 2 +- src/SubHask/Mutable.hs | 1 - src/SubHask/SubType.hs | 39 +- src/SubHask/TemplateHaskell/Base.hs | 57 +- src/SubHask/TemplateHaskell/CategoryTrans.hs | 137 --- src/SubHask/TemplateHaskell/Common.hs | 5 +- src/SubHask/TemplateHaskell/Deriving.hs | 101 +- src/SubHask/TemplateHaskell/Mutable.hs | 23 +- src/SubHask/TemplateHaskell/Test.hs | 38 +- stack.yaml | 3 + subhask.cabal | 138 +-- test/TestSuite.hs | 2 +- 55 files changed, 1433 insertions(+), 3596 deletions(-) delete mode 100644 src/SubHask/Algebra/Random.hs delete mode 100644 src/SubHask/Algebra/Trans/Kernel.hs delete mode 100644 src/SubHask/Category/Algebra/HMatrix.hs.old delete mode 100644 src/SubHask/Category/Algebra/TypeParams.hs delete mode 100644 src/SubHask/Category/HMatrix.hs delete mode 100644 src/SubHask/Category/Linear.hs delete mode 100644 src/SubHask/Category/Linear/Objects.hs delete mode 100644 src/SubHask/Category/Trans/Algebra.hs delete mode 100644 src/SubHask/Category/Trans/Continuous.hs delete mode 100644 src/SubHask/Category/Trans/Linear.hs delete mode 100644 src/SubHask/Internal/Box.hs delete mode 100644 src/SubHask/TemplateHaskell/CategoryTrans.hs diff --git a/.travis.yml b/.travis.yml index d0a921b..aff6647 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,57 +1,90 @@ +# see https://github.com/hvr/multi-ghc-travis for structure + +# Use new container infrastructure to enable caching +sudo: false + # NB: don't set `language: haskell` here +language: c + +# The different configurations we want to test. +matrix: + include: -# The following enables several GHC versions to be tested; often it's enough to test only against the last release in a major GHC version. Feel free to omit lines listings versions you don't need/want testing for. -env: - - CABALVER=1.22 GHCVER=7.10.1 LLVMVER=3.5 - - CABALVER=1.22 GHCVER=7.10.2 LLVMVER=3.5 - # - CABALVER=head GHCVER=head # see section about GHC HEAD snapshots + - env: BUILD=stack + compiler: ": #stack 7.10.3" + addons: {apt: {packages: [ghc-7.10.3, libblas-dev, liblapack-dev, g++-4.8], sources: [hvr-ghc, ubuntu-toolchain-r-test]}} + +# Caching so the next build will be fast too. +cache: + directories: + - $HOME/.ghc + - $HOME/.cabal + - $HOME/.stack -# Note: the distinction between `before_install` and `install` is not important. before_install: +# Using compiler above sets CC to an invalid value, so unset it +- unset CC - - travis_retry sudo add-apt-repository -y ppa:hvr/ghc - - travis_retry sudo apt-get update - - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER # see note about happy/alex - - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH - - travis_retry sudo apt-get install libblas-dev liblapack-dev - - # update g++ - - g++ --version - - sudo add-apt-repository -y ppa:ubuntu-toolchain-r/test - - sudo apt-get update -qq - - sudo apt-get install -qq g++-4.8 - - g++ --version - - sudo update-alternatives --install /usr/bin/g++ g++ /usr/bin/g++-4.8 90 - - g++ --version - - # update llvm - - wget -O - http://llvm.org/apt/llvm-snapshot.gpg.key|sudo apt-key add - - - travis_retry sudo add-apt-repository "deb http://llvm.org/apt/precise/ llvm-toolchain-precise main" - - travis_retry sudo add-apt-repository "deb http://llvm.org/apt/precise/ llvm-toolchain-precise-$LLVMVER main" - - travis_retry sudo apt-get update - - sudo apt-get install -y llvm-$LLVMVER llvm-$LLVMVER-dev - #- sudo ln -s /usr/bin/opt-$LLVMVER /usr/bin/opt - - sudo rm -rf /usr/bin/opt && sudo ln -s /usr/bin/opt-$LLVMVER /usr/bin/opt - - sudo rm -rf /usr/bin/llc && sudo ln -s /usr/bin/llc-$LLVMVER /usr/bin/llc - - export PATH="/usr/bin:$PATH" +# We want to always allow newer versions of packages when building on GHC HEAD +- CABALARGS="" +- if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi -install: - - cabal --version - - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" - - travis_retry cabal update - - travis_retry cabal install -j4 --only-dependencies --enable-tests --enable-benchmarks +# Download and unpack the stack executable +- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$HOME/.cabal/bin:$PATH +- mkdir -p ~/.local/bin +- | + if [ `uname` = "Darwin" ] + then + travis_retry curl --insecure -L https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin + else + travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' + fi + # Use the more reliable S3 mirror of Hackage + mkdir -p $HOME/.cabal + echo 'remote-repo: hackage.haskell.org:http://hackage.fpcomplete.com/' > $HOME/.cabal/config + echo 'remote-repo-cache: $HOME/.cabal/packages' >> $HOME/.cabal/config + if [ "$CABALVER" != "1.16" ] + then + echo 'jobs: $ncpus' >> $HOME/.cabal/config + fi +# Get the list of packages from the stack.yaml file +- PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@') -# Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail. +install: +- echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" +- if [ -f configure.ac ]; then autoreconf -i; fi +- | + set -ex + case "$BUILD" in + stack) + stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies --flag subhask:-llvmsupport + ;; + cabal) + cabal --version + travis_retry cabal update + cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 -f-llvmsupport $CABALARGS $PACKAGES + ;; + esac + set +ex script: - - if [ -f configure.ac ]; then autoreconf -i; fi - - cabal configure --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging - - cabal build # this builds all libraries and executables (including tests/benchmarks) - - cabal test - - cabal check - - cabal sdist # tests that a source-distribution can be generated - -# Check that the resulting source distribution can be built & installed. -# If there are no other `.tar.gz` files in `dist`, this can be even simpler: -# `cabal install --force-reinstalls dist/*-*.tar.gz` - - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && - (cd dist && cabal install --force-reinstalls "$SRC_TGZ") +- | + set -ex + case "$BUILD" in + stack) + stack --no-terminal $ARGS test --bench --no-run-benchmarks --flag subhask:-llvmsupport + ;; + cabal) + cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 -f-llvmsupport $CABALARGS $PACKAGES + ORIGDIR=$(pwd) + for dir in $PACKAGES + do + cd $dir + cabal check || [ "$CABALVER" == "1.16" ] + cabal sdist + SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && \ + (cd dist && cabal install --force-reinstalls "$SRC_TGZ") + cd $ORIGDIR + done + ;; + esac + set +ex diff --git a/README.md b/README.md index bf064e7..6a3d8f6 100644 --- a/README.md +++ b/README.md @@ -1,5 +1,4 @@ -# SubHask - +# SubHask ![](https://travis-ci.org/mikeizbicki/subhask.png) SubHask is a radical rewrite of the Haskell [Prelude](https://www.haskell.org/onlinereport/standard-prelude.html). The goal is to make numerical computing in Haskell *fun* and *fast*. @@ -7,12 +6,6 @@ The main idea is to use a type safe interface for programming in arbitrary subca For example, the category [Vect](http://ncatlab.org/nlab/show/Vect) of linear functions is a subcategory of Hask, and SubHask exploits this fact to give a nice interface for linear algebra. To achieve this goal, almost every class hierarchy is redefined to be more general. - - - - - - - - - +will build the project, run the tests, and run the benchmark. ## Examples diff --git a/examples/example0002-monad-instances-for-set.lhs b/examples/example0002-monad-instances-for-set.lhs index 6bd906a..a62c29c 100644 --- a/examples/example0002-monad-instances-for-set.lhs +++ b/examples/example0002-monad-instances-for-set.lhs @@ -47,7 +47,7 @@ The type signatures below are not mandatory, just added for clarity. > fxs = fmap (proveOrdHask f) $ xs > > -- g is not monotonic -> let g :: (Eq a, Integral a) => a -> a +> let g :: (Eq a, Integral a, ClassicalLogic a) => a -> a > g x = if x`mod`2 == 0 then x else -x > > gxs :: LexSet Int @@ -93,18 +93,18 @@ The type signatures are provided only to aide reading. > let oddneg :: Int `OrdHask` (LexSet Int) > oddneg = proveConstrained f > where -> f :: (Integral a, Ord a) => a -> LexSet a +> f :: (Integral a, Ord a, ClassicalLogic a) => a -> LexSet a > f i = if i `mod` 2 == 0 > then [i] > else [-i] > -> let times3 :: (Ord a, Ring a) => a `OrdHask` (LexSet a) +> let times3 :: (Ord a, Ring a, ClassicalLogic a) => a `OrdHask` (LexSet a) > times3 = proveConstrained f > where -> f :: (Ord a, Ring a) => a -> LexSet a +> f :: (Ord a, Ring a, ClassicalLogic a) => a -> LexSet a > f a = [a,2*a,3*a] > -> let times3mon :: (Ord a, Ring a) => a `Mon` (LexSet a) +> let times3mon :: (Ord a, Ring a, ClassicalLogic a) => a `Mon` (LexSet a) > times3mon = unsafeProveMon (times3 $) > > putStrLn "" diff --git a/src/SubHask.hs b/src/SubHask.hs index ef9117c..999ee6a 100644 --- a/src/SubHask.hs +++ b/src/SubHask.hs @@ -3,7 +3,7 @@ module SubHask ( module SubHask.Algebra , module SubHask.Category - , module SubHask.Compatibility.Base + -- , module SubHask.Compatibility.Base , module SubHask.Internal.Prelude , module SubHask.Monad , module SubHask.SubType @@ -11,7 +11,7 @@ module SubHask import SubHask.Algebra import SubHask.Category -import SubHask.Compatibility.Base +import SubHask.Compatibility.Base() import SubHask.Internal.Prelude import SubHask.Monad import SubHask.SubType diff --git a/src/SubHask/Algebra.hs b/src/SubHask/Algebra.hs index ebf1116..7c24211 100644 --- a/src/SubHask/Algebra.hs +++ b/src/SubHask/Algebra.hs @@ -1,4 +1,9 @@ -{-# LANGUAGE CPP,MagicHash,UnboxedTuples #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# OPTIONS_GHC -fno-warn-missing-methods #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- | This module defines the algebraic type-classes used in subhask. -- The class hierarchies are significantly more general than those in the standard Prelude. @@ -6,22 +11,23 @@ module SubHask.Algebra ( -- * Comparisons Logic - , ValidLogic + , TLogic , ClassicalLogic - , Eq_ (..) - , Eq - , ValidEq + , Elem + , TElem + , Container (..) + , law_Container_preservation + , ifThenElse + , Eq (..) , law_Eq_reflexive , law_Eq_symmetric , law_Eq_transitive , defn_Eq_noteq - , POrd_ (..) - , POrd + , POrd (..) , law_POrd_commutative , law_POrd_associative , theorem_POrd_idempotent - , Lattice_ (..) - , Lattice + , Lattice (..) , isChain , isAntichain , POrdering (..) @@ -34,8 +40,7 @@ module SubHask.Algebra , law_Lattice_antisymmetry , law_Lattice_transitivity , defn_Lattice_greaterthan - , MinBound_ (..) - , MinBound + , MinBound (..) , law_MinBound_inf , Bounded (..) , law_Bounded_sup @@ -51,19 +56,15 @@ module SubHask.Algebra , law_Heyting_infleft , law_Heyting_infright , law_Heyting_distributive - , Boolean (..) + , Boolean , law_Boolean_infcomplement , law_Boolean_supcomplement , law_Boolean_infdistributivity , law_Boolean_supdistributivity - --- , defn_Latticelessthaninf --- , defn_Latticelessthansup - , Ord_ (..) + , Ord (..) , law_Ord_totality , law_Ord_min , law_Ord_max - , Ord , Ordering (..) , min , max @@ -73,12 +74,12 @@ module SubHask.Algebra , minimum_ , argmin , argmax --- , argminimum_ --- , argmaximum_ , Graded (..) , law_Graded_fromEnum , law_Graded_pred , defn_Graded_predN + , (>.) + , (<.) , Enum (..) , law_Enum_toEnum , law_Enum_succ @@ -93,11 +94,6 @@ module SubHask.Algebra , or -- * Set-like - , Elem - , SetElem - , Container (..) - , law_Container_preservation - , Constructible (..) , Constructible0 , law_Constructible_singleton @@ -113,6 +109,8 @@ module SubHask.Algebra , insert , empty , isEmpty + , infDisjoint + , sizeDisjoint , Foldable (..) , law_Foldable_sum @@ -127,6 +125,7 @@ module SubHask.Algebra , defn_Foldable_foldl1' , foldtree1 + , convertUnfoldable , length , reduce , concat @@ -169,6 +168,7 @@ module SubHask.Algebra , Semigroup (..) , law_Semigroup_associativity , defn_Semigroup_plusequal + , cycle , Actor , Action (..) , law_Action_compatibility @@ -184,7 +184,7 @@ module SubHask.Algebra , law_Monoid_leftid , law_Monoid_rightid , defn_Monoid_isZero - , Abelian (..) + , Abelian , law_Abelian_commutative , Group (..) , law_Group_leftinverse @@ -215,7 +215,7 @@ module SubHask.Algebra -- , roundUpToNearestBase2 , fromIntegral , Field(..) - , OrdField(..) + , OrdField , RationalField(..) , convertRationalField , toFloat @@ -242,9 +242,9 @@ module SubHask.Algebra -- ** Linear algebra , Scalar - , IsScalar + , TScalar + , ValidScalar , HasScalar - , type (><) , Cone (..) , Module (..) , law_Module_multiplication @@ -260,15 +260,15 @@ module SubHask.Algebra , defn_FreeModule_dotstardotequal , FiniteModule (..) , VectorSpace (..) + , Reisz (..) , Banach (..) + , law_Banach_distance + , law_Banach_size , Hilbert (..) + , TSquare + , squaredInnerProductNorm , innerProductDistance , innerProductNorm - , TensorAlgebra (..) - - -- * Spatial programming - , Any (..) - , All -- * Helper functions , simpleMutableDefn @@ -281,33 +281,27 @@ import qualified Data.Number.Erf as P import qualified Math.Gamma as P import qualified Data.List as L -import Prelude (Ordering (..)) import Control.Monad hiding (liftM) import Control.Monad.ST import Data.Ratio import Data.Typeable -import Test.QuickCheck (Arbitrary (..), frequency) +import Test.QuickCheck (frequency) -import Control.Concurrent -import Control.Parallel import Control.Parallel.Strategies -import System.IO.Unsafe -- used in the parallel function -import GHC.Prim hiding (Any) -import GHC.Types -import GHC.Magic +import GHC.Types hiding (Module) import SubHask.Internal.Prelude import SubHask.Category import SubHask.Mutable -import SubHask.SubType +import Homoiconic.Constrained ------------------------------------------------------------------------------- -- Helper functions -- | Creates a quickcheck property for a simple mutable operator defined using "immutable2mutable" -simpleMutableDefn :: (Eq_ a, IsMutable a) +simpleMutableDefn :: (Eq a, IsMutable a) => (Mutable (ST s) a -> b -> ST s ()) -- ^ mutable function -> (a -> b -> a) -- ^ create a mutable function using "immutable2mutable" -> (a -> b -> Logic a) -- ^ the output property @@ -321,7 +315,53 @@ simpleMutableDefn mf f a b = unsafeRunMutableProperty $ do return $ a1==a2 ------------------------------------------------------------------------------- --- relational classes +-- comparison hierarchy + +-- | This is a generalization of a "set". +-- We do not require a container to be a boolean algebra, just a semigroup. +class Eq a => Container a where + {-# MINIMAL elem | notElem #-} + elem :: Elem a -> a -> Logic a + elem = not notElem + + notElem :: Elem a -> a -> Logic a + notElem = not elem + +law_Container_preservation :: Container s => s -> s -> Elem s -> Logic s +law_Container_preservation a1 a2 e = (a1==a2) ==> ((e `elem` a1) ==> (e `elem` a2)) + +type instance Elem Bool = () +instance Container Bool where + elem _ True = True + elem _ False = False + +type instance Elem () = () +instance Container () where + elem () = \_ -> () + +instance Eq b => Container (a -> b) + +-------------------- + +class + ( Monoid (Elem a) + , Container a + , IfThenElse (Logic a) + ) => IfThenElse a + where + ifThenElse :: a -> b -> b -> b + ifThenElse a b1 b2 = ifThenElse (zero `elem` a) b1 b2 + +instance Semigroup Bool where (+) = (||) +instance Monoid Bool where zero = False +instance IfThenElse Bool where + ifThenElse True b _ = b + ifThenElse False _ b = b + +instance IfThenElse () where + ifThenElse () b _ = b + +---------------------------------------- -- | Every type has an associated logic. -- Most types use classical logic, which corresponds to the Bool type. @@ -332,39 +372,25 @@ simpleMutableDefn mf f a b = unsafeRunMutableProperty $ do -- See wikipedia's articles on , -- and for more details. type family Logic a :: * -type instance Logic Bool = Bool -type instance Logic Char = Bool -type instance Logic Int = Bool -type instance Logic Integer = Bool -type instance Logic Rational = Bool -type instance Logic Float = Bool -type instance Logic Double = Bool -type instance Logic (a->b) = a -> Logic b -type instance Logic () = () --- FIXME: --- This type is only needed to due an apparent ghc bug. --- See [#10592](https://ghc.haskell.org/trac/ghc/ticket/10592). --- But there seems to be a workaround now. -type ValidLogic a = Complemented (Logic a) +type IdempLogic a = Logic (Logic a)~Logic a --- | Classical logic is implemented using the Prelude's Bool type. -type ClassicalLogic a = Logic a ~ Bool +type ClassicalLogic a = Logic a ~Bool -- | Defines equivalence classes over the type. -- The values need not have identical representations in the machine to be equal. -- -- See -- and for more details. -class Eq_ a where +class (IdempLogic a, Container (Logic a), Boolean (Logic a)) => Eq a where + {-# MINIMAL (==) | (/=) #-} infix 4 == (==) :: a -> a -> Logic a + (==) = not (/=) - -- | In order to have the "not equals to" relation, your logic must have a notion of "not", and therefore must be "Boolean". - {-# INLINE (/=) #-} infix 4 /= - (/=) :: ValidLogic a => a -> a -> Logic a + (/=) :: a -> a -> Logic a (/=) = not (==) law_Eq_reflexive :: Eq a => a -> Logic a @@ -376,41 +402,38 @@ law_Eq_symmetric a1 a2 = (a1==a2)==(a2==a1) law_Eq_transitive :: Eq a => a -> a -> a -> Logic a law_Eq_transitive a1 a2 a3 = (a1==a2&&a2==a3) ==> (a1==a3) -defn_Eq_noteq :: (Complemented (Logic a), Eq a) => a -> a -> Logic a +defn_Eq_noteq :: Eq a => a -> a -> Logic a defn_Eq_noteq a1 a2 = (a1/=a2) == (not $ a1==a2) -instance Eq_ () where - {-# INLINE (==) #-} - () == () = () - - {-# INLINE (/=) #-} - () /= () = () +#define mkEq(x) \ +type instance Logic x = Bool; \ +instance Eq x where (==) = (P.==); (/=) = (P./=) -instance Eq_ Bool where (==) = (P.==); (/=) = (P./=); {-# INLINE (==) #-}; {-# INLINE (/=) #-} -instance Eq_ Char where (==) = (P.==); (/=) = (P./=); {-# INLINE (==) #-}; {-# INLINE (/=) #-} -instance Eq_ Int where (==) = (P.==); (/=) = (P./=); {-# INLINE (==) #-}; {-# INLINE (/=) #-} -instance Eq_ Integer where (==) = (P.==); (/=) = (P./=); {-# INLINE (==) #-}; {-# INLINE (/=) #-} -instance Eq_ Rational where (==) = (P.==); (/=) = (P./=); {-# INLINE (==) #-}; {-# INLINE (/=) #-} -instance Eq_ Float where (==) = (P.==); (/=) = (P./=); {-# INLINE (==) #-}; {-# INLINE (/=) #-} -instance Eq_ Double where (==) = (P.==); (/=) = (P./=); {-# INLINE (==) #-}; {-# INLINE (/=) #-} - -instance Eq_ b => Eq_ (a -> b) where - {-# INLINE (==) #-} - (f==g) a = f a == g a +mkEq(Bool) +mkEq(Char) +mkEq(Int) +mkEq(Integer) +mkEq(Rational) +mkEq(Float) +mkEq(Double) -type Eq a = (Eq_ a, Logic a~Bool) -type ValidEq a = (Eq_ a, ValidLogic a) +type instance Logic () = () +instance Eq () where + () == () = () + () /= () = () --- class (Eq_ a, Logic a ~ Bool) => Eq a --- instance (Eq_ a, Logic a ~ Bool) => Eq a --- --- class (Eq_ a, ValidLogic a) => ValidEq a --- instance (Eq_ a, ValidLogic a) => ValidEq a +-- type instance Logic (a -> b) = (Neighbor (a -> b) -> Bool) +type instance Logic (a -> b) = a -> Logic b +instance Eq b => Eq (a -> b) where +-- (==) f g (xs,nb) = go xs +-- where +-- go (x:xs) = (f x==g x) nb && go xs +-- go [] = True -------------------- -- | This is more commonly known as a "meet" semilattice -class Eq_ b => POrd_ b where +class Eq b => POrd b where inf :: b -> b -> b {-# INLINE (<=) #-} @@ -419,25 +442,20 @@ class Eq_ b => POrd_ b where b1 <= b2 = inf b1 b2 == b1 {-# INLINE (<) #-} - infix 4 < - (<) :: Complemented (Logic b) => b -> b -> Logic b + (<) :: b -> b -> Logic b b1 < b2 = inf b1 b2 == b1 && b1 /= b2 -type POrd a = (Eq a, POrd_ a) --- class (Eq b, POrd_ b) => POrd b --- instance (Eq b, POrd_ b) => POrd b - -law_POrd_commutative :: (Eq b, POrd_ b) => b -> b -> Bool +law_POrd_commutative :: POrd b => b -> b -> Logic b law_POrd_commutative b1 b2 = inf b1 b2 == inf b2 b1 -law_POrd_associative :: (Eq b, POrd_ b) => b -> b -> b -> Bool +law_POrd_associative :: POrd b => b -> b -> b -> Logic b law_POrd_associative b1 b2 b3 = inf (inf b1 b2) b3 == inf b1 (inf b2 b3) -theorem_POrd_idempotent :: (Eq b, POrd_ b) => b -> Bool +theorem_POrd_idempotent :: POrd b => b -> Logic b theorem_POrd_idempotent b = inf b b == b -#define mkPOrd_(x) \ -instance POrd_ x where \ +#define mkPOrd(x) \ +instance POrd x where \ inf = (P.min) ;\ (<=) = (P.<=) ;\ (<) = (P.<) ;\ @@ -445,23 +463,23 @@ instance POrd_ x where \ {-# INLINE (<=) #-} ;\ {-# INLINE (<) #-} -mkPOrd_(Bool) -mkPOrd_(Char) -mkPOrd_(Int) -mkPOrd_(Integer) -mkPOrd_(Float) -mkPOrd_(Double) -mkPOrd_(Rational) +mkPOrd(Bool) +mkPOrd(Char) +mkPOrd(Int) +mkPOrd(Integer) +mkPOrd(Float) +mkPOrd(Double) +mkPOrd(Rational) -instance POrd_ () where +instance POrd () where {-# INLINE inf #-} inf () () = () -instance POrd_ b => POrd_ (a -> b) where +instance POrd b => POrd (a -> b) where {-# INLINE inf #-} inf f g = \x -> inf (f x) (g x) - {-# INLINE (<) #-} + {-# INLINE (<=) #-} (f<=g) a = f a <= g a ------------------- @@ -470,30 +488,26 @@ instance POrd_ b => POrd_ (a -> b) where -- -- prop> minBound <= b || not (minBound > b) -- -class POrd_ b => MinBound_ b where +class POrd b => MinBound b where minBound :: b -type MinBound a = (Eq a, MinBound_ a) --- class (Eq b, MinBound_ b) => MinBound b --- instance (Eq b, MinBound_ b) => MinBound b - -law_MinBound_inf :: (Eq b, MinBound_ b) => b -> Bool +law_MinBound_inf :: MinBound b => b -> Logic b law_MinBound_inf b = inf b minBound == minBound -- | "false" is an upper bound because `a && false = false` for all a. {-# INLINE false #-} -false :: MinBound_ b => b +false :: MinBound b => b false = minBound -instance MinBound_ () where minBound = () ; {-# INLINE minBound #-} -instance MinBound_ Bool where minBound = False ; {-# INLINE minBound #-} -instance MinBound_ Char where minBound = P.minBound ; {-# INLINE minBound #-} -instance MinBound_ Int where minBound = P.minBound ; {-# INLINE minBound #-} -instance MinBound_ Float where minBound = -1/0 ; {-# INLINE minBound #-} -instance MinBound_ Double where minBound = -1/0 ; {-# INLINE minBound #-} +instance MinBound () where minBound = () ; {-# INLINE minBound #-} +instance MinBound Bool where minBound = False ; {-# INLINE minBound #-} +instance MinBound Char where minBound = P.minBound ; {-# INLINE minBound #-} +instance MinBound Int where minBound = P.minBound ; {-# INLINE minBound #-} +instance MinBound Float where minBound = -1/0 ; {-# INLINE minBound #-} +instance MinBound Double where minBound = -1/0 ; {-# INLINE minBound #-} -- FIXME: should be a primop for this -instance MinBound_ b => MinBound_ (a -> b) where minBound = \x -> minBound ; {-# INLINE minBound #-} +instance MinBound b => MinBound (a -> b) where minBound = \_ -> minBound ; {-# INLINE minBound #-} ------------------- @@ -515,7 +529,7 @@ instance Arbitrary POrdering where , (1, P.return PNA) ] -instance Eq_ POrdering where +instance Eq POrdering where {-# INLINE (==) #-} PLT == PLT = True PGT == PGT = True @@ -534,7 +548,7 @@ instance Semigroup POrdering where type instance Logic Ordering = Bool -instance Eq_ Ordering where +instance Eq Ordering where {-# INLINE (==) #-} EQ == EQ = True LT == LT = True @@ -559,8 +573,8 @@ instance Monoid Ordering where -- | -- -- --- See for more details. -class POrd_ b => Lattice_ b where +-- See for more details. +class POrd b => Lattice b where sup :: b -> b -> b {-# INLINE (>=) #-} @@ -569,8 +583,7 @@ class POrd_ b => Lattice_ b where b1 >= b2 = sup b1 b2 == b1 {-# INLINE (>) #-} - infix 4 > - (>) :: Boolean (Logic b) => b -> b -> Logic b + (>) :: b -> b -> Logic b b1 > b2 = sup b1 b2 == b1 && b1 /= b2 -- | This function does not make sense on non-classical logics @@ -587,34 +600,30 @@ class POrd_ b => Lattice_ b where then PGT else PNA -type Lattice a = (Eq a, Lattice_ a) --- class (Eq b, Lattice_ b) => Lattice b --- instance (Eq b, Lattice_ b) => Lattice b - -law_Lattice_commutative :: (Eq b, Lattice_ b) => b -> b -> Bool +law_Lattice_commutative :: Lattice b => b -> b -> Logic b law_Lattice_commutative b1 b2 = sup b1 b2 == sup b2 b1 -law_Lattice_associative :: (Eq b, Lattice_ b) => b -> b -> b -> Bool +law_Lattice_associative :: Lattice b => b -> b -> b -> Logic b law_Lattice_associative b1 b2 b3 = sup (sup b1 b2) b3 == sup b1 (sup b2 b3) -theorem_Lattice_idempotent :: (Eq b, Lattice_ b) => b -> Bool +theorem_Lattice_idempotent :: Lattice b => b -> Logic b theorem_Lattice_idempotent b = sup b b == b -law_Lattice_infabsorption :: (Eq b, Lattice b) => b -> b -> Bool +law_Lattice_infabsorption :: Lattice b => b -> b -> Logic b law_Lattice_infabsorption b1 b2 = inf b1 (sup b1 b2) == b1 -law_Lattice_supabsorption :: (Eq b, Lattice b) => b -> b -> Bool +law_Lattice_supabsorption :: Lattice b => b -> b -> Logic b law_Lattice_supabsorption b1 b2 = sup b1 (inf b1 b2) == b1 law_Lattice_reflexivity :: Lattice a => a -> Logic a law_Lattice_reflexivity a = a<=a -law_Lattice_antisymmetry :: Lattice a => a -> a -> Logic a +law_Lattice_antisymmetry :: (ClassicalLogic a, Lattice a) => a -> a -> Logic a law_Lattice_antisymmetry a1 a2 | a1 <= a2 && a2 <= a1 = a1 == a2 | otherwise = true -law_Lattice_transitivity :: Lattice a => a -> a -> a -> Logic a +law_Lattice_transitivity :: (ClassicalLogic a, Lattice a) => a -> a -> a -> Logic a law_Lattice_transitivity a1 a2 a3 | a1 <= a2 && a2 <= a3 = a1 <= a3 | a1 <= a3 && a3 <= a2 = a1 <= a2 @@ -624,14 +633,14 @@ law_Lattice_transitivity a1 a2 a3 | a3 <= a1 && a1 <= a2 = a3 <= a2 | otherwise = true -defn_Lattice_greaterthan :: Lattice a => a -> a -> Logic a +defn_Lattice_greaterthan :: (ClassicalLogic a, Lattice a) => a -> a -> Logic a defn_Lattice_greaterthan a1 a2 | a1 < a2 = a2 >= a1 | a1 > a2 = a2 <= a1 | otherwise = true -#define mkLattice_(x)\ -instance Lattice_ x where \ +#define mkLattice(x)\ +instance Lattice x where \ sup = (P.max) ;\ (>=) = (P.>=) ;\ (>) = (P.>) ;\ @@ -639,19 +648,19 @@ instance Lattice_ x where \ {-# INLINE (>=) #-} ;\ {-# INLINE (>) #-} -mkLattice_(Bool) -mkLattice_(Char) -mkLattice_(Int) -mkLattice_(Integer) -mkLattice_(Float) -mkLattice_(Double) -mkLattice_(Rational) +mkLattice(Bool) +mkLattice(Char) +mkLattice(Int) +mkLattice(Integer) +mkLattice(Float) +mkLattice(Double) +mkLattice(Rational) -instance Lattice_ () where +instance Lattice () where {-# INLINE sup #-} sup () () = () -instance Lattice_ b => Lattice_ (a -> b) where +instance Lattice b => Lattice (a -> b) where {-# INLINE sup #-} sup f g = \x -> sup (f x) (g x) @@ -660,17 +669,17 @@ instance Lattice_ b => Lattice_ (a -> b) where {-# INLINE (&&) #-} infixr 3 && -(&&) :: Lattice_ b => b -> b -> b +(&&) :: Lattice b => b -> b -> b (&&) = inf {-# INLINE (||) #-} infixr 2 || -(||) :: Lattice_ b => b -> b -> b +(||) :: Lattice b => b -> b -> b (||) = sup -- | A chain is a collection of elements all of which can be compared {-# INLINABLE isChain #-} -isChain :: Lattice a => [a] -> Logic a +isChain :: (Lattice a, ClassicalLogic a) => [a] -> Logic a isChain [] = true isChain (x:xs) = all (/=PNA) (map (pcompare x) xs) && isChain xs @@ -680,7 +689,7 @@ isChain (x:xs) = all (/=PNA) (map (pcompare x) xs) && isChain xs -- -- See also the article on . {-# INLINABLE isAntichain #-} -isAntichain :: Lattice a => [a] -> Logic a +isAntichain :: (Lattice a, ClassicalLogic a) => [a] -> Logic a isAntichain [] = true isAntichain (x:xs) = all (==PNA) (map (pcompare x) xs) && isAntichain xs @@ -704,7 +713,7 @@ class Lattice b => Graded b where | i == 0 = b | i > 0 = predN (i-1) $ pred b -law_Graded_fromEnum :: (Lattice b, Graded b) => b -> b -> Bool +law_Graded_fromEnum :: (Lattice b, ClassicalLogic b, Graded b) => b -> b -> Bool law_Graded_fromEnum b1 b2 | b1 < b2 = fromEnum b1 < fromEnum b2 | b1 > b2 = fromEnum b1 > fromEnum b2 @@ -712,16 +721,17 @@ law_Graded_fromEnum b1 b2 | otherwise = True law_Graded_pred :: Graded b => b -> b -> Bool -law_Graded_pred b1 b2 = fromEnum (pred b1) == fromEnum b1-1 +law_Graded_pred b1 _ = fromEnum (pred b1) == fromEnum b1-1 || fromEnum (pred b1) == fromEnum b1 -defn_Graded_predN :: Graded b => Int -> b -> Bool +defn_Graded_predN :: Graded b => Int -> b -> Logic b defn_Graded_predN i b | i < 0 = true | otherwise = go i b == predN i b where - go 0 b = b - go i b = go (i-1) $ pred b + go :: Graded b => Int -> b -> b + go 0 b' = b' + go i' b' = go (i'-1) $ pred b' instance Graded Bool where {-# INLINE pred #-} @@ -766,14 +776,14 @@ instance Graded Integer where fromEnum = P.fromEnum {-# INLINE (<.) #-} -(<.) :: (Lattice b, Graded b) => b -> b -> Bool +(<.) :: Graded b => b -> b -> Logic b b1 <. b2 = b1 == pred b2 -- | In a well founded ordering, every element (except possibly the "maxBound" if it exists) has a successor element. -- We use the "Enum" to represent well founded orderings to maintain consistency with the standard Prelude. -- -- See for more info. -class (Graded b, Ord_ b) => Enum b where +class (Graded b, Ord b) => Enum b where -- | The next element in the ordering succ :: b -> b @@ -785,12 +795,12 @@ class (Graded b, Ord_ b) => Enum b where -- | Given an index (also called a rank) of an element, return the element toEnum :: Int -> b -law_Enum_toEnum :: Enum b => b -> Bool +law_Enum_toEnum :: Enum b => b -> Logic b law_Enum_toEnum b = toEnum (fromEnum b) == b -law_Enum_succ :: Enum b => b -> b -> Bool -law_Enum_succ b1 b2 = fromEnum (succ b1) == fromEnum b1+1 - || fromEnum (succ b1) == fromEnum b1 +law_Enum_succ :: Enum b => b -> Bool +law_Enum_succ b1 = fromEnum (succ b1) == fromEnum b1+1 + || fromEnum (succ b1) == fromEnum b1 defn_Enum_succN :: Enum b => Int -> b -> Logic b defn_Enum_succN i b = succN i b == toEnum (fromEnum b + i) @@ -832,7 +842,7 @@ instance Enum Integer where {-# INLINE (>.) #-} -(>.) :: (Lattice b, Enum b) => b -> b -> Bool +(>.) :: Enum b => b -> b -> Logic b b1 >. b2 = b1 == succ b2 --------------------------------------- @@ -840,52 +850,50 @@ b1 >. b2 = b1 == succ b2 -- | This is the class of total orderings. -- -- See https://en.wikipedia.org/wiki/Total_order -class Lattice_ a => Ord_ a where - compare :: (Logic a~Bool, Ord_ a) => a -> a -> Ordering +class Lattice a => Ord a where + compare :: ClassicalLogic a => a -> a -> Ordering compare a1 a2 = case pcompare a1 a2 of PLT -> LT PGT -> GT PEQ -> EQ PNA -> error "PNA given by pcompare on a totally ordered type" -law_Ord_totality :: Ord a => a -> a -> Bool +law_Ord_totality :: Ord a => a -> a -> Logic a law_Ord_totality a1 a2 = a1 <= a2 || a2 <= a1 -law_Ord_min :: Ord a => a -> a -> Bool +law_Ord_min :: Ord a => a -> a -> Logic a law_Ord_min a1 a2 = min a1 a2 == a1 || min a1 a2 == a2 -law_Ord_max :: Ord a => a -> a -> Bool +law_Ord_max :: Ord a => a -> a -> Logic a law_Ord_max a1 a2 = max a1 a2 == a1 || max a1 a2 == a2 {-# INLINE min #-} -min :: Ord_ a => a -> a -> a +min :: Ord a => a -> a -> a min = inf {-# INLINE max #-} -max :: Ord_ a => a -> a -> a +max :: Ord a => a -> a -> a max = sup -type Ord a = (Eq a, Ord_ a) - -instance Ord_ () -instance Ord_ Char where compare = P.compare ; {-# INLINE compare #-} -instance Ord_ Int where compare = P.compare ; {-# INLINE compare #-} -instance Ord_ Integer where compare = P.compare ; {-# INLINE compare #-} -instance Ord_ Float where compare = P.compare ; {-# INLINE compare #-} -instance Ord_ Double where compare = P.compare ; {-# INLINE compare #-} -instance Ord_ Rational where compare = P.compare ; {-# INLINE compare #-} -instance Ord_ Bool where compare = P.compare ; {-# INLINE compare #-} +instance Ord () +instance Ord Char where compare = P.compare ; {-# INLINE compare #-} +instance Ord Int where compare = P.compare ; {-# INLINE compare #-} +instance Ord Integer where compare = P.compare ; {-# INLINE compare #-} +instance Ord Float where compare = P.compare ; {-# INLINE compare #-} +instance Ord Double where compare = P.compare ; {-# INLINE compare #-} +instance Ord Rational where compare = P.compare ; {-# INLINE compare #-} +instance Ord Bool where compare = P.compare ; {-# INLINE compare #-} ------------------- -- | A Bounded lattice is a lattice with both a minimum and maximum element -- -class (Lattice_ b, MinBound_ b) => Bounded b where +class (Lattice b, MinBound b) => Bounded b where maxBound :: b -law_Bounded_sup :: (Eq b, Bounded b) => b -> Bool +law_Bounded_sup :: Bounded b => b -> Logic b law_Bounded_sup b = sup b maxBound == maxBound -- | "true" is an lower bound because `a && true = true` for all a. @@ -903,14 +911,14 @@ instance Bounded Double where maxBound = 1/0 ; {-# INLINE maxBound #-} instance Bounded b => Bounded (a -> b) where {-# INLINE maxBound #-} - maxBound = \x -> maxBound + maxBound = \_ -> maxBound -------------------- class Bounded b => Complemented b where not :: b -> b -law_Complemented_not :: (ValidLogic b, Complemented b) => b -> Logic b +law_Complemented_not :: Complemented b => b -> Logic b law_Complemented_not b = not (true `asTypeOf` b) == false && not (false `asTypeOf` b) == true @@ -946,16 +954,16 @@ class Bounded b => Heyting b where infixl 3 ==> (==>) :: b -> b -> b -law_Heyting_maxbound :: (Eq b, Heyting b) => b -> Bool +law_Heyting_maxbound :: Heyting b => b -> Logic b law_Heyting_maxbound b = (b ==> b) == maxBound -law_Heyting_infleft :: (Eq b, Heyting b) => b -> b -> Bool +law_Heyting_infleft :: Heyting b => b -> b -> Logic b law_Heyting_infleft b1 b2 = (b1 && (b1 ==> b2)) == (b1 && b2) -law_Heyting_infright :: (Eq b, Heyting b) => b -> b -> Bool +law_Heyting_infright :: Heyting b => b -> b -> Logic b law_Heyting_infright b1 b2 = (b2 && (b1 ==> b2)) == b2 -law_Heyting_distributive :: (Eq b, Heyting b) => b -> b -> b -> Bool +law_Heyting_distributive :: Heyting b => b -> b -> b -> Logic b law_Heyting_distributive b1 b2 b3 = (b1 ==> (b2 && b3)) == ((b1 ==> b2) && (b1 ==> b3)) -- | FIXME: add the axioms for intuitionist logic, which are theorems based on these laws @@ -985,16 +993,16 @@ instance Heyting b => Heyting (a -> b) where -- See for more details. class (Complemented b, Heyting b) => Boolean b where -law_Boolean_infcomplement :: (Eq b, Boolean b) => b -> Bool +law_Boolean_infcomplement :: Boolean b => b -> Logic b law_Boolean_infcomplement b = (b || not b) == true -law_Boolean_supcomplement :: (Eq b, Boolean b) => b -> Bool +law_Boolean_supcomplement :: Boolean b => b -> Logic b law_Boolean_supcomplement b = (b && not b) == false -law_Boolean_infdistributivity :: (Eq b, Boolean b) => b -> b -> b -> Bool +law_Boolean_infdistributivity :: Boolean b => b -> b -> b -> Logic b law_Boolean_infdistributivity b1 b2 b3 = (b1 || (b2 && b3)) == ((b1 || b2) && (b1 || b3)) -law_Boolean_supdistributivity :: (Eq b, Boolean b) => b -> b -> b -> Bool +law_Boolean_supdistributivity :: Boolean b => b -> b -> b -> Logic b law_Boolean_supdistributivity b1 b2 b3 = (b1 && (b2 || b3)) == ((b1 && b2) || (b1 && b3)) instance Boolean () @@ -1014,21 +1022,15 @@ class IsMutable g => Semigroup g where {-# INLINE (+=) #-} infixr 5 += - (+=) :: (PrimBase m) => Mutable m g -> g -> m () + (+=) :: PrimBase m => Mutable m g -> g -> m () (+=) = immutable2mutable (+) -law_Semigroup_associativity :: (Eq g, Semigroup g ) => g -> g -> g -> Logic g +law_Semigroup_associativity :: (Eq g, Semigroup g) => g -> g -> g -> Logic g law_Semigroup_associativity g1 g2 g3 = g1 + (g2 + g3) == (g1 + g2) + g3 -defn_Semigroup_plusequal :: (Eq_ g, Semigroup g, IsMutable g) => g -> g -> Logic g +defn_Semigroup_plusequal :: (Eq g, Semigroup g) => g -> g -> Logic g defn_Semigroup_plusequal = simpleMutableDefn (+=) (+) --- | Measures the degree to which a Semigroup obeys the associative law. --- --- FIXME: Less-than-perfect associativity should be formalized in the class laws somehow. -associator :: (Semigroup g, Metric g) => g -> g -> g -> Scalar g -associator g1 g2 g3 = distance ((g1+g2)+g3) (g1+(g2+g3)) - -- | A generalization of 'Data.List.cycle' to an arbitrary 'Semigroup'. -- May fail to terminate for some values in some semigroups. cycle :: Semigroup m => m -> m @@ -1077,10 +1079,10 @@ class (IsMutable s, Semigroup (Actor s)) => Action s where (.+=) :: (PrimBase m) => Mutable m s -> Actor s -> m () (.+=) = immutable2mutable (.+) -law_Action_compatibility :: (Eq_ s, Action s) => Actor s -> Actor s -> s -> Logic s +law_Action_compatibility :: (Eq s, Action s) => Actor s -> Actor s -> s -> Logic s law_Action_compatibility a1 a2 s = (a1+a2) +. s == a1 +. a2 +. s -defn_Action_dotplusequal :: (Eq_ s, Action s, Logic (Actor s)~Logic s) => s -> Actor s -> Logic s +defn_Action_dotplusequal :: (Eq s, Action s) => s -> Actor s -> Logic s defn_Action_dotplusequal = simpleMutableDefn (.+=) (.+) -- | > s .+ a = a +. s @@ -1113,21 +1115,21 @@ instance Action b => Action (a->b) where class Semigroup g => Monoid g where zero :: g --- | FIXME: this should be in the Monoid class, but putting it there requires a lot of changes to Eq -isZero :: (Monoid g, ValidEq g) => g -> Logic g +-- | FIXME: +-- Mive into Monoid class +isZero :: (Monoid g, Eq g) => g -> Logic g isZero = (==zero) --- | FIXME: this should be in the Monoid class, but putting it there requires a lot of changes to Eq -notZero :: (Monoid g, ValidEq g) => g -> Logic g +notZero :: (Monoid g, Eq g) => g -> Logic g notZero = (/=zero) -law_Monoid_leftid :: (Monoid g, Eq g) => g -> Bool +law_Monoid_leftid :: (Monoid g, Eq g) => g -> Logic g law_Monoid_leftid g = zero + g == g -law_Monoid_rightid :: (Monoid g, Eq g) => g -> Bool +law_Monoid_rightid :: (Monoid g, Eq g) => g -> Logic g law_Monoid_rightid g = g + zero == g -defn_Monoid_isZero :: (Monoid g, Eq g) => g -> Bool +defn_Monoid_isZero :: (Monoid g, Eq g) => g -> Logic g defn_Monoid_isZero g = (isZero $ zero `asTypeOf` g) && (g /= zero ==> not isZero g) @@ -1145,7 +1147,7 @@ instance Monoid () where instance Monoid b => Monoid (a -> b) where {-# INLINE zero #-} - zero = \a -> zero + zero = \_ -> zero --------------------------------------- @@ -1182,13 +1184,13 @@ class Semigroup g => Cancellative g where (-=) = immutable2mutable (-) -law_Cancellative_rightminus1 :: (Eq g, Cancellative g) => g -> g -> Bool +law_Cancellative_rightminus1 :: (Eq g, Cancellative g) => g -> g -> Logic g law_Cancellative_rightminus1 g1 g2 = (g1 + g2) - g2 == g1 -law_Cancellative_rightminus2 :: (Eq g, Cancellative g) => g -> g -> Bool +law_Cancellative_rightminus2 :: (Eq g, Cancellative g) => g -> g -> Logic g law_Cancellative_rightminus2 g1 g2 = g1 + (g2 - g2) == g1 -defn_Cancellative_plusequal :: (Eq_ g, Cancellative g) => g -> g -> Logic g +defn_Cancellative_plusequal :: (Eq g, Cancellative g) => g -> g -> Logic g defn_Cancellative_plusequal = simpleMutableDefn (-=) (-) instance Cancellative Int where (-) = (P.-) ; {-# INLINE (-) #-} @@ -1212,13 +1214,13 @@ class (Cancellative g, Monoid g) => Group g where negate :: g -> g negate g = zero - g -defn_Group_negateminus :: (Eq g, Group g) => g -> g -> Bool +defn_Group_negateminus :: (Eq g, Group g) => g -> g -> Logic g defn_Group_negateminus g1 g2 = g1 + negate g2 == g1 - g2 -law_Group_leftinverse :: (Eq g, Group g) => g -> Bool +law_Group_leftinverse :: (Eq g, Group g) => g -> Logic g law_Group_leftinverse g = negate g + g == zero -law_Group_rightinverse :: (Eq g, Group g) => g -> Bool +law_Group_rightinverse :: (Eq g, Group g) => g -> Logic g law_Group_rightinverse g = g + negate g == zero instance Group Int where negate = P.negate ; {-# INLINE negate #-} @@ -1239,7 +1241,7 @@ instance Group b => Group (a -> b) where class Semigroup m => Abelian m -law_Abelian_commutative :: (Abelian g, Eq g) => g -> g -> Bool +law_Abelian_commutative :: (Abelian g, Eq g) => g -> g -> Logic g law_Abelian_commutative g1 g2 = g1 + g2 == g2 + g1 instance Abelian Int @@ -1274,22 +1276,22 @@ class (Abelian r, Monoid r) => Rg r where (*=) :: (PrimBase m) => Mutable m r -> r -> m () (*=) = immutable2mutable (*) -law_Rg_multiplicativeAssociativity :: (Eq r, Rg r) => r -> r -> r -> Bool +law_Rg_multiplicativeAssociativity :: (Eq r, Rg r) => r -> r -> r -> Logic r law_Rg_multiplicativeAssociativity r1 r2 r3 = (r1 * r2) * r3 == r1 * (r2 * r3) -law_Rg_multiplicativeCommutivity :: (Eq r, Rg r) => r -> r -> Bool +law_Rg_multiplicativeCommutivity :: (Eq r, Rg r) => r -> r -> Logic r law_Rg_multiplicativeCommutivity r1 r2 = r1*r2 == r2*r1 -law_Rg_annihilation :: (Eq r, Rg r) => r -> Bool +law_Rg_annihilation :: (Eq r, Rg r) => r -> Logic r law_Rg_annihilation r = r * zero == zero -law_Rg_distributivityLeft :: (Eq r, Rg r) => r -> r -> r -> Bool +law_Rg_distributivityLeft :: (Eq r, Rg r) => r -> r -> r -> Logic r law_Rg_distributivityLeft r1 r2 r3 = r1*(r2+r3) == r1*r2+r1*r3 -theorem_Rg_distributivityRight :: (Eq r, Rg r) => r -> r -> r -> Bool +theorem_Rg_distributivityRight :: (Eq r, Rg r) => r -> r -> r -> Logic r theorem_Rg_distributivityRight r1 r2 r3 = (r2+r3)*r1 == r2*r1+r3*r1 -defn_Rg_timesequal :: (Eq_ g, Rg g) => g -> g -> Logic g +defn_Rg_timesequal :: (Eq g, Rg g) => g -> g -> Logic g defn_Rg_timesequal = simpleMutableDefn (*=) (*) instance Rg Int where (*) = (P.*) ; {-# INLINE (*) #-} @@ -1315,14 +1317,14 @@ class (Monoid r, Rg r) => Rig r where one :: r -- | FIXME: this should be in the Rig class, but putting it there requires a lot of changes to Eq -isOne :: (Rig g, ValidEq g) => g -> Logic g +isOne :: (Rig g, Eq g) => g -> Logic g isOne = (==one) -- | FIXME: this should be in the Rig class, but putting it there requires a lot of changes to Eq -notOne :: (Rig g, ValidEq g) => g -> Logic g +notOne :: (Rig g, Eq g) => g -> Logic g notOne = (/=one) -law_Rig_multiplicativeId :: (Eq r, Rig r) => r -> Bool +law_Rig_multiplicativeId :: (Eq r, Rig r) => r -> Logic r law_Rig_multiplicativeId r = r * one == r && one * r == r instance Rig Int where one = 1 ; {-# INLINE one #-} @@ -1333,7 +1335,7 @@ instance Rig Rational where one = 1 ; {-# INLINE one #-} instance Rig b => Rig (a -> b) where {-# INLINE one #-} - one = \a -> one + one = \_ -> one --------------------------------------- @@ -1359,7 +1361,7 @@ class (Rng r, Rig r) => Ring r where fromInteger :: Integer -> r fromInteger = slowFromInteger -defn_Ring_fromInteger :: (Eq r, Ring r) => r -> Integer -> Bool +defn_Ring_fromInteger :: (Eq r, Ring r) => r -> Integer -> Logic r defn_Ring_fromInteger r i = fromInteger i `asTypeOf` r == slowFromInteger i @@ -1381,7 +1383,7 @@ instance Ring Rational where fromInteger = P.fromInteger ; {-# INLINE fromInt instance Ring b => Ring (a -> b) where {-# INLINE fromInteger #-} - fromInteger i = \a -> fromInteger i + fromInteger i = \_ -> fromInteger i {-# INLINABLE indicator #-} indicator :: Ring r => Bool -> r @@ -1430,17 +1432,17 @@ class Ring a => Integral a where divMod :: a -> a -> (a,a) -law_Integral_divMod :: (Eq a, Integral a) => a -> a -> Bool +law_Integral_divMod :: (Eq a, Integral a, ClassicalLogic a) => a -> a -> Bool law_Integral_divMod a1 a2 = if a2 /= 0 then a2 * (a1 `div` a2) + (a1 `mod` a2) == a1 else True -law_Integral_quotRem :: (Eq a, Integral a) => a -> a -> Bool +law_Integral_quotRem :: (Eq a, Integral a, ClassicalLogic a) => a -> a -> Bool law_Integral_quotRem a1 a2 = if a2 /= 0 then a2 * (a1 `quot` a2) + (a1 `rem` a2) == a1 else True -law_Integral_toFromInverse :: (Eq a, Integral a) => a -> Bool +law_Integral_toFromInverse :: (Eq a, Integral a) => a -> Logic a law_Integral_toFromInverse a = fromInteger (toInteger a) == a {-# INLINE[1] fromIntegral #-} @@ -1559,7 +1561,7 @@ mkField(Double) mkField(Rational) instance Field b => Field (a -> b) where - {-# INLINE fromRational #-} + {-# INLINE reciprocal #-} reciprocal f = reciprocal . f ---------------------------------------- @@ -1568,7 +1570,7 @@ instance Field b => Field (a -> b) where -- In particular, all finite fields and the complex numbers are NOT ordered fields. -- -- See for more details. -class (Field r, Ord_ r, Normed r, IsScalar r) => OrdField r +class (Field r, Ord r, ValidScalar r) => OrdField r instance OrdField Float instance OrdField Double @@ -1816,25 +1818,11 @@ instance Real Double where type family Scalar m -infixr 8 >< -type family (><) (a::k1) (b::k2) :: * -type instance Int >< Int = Int -type instance Integer >< Integer = Integer -type instance Float >< Float = Float -type instance Double >< Double = Double -type instance Rational >< Rational = Rational - --- type instance (a,b) >< Scalar b = (a,b) --- type instance (a,b,c) >< Scalar b = (a,b,c) - -type instance (a -> b) >< c = a -> (b>< (a -> b) = a -> (c> b) = Scalar b -- -- See class - ( Ord_ (Scalar g) + ( Ord (Scalar g) , Scalar (Scalar g) ~ Scalar g , Ring (Scalar g) ) => Normed g where @@ -1865,7 +1853,7 @@ class where s = size g -abs :: IsScalar g => g -> g +abs :: ValidScalar g => g -> g abs = size instance Normed Int where size = P.abs @@ -1904,9 +1892,8 @@ class (Cancellative m, HasScalar m, Rig (Scalar m)) => Cone m where class ( Abelian v , Group v - , HasScalar v - , v ~ (v> Module v where @@ -1923,19 +1910,19 @@ class (.*=) :: (PrimBase m) => Mutable m v -> Scalar v -> m () (.*=) = immutable2mutable (.*) -law_Module_multiplication :: (Eq_ m, Module m) => m -> m -> Scalar m -> Logic m +law_Module_multiplication :: (Eq m, Module m) => m -> m -> Scalar m -> Logic m law_Module_multiplication m1 m2 s = s *. (m1 + m2) == s*.m1 + s*.m2 -law_Module_addition :: (Eq_ m, Module m) => m -> Scalar m -> Scalar m -> Logic m +law_Module_addition :: (Eq m, Module m) => m -> Scalar m -> Scalar m -> Logic m law_Module_addition m s1 s2 = (s1+s2)*.m == s1*.m + s2*.m -law_Module_action :: (Eq_ m, Module m) => m -> Scalar m -> Scalar m -> Logic m +law_Module_action :: (Eq m, Module m) => m -> Scalar m -> Scalar m -> Logic m law_Module_action m s1 s2 = s1*.(s2*.m) == (s1*s2)*.m -law_Module_unital :: (Eq_ m, Module m) => m -> Logic m +law_Module_unital :: (Eq m, Module m) => m -> Logic m law_Module_unital m = 1 *. m == m -defn_Module_dotstarequal :: (Eq_ m, Module m) => m -> Scalar m -> Logic m +defn_Module_dotstarequal :: (Eq m, Module m) => m -> Scalar m -> Logic m defn_Module_dotstarequal = simpleMutableDefn (.*=) (.*) @@ -1986,16 +1973,16 @@ class Module v => FreeModule v where -- Intuitively, this object has the value "one" in every column. ones :: v -law_FreeModule_commutative :: (Eq_ m, FreeModule m) => m -> m -> Logic m +law_FreeModule_commutative :: (Eq m, FreeModule m) => m -> m -> Logic m law_FreeModule_commutative m1 m2 = m1.*.m2 == m2.*.m1 -law_FreeModule_associative :: (Eq_ m, FreeModule m) => m -> m -> m -> Logic m +law_FreeModule_associative :: (Eq m, FreeModule m) => m -> m -> m -> Logic m law_FreeModule_associative m1 m2 m3 = m1.*.(m2.*.m3) == (m1.*.m2).*.m3 -law_FreeModule_id :: (Eq_ m, FreeModule m) => m -> Logic m +law_FreeModule_id :: (Eq m, FreeModule m) => m -> Logic m law_FreeModule_id m = m == m.*.ones -defn_FreeModule_dotstardotequal :: (Eq_ m, FreeModule m) => m -> m -> Logic m +defn_FreeModule_dotstardotequal :: (Eq m, FreeModule m) => m -> m -> Logic m defn_FreeModule_dotstardotequal = simpleMutableDefn (.*.=) (.*.) instance FreeModule Int where (.*.) = (*); ones = one @@ -2009,7 +1996,7 @@ instance ) => FreeModule (a -> b) where g .*. f = \a -> g a .*. f a - ones = \a -> ones + ones = \_ -> ones --------------------------------------- @@ -2022,14 +2009,12 @@ class ( FreeModule v , IxContainer v , Elem v~Scalar v - --, Index v~Int -- Disabled to accomodate Acclerate Exp Int - , v ~ SetElem v (Elem v) ) => FiniteModule v where -- | Returns the dimension of the object. -- For some objects, this may be known statically, and so the parameter will not be "seq"ed. -- But for others, this may not be known statically, and so the parameter will be "seq"ed. - dim :: v -> Index v-- Set to index to accommodate Acclerate Exp Int + dim :: v -> Int unsafeToModule :: [Scalar v] -> v @@ -2039,12 +2024,6 @@ type instance Elem Float = Float type instance Elem Double = Double type instance Elem Rational = Rational -type instance SetElem Int a = Int -type instance SetElem Integer a = Integer -type instance SetElem Float a = Float -type instance SetElem Double a = Double -type instance SetElem Rational a = Rational - type instance Index Int = Int type instance Index Integer = Int type instance Index Float = Int @@ -2101,7 +2080,7 @@ instance VectorSpace b => VectorSpace (a -> b) where g ./. f = \a -> g a ./. f a -- | A Reisz space is a vector space obeying nice partial ordering laws. -- -- See for more details. -class (VectorSpace v, Lattice_ v) => Reisz v where +class (VectorSpace v, Lattice v) => Reisz v where -- -- | An element of a Reisz space can always be split into positive and negative components. reiszSplit :: v -> (v,v) @@ -2125,7 +2104,7 @@ class (VectorSpace v, Normed v, Metric v) => Banach v where law_Banach_distance :: Banach v => v -> v -> Logic (Scalar v) law_Banach_distance v1 v2 = size (v1 - v2) == distance v1 v2 -law_Banach_size :: Banach v => v -> Logic (Scalar v) +law_Banach_size :: (Banach v, Logic v~Logic (Scalar v)) => v -> Logic (Scalar v) law_Banach_size v = isZero v || size (normalize v) == 1 @@ -2136,21 +2115,53 @@ instance Banach Rational --------------------------------------- --- | Hilbert spaces are a natural generalization of Euclidean space that allows for infinite dimension. +-- | Hilbert spaces generalize Euclidean space by allowing infinite dimensions. -- -- See for more details. --- --- FIXME: --- The result of a dot product must always be an ordered field. --- This is true even when the Hilbert space is over a non-ordered field like the complex numbers. --- But the "OrdField" constraint currently prevents us from doing scalar multiplication on Complex Hilbert spaces. --- See and for some technical details. -class ( Banach v , TensorAlgebra v , Real (Scalar v), OrdField (Scalar v) ) => Hilbert v where +class Banach v => Hilbert v where + + -- | The type of the tensor product of a vector with itself. + -- That is, the "square" of a type with respect to the tensor product. + -- + -- FIXME: + -- Tensors are actually much more general. + -- For example, they can be the product of two vectors of different types. + -- To capture this generality requires using the monoidal structure of the Vect category. + type Square v + + -- | The outer product + (><) :: v -> v -> Square v + + -- | "left multiplication" of a square matrix + vXm :: v -> Square v -> v + + -- | "right multiplication" of a square matrix + mXv :: Square v -> v -> v + + -- | The inner product infix 8 <> (<>) :: v -> v -> Scalar v -instance Hilbert Float where (<>) = (*) -instance Hilbert Double where (<>) = (*) +instance Hilbert Float where + type Square Float = Float + (><) = (*) + vXm = (*) + mXv = (*) + (<>) = (*) + +instance Hilbert Double where + type Square Double = Double + (><) = (*) + vXm = (*) + mXv = (*) + (<>) = (*) + +instance Hilbert Rational where + type Square Rational = Rational + (><) = (*) + vXm = (*) + mXv = (*) + (<>) = (*) {-# INLINE squaredInnerProductNorm #-} squaredInnerProductNorm :: Hilbert v => v -> Scalar v @@ -2162,66 +2173,10 @@ innerProductNorm = undefined -- sqrt . squaredInnerProductNorm {-# INLINE innerProductDistance #-} innerProductDistance :: Hilbert v => v -> v -> Scalar v -innerProductDistance v1 v2 = undefined --innerProductNorm $ v1-v2 - ---------------------------------------- - --- | Tensor algebras generalize the outer product of vectors to construct a matrix. --- --- See for details. --- --- FIXME: --- This needs to be replaced by the Tensor product in the Monoidal category Vect -class - ( VectorSpace v - , VectorSpace (v> TensorAlgebra v - where - - -- | Take the tensor product of two vectors - (><) :: v -> v -> (v> (v> v - - -- | "right multiplication" of a square matrix - mXv :: (v> v -> v - -instance TensorAlgebra Float where (><) = (*); vXm = (*); mXv = (*) -instance TensorAlgebra Double where (><) = (*); vXm = (*); mXv = (*) -instance TensorAlgebra Rational where (><) = (*); vXm = (*); mXv = (*) +innerProductDistance _ _ = undefined --innerProductNorm $ v1-v2 --------------------------------------- -{- --- | Bregman divergences generalize the squared Euclidean distance and the KL-divergence. --- They are closely related to exponential family distributions. --- --- Mark Reid has a . --- --- FIXME: --- The definition of divergence requires taking the derivative. --- How should this relate to categories? -class - ( Hilbert v - ) => Bregman v - where - - divergence :: v -> v -> Scalar v - divergence v1 v2 = f v1 - f v2 - (derivative f v2 <> v1 - v2) - where - f = bregmanFunction - - bregmanFunction :: v -> Scalar v - -law_Bregman_nonnegativity :: v -> v -> Logic v -law_Bregman_nonnegativity v1 v2 = divergence v1 v2 > 0 - -law_Bregman_triangle :: --} --------------------------------------- @@ -2230,9 +2185,8 @@ law_Bregman_triangle :: -- FIXME: There are many other notions of distance and we should make a whole hierarchy. class ( HasScalar v - , Eq_ v - --, Boolean (Logic v) --Disabled for accelerqte Exp v - , Logic (Scalar v) ~ Logic v + , Eq v + , Boolean (Logic v) ) => Metric v where @@ -2243,18 +2197,18 @@ class -- Otherwise, it will return some number greater than the upper bound. {-# INLINE distanceUB #-} distanceUB :: v -> v -> Scalar v -> Scalar v - distanceUB v1 v2 _ = {-# SCC distanceUB #-} distance v1 v2 + distanceUB v1 v2 _ = distance v1 v2 -- | Calling this function will be faster on some 'Metric's than manually checking if distance is greater than the bound. {-# INLINE isFartherThan #-} -isFartherThan :: Metric v => v -> v -> Scalar v -> Logic v -isFartherThan s1 s2 b = {-# SCC isFartherThan #-} distanceUB s1 s2 b > b +isFartherThan :: Metric v => v -> v -> Scalar v -> Logic (Scalar v) +isFartherThan s1 s2 b = distanceUB s1 s2 b > b -- | This function constructs an efficient default implementation for 'distanceUB' given a function that lower bounds the distance metric. {-# INLINE lb2distanceUB #-} lb2distanceUB :: ( Metric a - , ClassicalLogic a + , IfThenElse (Logic (Scalar a)) ) => (a -> a -> Scalar a) -> (a -> a -> Scalar a -> Scalar a) lb2distanceUB lb p q b = if lbpq > b @@ -2262,18 +2216,18 @@ lb2distanceUB lb p q b = if lbpq > b else distance p q where lbpq = lb p q -law_Metric_nonnegativity :: Metric v => v -> v -> Logic v +law_Metric_nonnegativity :: Metric v => v -> v -> Logic (Scalar v) law_Metric_nonnegativity v1 v2 = distance v1 v2 >= 0 -law_Metric_indiscernables :: (Eq v, Metric v) => v -> v -> Logic v +law_Metric_indiscernables :: (Metric v, IfThenElse (Logic v)) => v -> v -> Logic (Scalar v) law_Metric_indiscernables v1 v2 = if v1 == v2 then distance v1 v2 == 0 else distance v1 v2 > 0 -law_Metric_symmetry :: Metric v => v -> v -> Logic v +law_Metric_symmetry :: Metric v => v -> v -> Logic (Scalar v) law_Metric_symmetry v1 v2 = distance v1 v2 == distance v2 v1 -law_Metric_triangle :: Metric v => v -> v -> v -> Logic v +law_Metric_triangle :: Metric v => v -> v -> v -> Logic (Scalar v) law_Metric_triangle m1 m2 m3 = distance m1 m2 <= distance m1 m3 + distance m2 m3 && distance m1 m3 <= distance m1 m2 + distance m2 m3 @@ -2332,13 +2286,7 @@ instance CanError Double where ------------------------------------------------------------------------------- -- set-like - -type Item s = Elem s - type family Elem s -type family SetElem s t - -type ValidSetElem s = SetElem s (Elem s) ~ s -- | Two sets are disjoint if their infimum is the empty set. -- This function generalizes the notion of disjointness for any lower bounded lattice. @@ -2382,20 +2330,26 @@ class Semigroup s => Constructible s where fromList1N :: Int -> Elem s -> [Elem s] -> s fromList1N _ = fromList1 -defn_Constructible_fromList :: (Eq_ s, Constructible s) => s -> Elem s -> [Elem s] -> Logic s +defn_Constructible_fromList :: (Eq s, Constructible s) => s -> Elem s -> [Elem s] -> Logic s defn_Constructible_fromList s e es = fromList1 e es `asTypeOf` s == foldl' snoc (singleton e) es -defn_Constructible_fromListN :: (Eq_ s, Constructible s) => s -> Elem s -> [Elem s] -> Logic s +defn_Constructible_fromListN :: (Eq s, Constructible s) => s -> Elem s -> [Elem s] -> Logic s defn_Constructible_fromListN s e es = (fromList1 e es `asTypeOf` s)==fromList1N (size es+1) e es -defn_Constructible_cons :: (Eq_ s, Constructible s) => s -> Elem s -> Logic s +defn_Constructible_cons :: (Eq s, Constructible s) => s -> Elem s -> Logic s defn_Constructible_cons s e = cons e s == singleton e + s -defn_Constructible_snoc :: (Eq_ s, Constructible s) => s -> Elem s -> Logic s +defn_Constructible_snoc :: (Eq s, Constructible s) => s -> Elem s -> Logic s defn_Constructible_snoc s e = snoc s e == s + singleton e +law_Constructible_singleton :: (Constructible s, Container s) => s -> Elem s -> Logic s +law_Constructible_singleton s e = elem e $ singleton e `asTypeOf` s + +theorem_Constructible_cons :: (Constructible s, Container s) => s -> Elem s -> Logic s +theorem_Constructible_cons s e = elem e (cons e s) + -- | A more suggestive name for inserting an element into a container that does not remember location -insert :: Constructible s => Elem s -> s -> s +insert :: (Abelian s, Constructible s) => Elem s -> s -> s insert = cons -- | A slightly more suggestive name for a container's monoid identity @@ -2403,7 +2357,7 @@ empty :: (Monoid s, Constructible s) => s empty = zero -- | A slightly more suggestive name for checking if a container is empty -isEmpty :: (ValidEq s, Monoid s, Constructible s) => s -> Logic s +isEmpty :: (Eq s, Monoid s, Constructible s) => s -> Logic s isEmpty = isZero -- | This function needed for the OverloadedStrings language extension @@ -2427,24 +2381,6 @@ generate n f = if n <= 0 then zero else fromList1N n (f 0) (map f [1..n-1]) --- | This is a generalization of a "set". --- We do not require a container to be a boolean algebra, just a semigroup. -class (ValidLogic s, Constructible s, ValidSetElem s) => Container s where - elem :: Elem s -> s -> Logic s - - notElem :: Elem s -> s -> Logic s - notElem = not elem - -law_Container_preservation :: (Heyting (Logic s), Container s) => s -> s -> Elem s -> Logic s -law_Container_preservation s1 s2 e = (e `elem` s1 || e `elem` s2) ==> (e `elem` (s1+s2)) - -law_Constructible_singleton :: Container s => s -> Elem s -> Logic s -law_Constructible_singleton s e = elem e $ singleton e `asTypeOf` s - -theorem_Constructible_cons :: Container s => s -> Elem s -> Logic s -theorem_Constructible_cons s e = elem e (cons e s) - - -- | The dual of a monoid, obtained by swapping the arguments of 'mappend'. newtype DualSG a = DualSG { getDualSG :: a } deriving (Read,Show) @@ -2473,7 +2409,7 @@ class (Constructible s, Monoid s, Normed s, Scalar s~Int) => Foldable s where {-# MINIMAL foldMap | foldr #-} -- | Convert the container into a list. - toList :: Foldable s => s -> [Elem s] + toList :: s -> [Elem s] toList s = foldr (:) [] s -- | Remove an element from the left of the container. @@ -2493,17 +2429,7 @@ class (Constructible s, Monoid s, Normed s, Scalar s~Int) => Foldable s where sum :: Monoid (Elem s) => s -> Elem s sum xs = foldl' (+) zero $ toList xs - -- | the default summation uses kahan summation --- sum :: (Abelian (Elem s), Group (Elem s)) => s -> Elem s --- sum = snd . foldl' go (zero,zero) --- where --- go (c,t) i = ((t'-t)-y,t') --- where --- y = i-c --- t' = t+y - -- the definitions below are copied from Data.Foldable - foldMap :: Monoid a => (Elem s -> a) -> s -> a foldMap f = foldr ((+) . f) zero @@ -2536,74 +2462,62 @@ class (Constructible s, Monoid s, Normed s, Scalar s~Int) => Foldable s where foldl1' f s = foldl1' f (toList s) defn_Foldable_foldr :: - ( Eq_ a + ( Eq a , a~Elem s - , Logic a ~ Logic (Elem s) , Logic (Scalar s) ~ Logic (Elem s) - , Boolean (Logic (Elem s)) , Foldable s ) => (Elem s -> Elem s -> Elem s) -> Elem s -> s -> Logic (Elem s) defn_Foldable_foldr f a s = foldr f a s == foldr f a (toList s) defn_Foldable_foldr' :: - ( Eq_ a + ( Eq a , a~Elem s - , Logic a ~ Logic (Elem s) , Logic (Scalar s) ~ Logic (Elem s) - , Boolean (Logic (Elem s)) , Foldable s ) => (Elem s -> Elem s -> Elem s) -> Elem s -> s -> Logic (Elem s) defn_Foldable_foldr' f a s = foldr' f a s == foldr' f a (toList s) defn_Foldable_foldl :: - ( Eq_ a + ( Eq a , a~Elem s - , Logic a ~ Logic (Elem s) , Logic (Scalar s) ~ Logic (Elem s) - , Boolean (Logic (Elem s)) , Foldable s ) => (Elem s -> Elem s -> Elem s) -> Elem s -> s -> Logic (Elem s) defn_Foldable_foldl f a s = foldl f a s == foldl f a (toList s) defn_Foldable_foldl' :: - ( Eq_ a + ( Eq a , a~Elem s - , Logic a ~ Logic (Elem s) , Logic (Scalar s) ~ Logic (Elem s) - , Boolean (Logic (Elem s)) , Foldable s ) => (Elem s -> Elem s -> Elem s) -> Elem s -> s -> Logic (Elem s) defn_Foldable_foldl' f a s = foldl' f a s == foldl' f a (toList s) defn_Foldable_foldr1 :: - ( Eq_ (Elem s) - , Logic (Scalar s) ~ Logic (Elem s) - , Boolean (Logic (Elem s)) + ( Eq (Elem s) , Foldable s + , ClassicalLogic (Elem s) ) => (Elem s -> Elem s -> Elem s) -> s -> Logic (Elem s) defn_Foldable_foldr1 f s = (length s > 0) ==> (foldr1 f s == foldr1 f (toList s)) defn_Foldable_foldr1' :: - ( Eq_ (Elem s) - , Logic (Scalar s) ~ Logic (Elem s) - , Boolean (Logic (Elem s)) + ( Eq (Elem s) , Foldable s + , ClassicalLogic (Elem s) ) => (Elem s -> Elem s -> Elem s) -> s -> Logic (Elem s) defn_Foldable_foldr1' f s = (length s > 0) ==> (foldr1' f s == foldr1' f (toList s)) defn_Foldable_foldl1 :: - ( Eq_ (Elem s) - , Logic (Scalar s) ~ Logic (Elem s) - , Boolean (Logic (Elem s)) + ( Eq (Elem s) , Foldable s + , ClassicalLogic (Elem s) ) => (Elem s -> Elem s -> Elem s) -> s -> Logic (Elem s) defn_Foldable_foldl1 f s = (length s > 0) ==> (foldl1 f s == foldl1 f (toList s)) defn_Foldable_foldl1' :: - ( Eq_ (Elem s) - , Logic (Scalar s) ~ Logic (Elem s) - , Boolean (Logic (Elem s)) + ( Eq (Elem s) , Foldable s + , ClassicalLogic (Elem s) ) => (Elem s -> Elem s -> Elem s) -> s -> Logic (Elem s) defn_Foldable_foldl1' f s = (length s > 0) ==> (foldl1' f s == foldl1' f (toList s)) @@ -2612,7 +2526,7 @@ defn_Foldable_foldl1' f s = (length s > 0) ==> (foldl1' f s == foldl1' f (toList -- Note: -- The inverse \"theorem\" of @(toList . fromList) xs == xs@ is actually not true. -- See the "Set" type for a counter example. -theorem_Foldable_tofrom :: (Eq_ s, Foldable s) => s -> Logic s +theorem_Foldable_tofrom :: (Eq s, Foldable s) => s -> Logic s theorem_Foldable_tofrom s = fromList (toList s) == s -- | @@ -2623,7 +2537,7 @@ law_Foldable_sum :: , Logic (Elem s)~Logic s , Heyting (Logic s) , Monoid (Elem s) - , Eq_ (Elem s) + , Eq (Elem s) , Foldable s ) => s -> s -> Logic s law_Foldable_sum s1 s2 = sizeDisjoint s1 s2 ==> (sum (s1+s2) == sum s1 + sum s2) @@ -2633,11 +2547,11 @@ foldtree1 :: Monoid a => [a] -> a foldtree1 as = case go as of [] -> zero [a] -> a - as -> foldtree1 as + as' -> foldtree1 as' where go [] = [] go [a] = [a] - go (a1:a2:as) = (a1+a2):go as + go (a1:a2:as'') = (a1+a2):go as'' {-# INLINE[1] convertUnfoldable #-} convertUnfoldable :: (Monoid t, Foldable s, Constructible t, Elem s ~ Elem t) => s -> t @@ -2661,45 +2575,27 @@ or :: (Foldable bs, Elem bs~b, Boolean b) => bs -> b or = foldl' sup false {-# INLINE argmin #-} -argmin :: Ord b => a -> a -> (a -> b) -> a +argmin :: (Ord b, ClassicalLogic b) => a -> a -> (a -> b) -> a argmin a1 a2 f = if f a1 < f a2 then a1 else a2 {-# INLINE argmax #-} -argmax :: Ord b => a -> a -> (a -> b) -> a +argmax :: (Ord b, ClassicalLogic b) => a -> a -> (a -> b) -> a argmax a1 a2 f = if f a1 > f a2 then a1 else a2 --- {-# INLINE argminimum_ #-} --- argminimum_ :: Ord_ b => a -> [a] -> (a -> b) -> a --- argminimum_ a as f = fstHask $ foldl' go (a,f a) as --- where --- go (a1,fa1) a2 = if fa1 < fa2 --- then (a1,fa1) --- else (a2,fa2) --- where fa2 = f a2 --- --- {-# INLINE argmaximum_ #-} --- argmaximum_ :: Ord_ b => a -> [a] -> (a -> b) -> a --- argmaximum_ a as f = fstHask $ foldl' go (a,f a) as --- where --- go (a1,fa1) a2 = if fa1 > fa2 --- then (a1,fa1) --- else (a2,fa2) --- where fa2 = f a2 - {-# INLINE maximum #-} -maximum :: (ValidLogic b, Bounded b) => [b] -> b +maximum :: (Bounded b) => [b] -> b maximum = supremum {-# INLINE maximum_ #-} -maximum_ :: (ValidLogic b, Ord_ b) => b -> [b] -> b +maximum_ :: (Ord b) => b -> [b] -> b maximum_ = supremum_ {-# INLINE minimum #-} -minimum :: (ValidLogic b, Bounded b) => [b] -> b +minimum :: (Bounded b) => [b] -> b minimum = infimum {-# INLINE minimum_ #-} -minimum_ :: (ValidLogic b, Ord_ b) => b -> [b] -> b +minimum_ :: (Ord b) => b -> [b] -> b minimum_ = infimum_ {-# INLINE supremum #-} @@ -2707,7 +2603,7 @@ supremum :: (Foldable bs, Elem bs~b, Bounded b) => bs -> b supremum = supremum_ minBound {-# INLINE supremum_ #-} -supremum_ :: (Foldable bs, Elem bs~b, Lattice_ b) => b -> bs -> b +supremum_ :: (Foldable bs, Elem bs~b, Lattice b) => b -> bs -> b supremum_ = foldl' sup {-# INLINE infimum #-} @@ -2715,7 +2611,7 @@ infimum :: (Foldable bs, Elem bs~b, Bounded b) => bs -> b infimum = infimum_ maxBound {-# INLINE infimum_ #-} -infimum_ :: (Foldable bs, Elem bs~b, POrd_ b) => b -> bs -> b +infimum_ :: (Foldable bs, Elem bs~b, POrd b) => b -> bs -> b infimum_ = foldl' inf {-# INLINE concat #-} @@ -2738,29 +2634,11 @@ lastMaybe = P.fmap snd . unsnoc initMaybe :: Foldable s => s -> Maybe s initMaybe = P.fmap fst . unsnoc --- | --- --- FIXME: --- This is a correct definition of topologies, but is it useful? --- How can this relate to continuous functions? -class (Boolean (Logic s), Boolean s, Container s) => Topology s where - open :: s -> Logic s - - closed :: s -> Logic s - closed s = open $ not s - - clopen :: s -> Logic s - clopen = open && closed - ---------------------------------------- type family Index s type family SetIndex s a --- | FIXME: --- This type is a hack designed to work around the lack of injective type families. -type ValidSetIndex s = SetIndex s (Index s) ~ s - -- | An indexed constructible container associates an 'Index' with each 'Elem'. -- This class generalizes the map abstract data type. -- @@ -2769,7 +2647,7 @@ type ValidSetIndex s = SetIndex s (Index s) ~ s -- 2. Many regular containers are indexed containers, but not the other way around. -- So the class hierarchy is in a different order. -- -class (ValidLogic s, Monoid s, ValidSetElem s{-, ValidSetIndex s-}) => IxContainer s where +class (Monoid s) => IxContainer s where lookup :: Index s -> s -> Maybe (Elem s) {-# INLINABLE (!) #-} @@ -2785,16 +2663,16 @@ class (ValidLogic s, Monoid s, ValidSetElem s{-, ValidSetIndex s-}) => IxContain Just e -> e {-# INLINABLE hasIndex #-} - hasIndex :: s -> Index s -> Logic s + hasIndex :: Bounded (Logic s) => s -> Index s -> Logic s hasIndex s i = case s !? i of Nothing -> false Just _ -> true -- | FIXME: should the functions below be moved to other classes? - type ValidElem s e :: Constraint + type ValidElem s (e :: *) :: Constraint type ValidElem s e = () - imap :: (ValidElem s (Elem s), ValidElem s b) => (Index s -> Elem s -> b) -> s -> SetElem s b + imap :: (Index s -> Elem s -> Elem s) -> s -> s toIxList :: s -> [(Index s, Elem s)] @@ -2806,8 +2684,7 @@ class (ValidLogic s, Monoid s, ValidSetElem s{-, ValidSetIndex s-}) => IxContain law_IxContainer_preservation :: ( Logic (Elem s)~Logic s - , ValidLogic s - , Eq_ (Elem s) + , Eq (Elem s) , IxContainer s ) => s -> s -> Index s -> Logic s law_IxContainer_preservation s1 s2 i = case s1 !? i of @@ -2815,8 +2692,7 @@ law_IxContainer_preservation s1 s2 i = case s1 !? i of Nothing -> true defn_IxContainer_bang :: - ( Eq_ (Elem s) - , ValidLogic (Elem s) + ( Eq (Elem s) , IxContainer s ) => s -> Index s -> Logic (Elem s) defn_IxContainer_bang s i = case s !? i of @@ -2824,7 +2700,7 @@ defn_IxContainer_bang s i = case s !? i of Just e -> s!i == e defn_IxContainer_findWithDefault :: - ( Eq_ (Elem s) + ( Eq (Elem s) , IxContainer s ) => s -> Index s -> Elem s -> Logic (Elem s) defn_IxContainer_findWithDefault s i e = case s !? i of @@ -2832,7 +2708,7 @@ defn_IxContainer_findWithDefault s i e = case s !? i of Just e' -> findWithDefault e i s == e' defn_IxContainer_hasIndex :: - ( Eq_ (Elem s) + ( Complemented (Logic s) , IxContainer s ) => s -> Index s -> Logic s defn_IxContainer_hasIndex s i = case s !? i of @@ -2871,17 +2747,17 @@ class (IxContainer s, Scalar s~Index s, HasScalar s, Normed s) => Sliceable s wh law_Sliceable_restorable :: ( Sliceable s , Eq s + , Logic (Index s) ~ Logic s + , IfThenElse (Logic s) ) => s -> Index s -> Logic s -law_Sliceable_restorable s i - | i >= 0 && i < length s = slice 0 i s + slice i (length s-i) s == s - | otherwise = True +law_Sliceable_restorable s i = if i >= 0 && i < length s + then slice 0 i s + slice i (length s-i) s == s + else true law_Sliceable_preservation :: - ( ValidLogic s - , Logic (Elem s) ~ Logic s - , Eq_ (Elem s) - , Eq_ s + ( Eq (Elem s) , Sliceable s + , Logic s ~ Logic (Elem s) ) => s -> s -> Index s -> Logic s law_Sliceable_preservation s1 s2 i = case s1 !? i of Just e -> (s1+s2) !? i == Just e @@ -2922,31 +2798,28 @@ class IxContainer s => IxConstructible s where fromIxList xs = foldl' (\s (i,e) -> snocAt s i e) zero xs law_IxConstructible_lookup :: - ( ValidLogic (Elem s) - , Eq_ (Elem s) + ( Eq (Elem s) , IxConstructible s ) => s -> Index s -> Elem s -> Logic (Elem s) law_IxConstructible_lookup s i e = case lookup i (consAt i e s) of Just e' -> e'==e Nothing -> false -defn_IxConstructible_consAt :: (Eq_ s, IxConstructible s) => s -> Index s -> Elem s -> Logic s +defn_IxConstructible_consAt :: (Eq s, IxConstructible s) => s -> Index s -> Elem s -> Logic s defn_IxConstructible_consAt s i e = consAt i e s == singletonAt i e + s -defn_IxConstructible_snocAt :: (Eq_ s, IxConstructible s) => s -> Index s -> Elem s -> Logic s +defn_IxConstructible_snocAt :: (Eq s, IxConstructible s) => s -> Index s -> Elem s -> Logic s defn_IxConstructible_snocAt s i e = snocAt s i e == s + singletonAt i e -defn_IxConstructible_fromIxList :: (Eq_ s, IxConstructible s) => s -> [(Index s, Elem s)] -> Logic s +defn_IxConstructible_fromIxList :: (Eq s, IxConstructible s) => s -> [(Index s, Elem s)] -> Logic s defn_IxConstructible_fromIxList t es = fromIxList es `asTypeOf` t == foldl' (\s (i,e) -> snocAt s i e) zero es -- | Follows from "law_IxConstructible_lookup" but is closely related to "law_IxContainer_preservation" and "law_Sliceable_preservation" theorem_IxConstructible_preservation :: - ( ValidLogic s - , Logic (Elem s) ~ Logic s - , Eq_ (Elem s) + ( Eq (Elem s) , IxContainer s - , Scalar s ~ Int + , Logic s ~ Logic (Elem s) ) => s -> s -> Index s -> Logic s theorem_IxConstructible_preservation s1 s2 i = case s1 !? i of Just e -> (s1+s2) !? i == Just e @@ -2968,23 +2841,22 @@ insertAt = consAt type instance Scalar [a] = Int type instance Logic [a] = Logic a type instance Elem [a] = a -type instance SetElem [a] b = [b] type instance Index [a] = Int -instance ValidEq a => Eq_ [a] where +instance Eq a => Eq [a] where (x:xs)==(y:ys) = x==y && xs==ys - (x:xs)==[] = false - [] ==(y:ts) = false + (_:_)==[] = false + [] ==(_:_) = false [] ==[] = true -instance Eq a => POrd_ [a] where +instance (Eq a, ClassicalLogic a) => POrd [a] where inf [] _ = [] inf _ [] = [] inf (x:xs) (y:ys) = if x==y then x:inf xs ys else [] -instance Eq a => MinBound_ [a] where +instance (Eq a, ClassicalLogic a) => MinBound [a] where minBound = [] instance Normed [a] where @@ -2996,7 +2868,7 @@ instance Semigroup [a] where instance Monoid [a] where zero = [] -instance ValidEq a => Container [a] where +instance Eq a => Container [a] where elem _ [] = false elem x (y:ys) = x==y || elem x ys @@ -3029,10 +2901,10 @@ instance Foldable [a] where foldl1 = L.foldl1 foldl1' = L.foldl1' -instance ValidLogic a => IxContainer [a] where - lookup 0 (x:xs) = Just x - lookup i (x:xs) = lookup (i-1) xs - lookup _ [] = Nothing +instance Eq a => IxContainer [a] where + lookup 0 (x:_ ) = Just x + lookup i (_:xs) = lookup (i-1) xs + lookup _ [] = Nothing imap f xs = map (uncurry f) $ P.zip [0..] xs @@ -3043,7 +2915,7 @@ instance ValidLogic a => IxContainer [a] where type instance Scalar (Maybe a) = Scalar a type instance Logic (Maybe a) = Logic a -instance ValidEq a => Eq_ (Maybe a) where +instance Eq a => Eq (Maybe a) where Nothing == Nothing = true Nothing == _ = false _ == Nothing = false @@ -3073,7 +2945,7 @@ instance NFData a => NFData (Maybe' a) where rnf Nothing' = () rnf (Just' a) = rnf a -instance ValidEq a => Eq_ (Maybe' a) where +instance Eq a => Eq (Maybe' a) where (Just' a1) == (Just' a2) = a1==a2 Nothing' == Nothing' = true _ == _ = false @@ -3091,10 +2963,10 @@ instance Semigroup a => Monoid (Maybe' a) where type instance Logic (a,b) = Logic a type instance Logic (a,b,c) = Logic a -instance (ValidEq a, ValidEq b, Logic a ~ Logic b) => Eq_ (a,b) where +instance (Eq a, Eq b, Logic a ~ Logic b) => Eq (a,b) where (a1,b1)==(a2,b2) = a1==a2 && b1==b2 -instance (ValidEq a, ValidEq b, ValidEq c, Logic a ~ Logic b, Logic b~Logic c) => Eq_ (a,b,c) where +instance (Eq a, Eq b, Eq c, Logic a ~ Logic b, Logic b~Logic c) => Eq (a,b,c) where (a1,b1,c1)==(a2,b2,c2) = a1==a2 && b1==b2 && c1==c2 instance (Semigroup a, Semigroup b) => Semigroup (a,b) where @@ -3125,24 +2997,6 @@ instance (Abelian a, Abelian b) => Abelian (a,b) instance (Abelian a, Abelian b, Abelian c) => Abelian (a,b,c) --- instance (Module a, Module b, Scalar a ~ Scalar b) => Module (a,b) where --- (a,b) .* r = (r*.a, r*.b) --- (a1,b1).*.(a2,b2) = (a1.*.a2,b1.*.b2) --- --- instance (Module a, Module b, Module c, Scalar a ~ Scalar b, Scalar c~Scalar b) => Module (a,b,c) where --- (a,b,c) .* r = (r*.a, r*.b,r*.c) --- (a1,b1,c1).*.(a2,b2,c2) = (a1.*.a2,b1.*.b2,c1.*.c2) --- --- instance (VectorSpace a,VectorSpace b, Scalar a ~ Scalar b) => VectorSpace (a,b) where --- (a,b) ./ r = (a./r,b./r) --- (a1,b1)./.(a2,b2) = (a1./.a2,b1./.b2) --- --- instance (VectorSpace a,VectorSpace b, VectorSpace c, Scalar a ~ Scalar b, Scalar c~Scalar b) => VectorSpace (a,b,c) where --- (a,b,c) ./ r = (a./r,b./r,c./r) --- (a1,b1,c1)./.(a2,b2,c2) = (a1./.a2,b1./.b2,c1./.c2) - --------------------------------------------------------------------------------- - data Labeled' x y = Labeled' { xLabeled' :: !x, yLabeled' :: !y } deriving (Read,Show,Typeable) @@ -3165,76 +3019,35 @@ type instance Elem (Labeled' x y) = Elem x ----- -instance Eq_ x => Eq_ (Labeled' x y) where - (Labeled' x1 y1) == (Labeled' x2 y2) = x1==x2 +instance Eq x => Eq (Labeled' x y) where + (Labeled' x1 _) == (Labeled' x2 _) = x1==x2 -instance (ClassicalLogic x, Ord_ x) => POrd_ (Labeled' x y) where +instance (ClassicalLogic x, Ord x) => POrd (Labeled' x y) where inf (Labeled' x1 y1) (Labeled' x2 y2) = if x1 < x2 then Labeled' x1 y1 else Labeled' x2 y2 (Labeled' x1 _)< (Labeled' x2 _) = x1< x2 (Labeled' x1 _)<=(Labeled' x2 _) = x1<=x2 -instance (ClassicalLogic x, Ord_ x) => Lattice_ (Labeled' x y) where +instance (ClassicalLogic x, Ord x) => Lattice (Labeled' x y) where sup (Labeled' x1 y1) (Labeled' x2 y2) = if x1 >= x2 then Labeled' x1 y1 else Labeled' x2 y2 (Labeled' x1 _)> (Labeled' x2 _) = x1> x2 (Labeled' x1 _)>=(Labeled' x2 _) = x1>=x2 -instance (ClassicalLogic x, Ord_ x) => Ord_ (Labeled' x y) where - ------ +instance (ClassicalLogic x, Ord x) => Ord (Labeled' x y) where instance Semigroup x => Action (Labeled' x y) where (Labeled' x y) .+ x' = Labeled' (x'+x) y ------ - instance Metric x => Metric (Labeled' x y) where - distance (Labeled' x1 y1) (Labeled' x2 y2) = distance x1 x2 - distanceUB (Labeled' x1 y1) (Labeled' x2 y2) = distanceUB x1 x2 + distance (Labeled' x1 _) (Labeled' x2 _) = distance x1 x2 + distanceUB (Labeled' x1 _) (Labeled' x2 _) = distanceUB x1 x2 instance Normed x => Normed (Labeled' x y) where size (Labeled' x _) = size x - --------------------------------------------------------------------------------- --- spatial programming --- --- FIXME: --- This is broken, partly due to type system limits. --- It's being exported just for basic testing. - --- | The type of all containers satisfying the @cxt@ constraint with elements of type @x@. -type All cxt x = forall xs. (cxt xs, Elem xs~x) => xs - -data Any cxt x where - Any :: forall cxt x xs. (cxt xs, Elem xs~x) => xs -> Any cxt x --- Any :: All cxt x -> Any cxt x - -instance Show x => Show (Any Foldable x) where - show (Any xs) = show $ toList xs - -type instance Elem (Any cxt x) = x -type instance Scalar (Any cxt x) = Int - -instance Semigroup (Any Foldable x) where - (Any x1)+(Any x2)=Any (x1+(fromList.toList)x2) - -instance Constructible (Any Foldable x) where - -instance Normed (Any Foldable x) where - size (Any xs) = size xs - -instance Monoid (Any Foldable x) where - zero = Any [] - -instance Foldable (Any Foldable x) where - toList (Any xs) = toList xs - -mkMutable [t| forall cxt x. Any cxt x |] - -------------------------------------------------------------------------------- mkMutable [t| POrdering |] @@ -3244,3 +3057,32 @@ mkMutable [t| forall a. DualSG a |] mkMutable [t| forall a. Maybe a |] mkMutable [t| forall a. Maybe' a |] mkMutable [t| forall a b. Labeled' a b |] + +instance FAlgebra IfThenElse +instance FAlgebra IsMutable +instance IsMutable (Free (Sig alg) t a) +instance Show (Sig IsMutable t a) +mkTagFromCnst ''Logic [t| forall a. IdempLogic a |] +mkTag ''Elem +mkFAlgebra ''Eq +mkFAlgebra ''POrd +mkFAlgebra ''MinBound +mkFAlgebra ''Lattice +mkFAlgebra ''Boolean +mkTagFromCnst ''Scalar [t| forall a. Scalar (Scalar a) ~ Scalar a |] +mkFAlgebra ''RationalField +mkFAlgebra ''VectorSpace +mkFAlgebra ''Normed +mkFAlgebra ''Hilbert + +type instance FreeConstraints t a + = ( AppTags (ConsTag TScalar t) a + ~ Scalar (AppTags t a) +-- , AppTags (ConsTag TScalar (ConsTag TLogic (ConsTag TLogic t))) a +-- ~ Scalar (AppTags (ConsTag_TLogic (ConsTag_TLogic t)) a) + ) + +-------------------------------------------------------------------------------- + +class FAlgebra alg => Variety alg where + diff --git a/src/SubHask/Algebra/Array.hs b/src/SubHask/Algebra/Array.hs index 62c8034..6d16af5 100644 --- a/src/SubHask/Algebra/Array.hs +++ b/src/SubHask/Algebra/Array.hs @@ -1,4 +1,8 @@ {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-missing-methods #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + module SubHask.Algebra.Array ( BArray (..) , UArray (..) @@ -8,11 +12,8 @@ module SubHask.Algebra.Array import Control.Monad import Control.Monad.Primitive -import Unsafe.Coerce import Data.Primitive as Prim -import Data.Primitive.ByteArray import qualified Data.Vector as V -import qualified Data.Vector as VM import qualified Data.Vector.Unboxed as VU import qualified Data.Vector.Unboxed.Mutable as VUM import qualified Data.Vector.Generic as VG @@ -24,7 +25,6 @@ import SubHask.Algebra.Parallel import SubHask.Algebra.Vector import SubHask.Category import SubHask.Internal.Prelude -import SubHask.Compatibility.Base ------------------------------------------------------------------------------- -- boxed arrays @@ -35,7 +35,6 @@ type instance Index (BArray e) = Int type instance Logic (BArray e) = Logic e type instance Scalar (BArray e) = Int type instance Elem (BArray e) = e -type instance SetElem (BArray e) e' = BArray e' ---------------------------------------- -- mutability @@ -69,13 +68,13 @@ instance Normed (BArray e) where ---------------------------------------- -- comparison -instance (ValidLogic e, Eq_ e) => Eq_ (BArray e) where +instance (Eq e) => Eq (BArray e) where a1==a2 = toList a1==toList a2 -instance (ClassicalLogic e, POrd_ e) => POrd_ (BArray e) where +instance (ClassicalLogic e, POrd e) => POrd (BArray e) where inf a1 a2 = fromList $ inf (toList a1) (toList a2) -instance (ClassicalLogic e, POrd_ e) => MinBound_ (BArray e) where +instance (ClassicalLogic e, POrd e) => MinBound (BArray e) where minBound = zero ---------------------------------------- @@ -84,7 +83,7 @@ instance (ClassicalLogic e, POrd_ e) => MinBound_ (BArray e) where instance Constructible (BArray e) where fromList1 x xs = BArray $ VG.fromList (x:xs) -instance (ValidLogic e, Eq_ e) => Container (BArray e) where +instance (Eq e) => Container (BArray e) where elem e arr = elem e $ toList arr instance Foldable (BArray e) where @@ -114,7 +113,7 @@ instance Foldable (BArray e) where {-# INLINE foldl1 #-} {-# INLINE foldl1' #-} foldr f x (BArray v) = VG.foldr f x v - foldr' f x (BArray v) = {-# SCC foldr'_BArray #-} VG.foldr' f x v + foldr' f x (BArray v) = VG.foldr' f x v foldr1 f (BArray v) = VG.foldr1 f v foldr1' f (BArray v) = VG.foldr1' f v foldl f x (BArray v) = VG.foldl f x v @@ -122,17 +121,17 @@ instance Foldable (BArray e) where foldl1 f (BArray v) = VG.foldl1 f v foldl1' f (BArray v) = VG.foldl1' f v -instance ValidLogic e => Sliceable (BArray e) where +instance Eq e => Sliceable (BArray e) where slice i n (BArray v) = BArray $ VG.slice i n v -instance ValidLogic e => IxContainer (BArray e) where +instance Eq e => IxContainer (BArray e) where lookup i (BArray v) = v VG.!? i (!) (BArray v) = VG.unsafeIndex v indices (BArray v) = [0..VG.length v-1] values (BArray v) = VG.toList v imap f (BArray v) = BArray $ VG.imap f v -instance ValidLogic e => Partitionable (BArray e) where +instance Eq e => Partitionable (BArray e) where partition n arr = go 0 where go i = if i>=length arr @@ -149,14 +148,13 @@ instance ValidLogic e => Partitionable (BArray e) where -- unboxed arrays data UArray e - = UArray {-#UNPACK#-}!(VU.Vector e) + = UArray !(VU.Vector e) -- | UArray_Zero type instance Index (UArray e) = Int type instance Logic (UArray e) = Logic e type instance Scalar (UArray e) = Int type instance Elem (UArray e) = e -type instance SetElem (UArray e) e' = UArray e' ---------------------------------------- -- mutability @@ -169,7 +167,7 @@ mkMutable [t| forall e. UArray e |] instance (Unboxable e, Arbitrary e) => Arbitrary (UArray e) where arbitrary = fmap fromList arbitrary -instance (NFData e) => NFData (UArray e) where +instance NFData (UArray e) where rnf (UArray v) = rnf v -- rnf UArray_Zero = () @@ -195,13 +193,13 @@ instance Unbox e => Normed (UArray e) where ---------------------------------------- -- comparison -instance (Unboxable e, Eq_ e) => Eq_ (UArray e) where +instance (Unboxable e, Eq e) => Eq (UArray e) where a1==a2 = toList a1==toList a2 -instance (Unboxable e, POrd_ e) => POrd_ (UArray e) where +instance (Unboxable e, ClassicalLogic e, POrd e) => POrd (UArray e) where inf a1 a2 = fromList $ inf (toList a1) (toList a2) -instance (Unboxable e, POrd_ e) => MinBound_ (UArray e) where +instance (Unboxable e, ClassicalLogic e, POrd e) => MinBound (UArray e) where minBound = zero ---------------------------------------- @@ -221,11 +219,11 @@ mkConstructible(Bool) instance ( ClassicalLogic r - , Eq_ r + , Eq r , Unbox r , Prim r , FreeModule r - , IsScalar r + , ValidScalar r , ValidUVector s r ) => Constructible (UArray (UVector (s::Symbol) r)) where @@ -235,48 +233,20 @@ instance {-# INLINABLE fromList1N #-} fromList1N n x xs = unsafeInlineIO $ do - marr <- safeNewByteArray (n*size*rbytes) 16 - let mv = UArray_MUVector marr 0 n size + marr <- safeNewByteArray (n*size'*rbytes) 16 + let mv = UArray_MUVector marr 0 n size' let go [] (-1) = return () - go (x:xs) i = do - VGM.unsafeWrite mv i x - go xs (i-1) + go (x':xs') i = do + VGM.unsafeWrite mv i x' + go xs' (i-1) go (P.reverse $ x:xs) (n-1) v <- VG.basicUnsafeFreeze mv return $ UArray v where rbytes=Prim.sizeOf (undefined::r) - size=roundUpToNearest 4 $ dim x - --- instance --- ( ClassicalLogic r --- , Eq_ r --- , Unbox r --- , Prim r --- , FreeModule r --- , IsScalar r --- ) => Monoid (UArray (UVector (s::Symbol) r)) where --- zero = unsafeInlineIO $ do --- marr <- safeNewByteArray 0 16 --- arr <- unsafeFreezeByteArray marr --- return $ UArray $ UArray_UVector arr 0 0 0 - --- instance --- ( ClassicalLogic r --- , Eq_ r --- , Unbox r --- , Prim r --- , FreeModule r --- , IsScalar r --- , Prim y --- , Unbox y --- ) => Monoid (UArray (Labeled' (UVector (s::Symbol) r) y)) where --- zero = unsafeInlineIO $ do --- marr <- safeNewByteArray 0 16 --- arr <- unsafeFreezeByteArray marr --- return $ UArray $ UArray_Labeled'_UVector arr 0 0 0 + size'=roundUpToNearest 4 $ dim x instance Unboxable e => Container (UArray e) where elem e (UArray v) = elem e $ VG.toList v @@ -285,7 +255,6 @@ instance Unboxable e => Foldable (UArray e) where {-# INLINE toList #-} toList (UArray v) = VG.toList v --- toList UArray_Zero = [] {-# INLINE uncons #-} uncons (UArray v) = if VG.null v @@ -309,7 +278,7 @@ instance Unboxable e => Foldable (UArray e) where {-# INLINE foldl1 #-} {-# INLINE foldl1' #-} foldr f x (UArray v) = VG.foldr f x v - foldr' f x (UArray v) = {-# SCC foldr'_UArray #-} VG.foldr' f x v + foldr' f x (UArray v) = VG.foldr' f x v foldr1 f (UArray v) = VG.foldr1 f v foldr1' f (UArray v) = VG.foldr1' f v foldl f x (UArray v) = VG.foldl f x v @@ -321,7 +290,7 @@ instance Unboxable e => Sliceable (UArray e) where slice i n (UArray v) = UArray $ VG.slice i n v instance Unboxable e => IxContainer (UArray e) where - type ValidElem (UArray e) e = Unboxable e + type ValidElem (UArray e) e' = (e~e', Unboxable e) lookup i (UArray v) = v VG.!? i (!) (UArray v) = VG.unsafeIndex v @@ -345,14 +314,12 @@ instance Unboxable e => Partitionable (UArray e) where -- UVector instance - ( IsScalar elem + ( ValidScalar elem , ClassicalLogic elem , Unbox elem , Prim elem ) => Unbox (UVector (n::Symbol) elem) ---------------------------------------- - data instance VU.Vector (UVector (n::Symbol) elem) = UArray_UVector {-#UNPACK#-}!ByteArray {-#UNPACK#-}!Int -- offset @@ -360,9 +327,10 @@ data instance VU.Vector (UVector (n::Symbol) elem) = UArray_UVector {-#UNPACK#-}!Int -- length of element vectors instance - ( IsScalar elem + ( ValidScalar elem , Unbox elem , Prim elem + , ClassicalLogic elem ) => VG.Vector VU.Vector (UVector (n::Symbol) elem) where @@ -370,26 +338,21 @@ instance basicLength (UArray_UVector _ _ n _) = n {-# INLINABLE basicUnsafeSlice #-} - basicUnsafeSlice i len' (UArray_UVector arr off n size) = UArray_UVector arr (off+i*size) len' size + basicUnsafeSlice i len' (UArray_UVector arr off _ size') = UArray_UVector arr (off+i*size') len' size' {-# INLINABLE basicUnsafeFreeze #-} - basicUnsafeFreeze (UArray_MUVector marr off n size) = do + basicUnsafeFreeze (UArray_MUVector marr off n size') = do arr <- unsafeFreezeByteArray marr - return $ UArray_UVector arr off n size + return $ UArray_UVector arr off n size' {-# INLINABLE basicUnsafeThaw #-} - basicUnsafeThaw (UArray_UVector arr off n size)= do + basicUnsafeThaw (UArray_UVector arr off n size')= do marr <- unsafeThawByteArray arr - return $ UArray_MUVector marr off n size + return $ UArray_MUVector marr off n size' {-# INLINABLE basicUnsafeIndexM #-} - basicUnsafeIndexM (UArray_UVector arr off n size) i = - return $ UVector_Dynamic arr (off+i*size) size - --- {-# INLINABLE basicUnsafeCopy #-} --- basicUnsafeCopy mv v = VG.basicUnsafeCopy (vecM mv) (vec v) - ---------------------------------------- + basicUnsafeIndexM (UArray_UVector arr off _ size') i = + return $ UVector_Dynamic arr (off+i*size') size' data instance VUM.MVector s (UVector (n::Symbol) elem) = UArray_MUVector {-#UNPACK#-}!(MutableByteArray s) @@ -399,7 +362,7 @@ data instance VUM.MVector s (UVector (n::Symbol) elem) = UArray_MUVector instance ( ClassicalLogic elem - , IsScalar elem + , ValidScalar elem , Unbox elem , Prim elem ) => VGM.MVector VUM.MVector (UVector (n::Symbol) elem) @@ -409,46 +372,41 @@ instance basicLength (UArray_MUVector _ _ n _) = n {-# INLINABLE basicUnsafeSlice #-} - basicUnsafeSlice i lenM' (UArray_MUVector marr off n size) - = UArray_MUVector marr (off+i*size) lenM' size + basicUnsafeSlice i lenM' (UArray_MUVector marr off _ size') + = UArray_MUVector marr (off+i*size') lenM' size' {-# INLINABLE basicOverlaps #-} - basicOverlaps (UArray_MUVector marr1 off1 n1 size) (UArray_MUVector marr2 off2 n2 _) + basicOverlaps (UArray_MUVector marr1 _ _ _) (UArray_MUVector marr2 _ _ _) = sameMutableByteArray marr1 marr2 {-# INLINABLE basicUnsafeNew #-} basicUnsafeNew 0 = do marr <- newByteArray 0 return $ UArray_MUVector marr 0 0 0 - basicUnsafeNew n = error "basicUnsafeNew not supported on UArray_MUVector with nonzero size" - --- basicUnsafeNew lenM' = do --- let elemsize=ptsize --- marr <- newPinnedByteArray (lenM'*elemsize*Prim.sizeOf (undefined::elem)) --- return $ UArray_MUVector marr 0 lenM' elemsize + basicUnsafeNew _ = error "basicUnsafeNew not supported on UArray_MUVector with nonzero size" {-# INLINABLE basicUnsafeRead #-} - basicUnsafeRead mv@(UArray_MUVector marr off n size) i = do + basicUnsafeRead (UArray_MUVector marr off _ size') i = do let b=Prim.sizeOf (undefined::elem) - marr' <- safeNewByteArray (size*b) 16 - copyMutableByteArray marr' 0 marr ((off+i*size)*b) (size*b) + marr' <- safeNewByteArray (size'*b) 16 + copyMutableByteArray marr' 0 marr ((off+i*size')*b) (size'*b) arr <- unsafeFreezeByteArray marr' - return $ UVector_Dynamic arr 0 size + return $ UVector_Dynamic arr 0 size' {-# INLINABLE basicUnsafeWrite #-} - basicUnsafeWrite mv@(UArray_MUVector marr1 off1 _ size) loc v@(UVector_Dynamic arr2 off2 _) = - copyByteArray marr1 ((off1+size*loc)*b) arr2 (off2*b) (size*b) + basicUnsafeWrite (UArray_MUVector marr1 off1 _ size1) loc (UVector_Dynamic arr2 off2 _) = + copyByteArray marr1 ((off1+size1*loc)*b) arr2 (off2*b) (size1*b) where b=Prim.sizeOf (undefined::elem) {-# INLINABLE basicUnsafeCopy #-} - basicUnsafeCopy (UArray_MUVector marr1 off1 n1 size1) (UArray_MUVector marr2 off2 n2 size2) = + basicUnsafeCopy (UArray_MUVector marr1 off1 _ size1) (UArray_MUVector marr2 off2 n2 _) = copyMutableByteArray marr1 (off1*b) marr2 (off2*b) (n2*b) where b = size1*Prim.sizeOf (undefined::elem) {-# INLINABLE basicUnsafeMove #-} - basicUnsafeMove (UArray_MUVector marr1 off1 n1 size1) (UArray_MUVector marr2 off2 n2 size2) = + basicUnsafeMove (UArray_MUVector marr1 off1 _ size1) (UArray_MUVector marr2 off2 n2 _) = moveByteArray marr1 (off1*b) marr2 (off2*b) (n2*b) where b = size1*Prim.sizeOf (undefined::elem) @@ -457,16 +415,13 @@ instance -- Labeled' instance - ( Unbox y - , Prim y + ( Prim y , ClassicalLogic a - , IsScalar a + , ValidScalar a , Unbox a , Prim a ) => Unbox (Labeled' (UVector (s::Symbol) a) y) ---------------------------------------- - data instance VUM.MVector s (Labeled' (UVector (n::Symbol) elem) y) = UArray_Labeled'_MUVector {-#UNPACK#-}!(MutableByteArray s) {-#UNPACK#-}!Int -- offset in number of elem @@ -475,7 +430,7 @@ data instance VUM.MVector s (Labeled' (UVector (n::Symbol) elem) y) = UArray_Lab instance ( ClassicalLogic elem - , IsScalar elem + , ValidScalar elem , Unbox elem , Prim elem , Prim y @@ -486,34 +441,28 @@ instance basicLength (UArray_Labeled'_MUVector _ _ n _) = n {-# INLINABLE basicUnsafeSlice #-} - basicUnsafeSlice i lenM' (UArray_Labeled'_MUVector marr off n size) - = UArray_Labeled'_MUVector marr (off+i*(size+ysize)) lenM' size + basicUnsafeSlice i lenM' (UArray_Labeled'_MUVector marr off _ size') + = UArray_Labeled'_MUVector marr (off+i*(size'+ysize)) lenM' size' where ysize=roundUpToNearest 4 $ Prim.sizeOf (undefined::y) `quot` Prim.sizeOf (undefined::elem) {-# INLINABLE basicOverlaps #-} - basicOverlaps (UArray_Labeled'_MUVector marr1 off1 n1 size) (UArray_Labeled'_MUVector marr2 off2 n2 _) + basicOverlaps (UArray_Labeled'_MUVector marr1 _ _ _) (UArray_Labeled'_MUVector marr2 _ _ _) = sameMutableByteArray marr1 marr2 {-# INLINABLE basicUnsafeNew #-} basicUnsafeNew 0 = do marr <- newByteArray 0 return $ UArray_Labeled'_MUVector marr 0 0 0 - basicUnsafeNew n = error "basicUnsafeNew not supported on UArray_MUVector with nonzero size" --- basicUnsafeNew lenM' = do --- let elemsize=ptsize --- marr <- newPinnedByteArray (lenM'*(elemsize+ysize)*Prim.sizeOf (undefined::elem)) --- return $ UArray_Labeled'_MUVector marr 0 lenM' elemsize --- where --- ysize=roundUpToNearest 4 $ Prim.sizeOf (undefined::y) `quot` Prim.sizeOf (undefined::elem) + basicUnsafeNew _ = error "basicUnsafeNew not supported on UArray_MUVector with nonzero size" {-# INLINABLE basicUnsafeRead #-} - basicUnsafeRead mv@(UArray_Labeled'_MUVector marr off n size) i = do - marr' <- safeNewByteArray (size*b) 16 - copyMutableByteArray marr' 0 marr ((off+i*(size+ysize))*b) (size*b) + basicUnsafeRead (UArray_Labeled'_MUVector marr off _ size') i = do + marr' <- safeNewByteArray (size'*b) 16 + copyMutableByteArray marr' 0 marr ((off+i*(size'+ysize))*b) (size'*b) arr <- unsafeFreezeByteArray marr' - let x=UVector_Dynamic arr 0 size - y <- readByteArray marr $ (off+i*(size+ysize)+size) `quot` ysizereal + let x=UVector_Dynamic arr 0 size' + y <- readByteArray marr $ (off+i*(size'+ysize)+size') `quot` ysizereal return $ Labeled' x y where b=Prim.sizeOf (undefined::elem) @@ -522,12 +471,12 @@ instance {-# INLINABLE basicUnsafeWrite #-} basicUnsafeWrite - (UArray_Labeled'_MUVector marr1 off1 _ size) + (UArray_Labeled'_MUVector marr1 off1 _ size') i (Labeled' (UVector_Dynamic arr2 off2 _) y) = do - copyByteArray marr1 ((off1+i*(size+ysize))*b) arr2 (off2*b) (size*b) - writeByteArray marr1 ((off1+i*(size+ysize)+size) `quot` ysizereal) y + copyByteArray marr1 ((off1+i*(size'+ysize))*b) arr2 (off2*b) (size'*b) + writeByteArray marr1 ((off1+i*(size'+ysize)+size') `quot` ysizereal) y where b=Prim.sizeOf (undefined::elem) ysizereal = Prim.sizeOf (undefined::y) `quot` Prim.sizeOf (undefined::elem) @@ -535,8 +484,8 @@ instance {-# INLINABLE basicUnsafeCopy #-} basicUnsafeCopy - (UArray_Labeled'_MUVector marr1 off1 n1 size1) - (UArray_Labeled'_MUVector marr2 off2 n2 size2) + (UArray_Labeled'_MUVector marr1 off1 _ size1) + (UArray_Labeled'_MUVector marr2 off2 n2 _) = copyMutableByteArray marr1 (off1*b) marr2 (off2*b) (n2*b) where b = (size1+ysize)*Prim.sizeOf (undefined::elem) @@ -544,15 +493,13 @@ instance {-# INLINABLE basicUnsafeMove #-} basicUnsafeMove - (UArray_Labeled'_MUVector marr1 off1 n1 size1) - (UArray_Labeled'_MUVector marr2 off2 n2 size2) + (UArray_Labeled'_MUVector marr1 off1 _ size1) + (UArray_Labeled'_MUVector marr2 off2 n2 _) = moveByteArray marr1 (off1*b) marr2 (off2*b) (n2*b) where b = (size1+ysize)*Prim.sizeOf (undefined::elem) ysize=roundUpToNearest 4 $ Prim.sizeOf (undefined::y) `quot` Prim.sizeOf (undefined::elem) ----------------------------------------- - data instance VU.Vector (Labeled' (UVector (n::Symbol) elem) y) = UArray_Labeled'_UVector {-#UNPACK#-}!ByteArray {-#UNPACK#-}!Int -- offset @@ -560,10 +507,11 @@ data instance VU.Vector (Labeled' (UVector (n::Symbol) elem) y) = UArray_Labeled {-#UNPACK#-}!Int -- length of element vectors instance - ( IsScalar elem + ( ValidScalar elem , Unbox elem , Prim elem , Prim y + , ClassicalLogic elem ) => VG.Vector VU.Vector (Labeled' (UVector (n::Symbol) elem) y) where @@ -571,39 +519,38 @@ instance basicLength (UArray_Labeled'_UVector _ _ n _) = n {-# INLINABLE basicUnsafeSlice #-} - basicUnsafeSlice i len' (UArray_Labeled'_UVector arr off n size) - = UArray_Labeled'_UVector arr (off+i*(size+ysize)) len' size + basicUnsafeSlice i len' (UArray_Labeled'_UVector arr off _ size') + = UArray_Labeled'_UVector arr (off+i*(size'+ysize)) len' size' where ysize=roundUpToNearest 4 $ Prim.sizeOf (undefined::y) `quot` Prim.sizeOf (undefined::elem) {-# INLINABLE basicUnsafeFreeze #-} - basicUnsafeFreeze (UArray_Labeled'_MUVector marr off n size) = do + basicUnsafeFreeze (UArray_Labeled'_MUVector marr off n size') = do arr <- unsafeFreezeByteArray marr - return $ UArray_Labeled'_UVector arr off n size + return $ UArray_Labeled'_UVector arr off n size' {-# INLINABLE basicUnsafeThaw #-} - basicUnsafeThaw (UArray_Labeled'_UVector arr off n size)= do + basicUnsafeThaw (UArray_Labeled'_UVector arr off n size')= do marr <- unsafeThawByteArray arr - return $ UArray_Labeled'_MUVector marr off n size + return $ UArray_Labeled'_MUVector marr off n size' {-# INLINE basicUnsafeIndexM #-} - basicUnsafeIndexM (UArray_Labeled'_UVector arr off n size) i = --- trace ("off'="+show off') $ + basicUnsafeIndexM (UArray_Labeled'_UVector arr off _ size') i = return $ Labeled' x y where - off' = off+i*(size+ysize) - x = UVector_Dynamic arr off' size - y = indexByteArray arr $ (off'+size) `quot` ysizereal + off' = off+i*(size'+ysize) + x = UVector_Dynamic arr off' size' + y = indexByteArray arr $ (off'+size') `quot` ysizereal ysizereal = Prim.sizeOf (undefined::y) `quot` Prim.sizeOf (undefined::elem) ysize=roundUpToNearest 4 $ ysizereal instance ( ClassicalLogic r - , Eq_ r + , Eq r , Unbox r , Prim r , FreeModule r - , IsScalar r + , ValidScalar r , Prim y , Unbox y , ValidUVector s r @@ -621,9 +568,9 @@ instance let mv = UArray_Labeled'_MUVector marr 0 n xsize let go [] (-1) = return () - go (x:xs) i = do - VGM.unsafeWrite mv i x - go xs (i-1) + go (x':xs') i = do + VGM.unsafeWrite mv i x' + go xs' (i-1) go (P.reverse $ x:xs) (n-1) v <- VG.basicUnsafeFreeze mv @@ -633,182 +580,3 @@ instance xsize=roundUpToNearest 4 $ dim $ xLabeled' x ysize=roundUpToNearest 4 $ Prim.sizeOf (undefined::y) `quot` rbytes - --- roundUpToNearest_ :: Int -> Int -> Int --- roundUpToNearest_ m i = i -- +4-i`rem`4 --- roundUpToNearest_ m x = x+r --- where --- s = x`rem`m --- r = if s==0 then 0 else m-s - -------------------------------------------------------------------------------- --- Labeled' - -{- -instance (VU.Unbox x, VU.Unbox y) => VU.Unbox (Labeled' x y) - -data instance VUM.MVector s (Labeled' x y) = UArray_Labeled'_MUVector - !(VUM.MVector s x) - !(VUM.MVector s y) - -instance - ( VUM.Unbox x - , VUM.Unbox y - ) => VGM.MVector VUM.MVector (Labeled' x y) - where - - {-# INLINABLE basicLength #-} - {-# INLINABLE basicUnsafeSlice #-} - {-# INLINABLE basicOverlaps #-} - {-# INLINABLE basicUnsafeNew #-} - {-# INLINABLE basicUnsafeRead #-} - {-# INLINABLE basicUnsafeWrite #-} - {-# INLINABLE basicUnsafeCopy #-} - {-# INLINABLE basicUnsafeMove #-} - {-# INLINABLE basicSet #-} - basicLength (UArray_Labeled'_MUVector xv yv) = VGM.basicLength xv - - basicUnsafeSlice i len (UArray_Labeled'_MUVector xv yv) - = UArray_Labeled'_MUVector - (VGM.basicUnsafeSlice i len xv) - (VGM.basicUnsafeSlice i len yv) - - basicOverlaps (UArray_Labeled'_MUVector xv1 _) (UArray_Labeled'_MUVector xv2 _) - = VGM.basicOverlaps xv1 xv2 - - basicUnsafeNew n = do - mvx <- VGM.basicUnsafeNew n - mvy <- VGM.basicUnsafeNew n - return $ UArray_Labeled'_MUVector mvx mvy - - basicUnsafeRead (UArray_Labeled'_MUVector xv yv) i = do - x <- VGM.basicUnsafeRead xv i - y <- VGM.basicUnsafeRead yv i - return $ Labeled' x y - - basicUnsafeWrite (UArray_Labeled'_MUVector xv yv) i (Labeled' x y) = do - VGM.basicUnsafeWrite xv i x - VGM.basicUnsafeWrite yv i y - - basicUnsafeCopy (UArray_Labeled'_MUVector xv1 yv1) (UArray_Labeled'_MUVector xv2 yv2) = do - VGM.basicUnsafeCopy xv1 xv2 - VGM.basicUnsafeCopy yv1 yv2 - - basicUnsafeMove (UArray_Labeled'_MUVector xv1 yv1) (UArray_Labeled'_MUVector xv2 yv2) = do - VGM.basicUnsafeMove xv1 xv2 - VGM.basicUnsafeMove yv1 yv2 - - basicSet (UArray_Labeled'_MUVector xv yv) (Labeled' x y) = do - VGM.basicSet xv x - VGM.basicSet yv y - -data instance VU.Vector (Labeled' x y) = UArray_Labeled'_UVector - !(VU.Vector x) - !(VU.Vector y) - -instance - ( VUM.Unbox x - , VUM.Unbox y - ) => VG.Vector VU.Vector (Labeled' x y) - where - - {-# INLINABLE basicUnsafeFreeze #-} - {-# INLINABLE basicUnsafeThaw #-} - {-# INLINABLE basicLength #-} - {-# INLINABLE basicUnsafeSlice #-} - {-# INLINABLE basicUnsafeIndexM #-} - basicUnsafeFreeze (UArray_Labeled'_MUVector mxv myv) = do - xv <- VG.basicUnsafeFreeze mxv - yv <- VG.basicUnsafeFreeze myv - return $ UArray_Labeled'_UVector xv yv - - basicUnsafeThaw (UArray_Labeled'_UVector xv yv) = do - mxv <- VG.basicUnsafeThaw xv - myv <- VG.basicUnsafeThaw yv - return ( UArray_Labeled'_MUVector mxv myv ) - - basicLength (UArray_Labeled'_UVector xv _ ) = VG.basicLength xv - - basicUnsafeSlice i len (UArray_Labeled'_UVector xv yv) = UArray_Labeled'_UVector - (VG.basicUnsafeSlice i len xv) - (VG.basicUnsafeSlice i len yv) - - basicUnsafeIndexM (UArray_Labeled'_UVector xv yv) i = do - x <- VG.basicUnsafeIndexM xv i - y <- VG.basicUnsafeIndexM yv i - return $ Labeled' x y - -instance - ( Unboxable x - , Unboxable y - ) => Constructible (UArray (Labeled' x y)) - where - - fromList1 z zs = UArray $ UArray_Labeled'_UVector - ( unUArray $ fromList1 (xLabeled' z) (map xLabeled' zs) ) - ( unUArray $ fromList1 (yLabeled' z) (map yLabeled' zs) ) - where - unUArray (UArray v) = v - - fromList1N n z zs = UArray $ UArray_Labeled'_UVector - ( unUArray $ fromList1N n (xLabeled' z) (map xLabeled' zs) ) - ( unUArray $ fromList1N n (yLabeled' z) (map yLabeled' zs) ) - where - unUArray (UArray v) = v - --} - -{- -instance (VUM.Unbox x, VUM.Unbox y) => VUM.Unbox (Labeled' x y) - -newtype instance VUM.MVector s (Labeled' x y) = UMV_Labeled' (VUM.MVector s (x,y)) - -instance - ( VUM.Unbox x - , VUM.Unbox y - ) => VGM.MVector VUM.MVector (Labeled' x y) - where - - {-# INLINABLE basicLength #-} - {-# INLINABLE basicUnsafeSlice #-} - {-# INLINABLE basicOverlaps #-} - {-# INLINABLE basicUnsafeNew #-} - {-# INLINABLE basicUnsafeRead #-} - {-# INLINABLE basicUnsafeWrite #-} - {-# INLINABLE basicUnsafeCopy #-} - {-# INLINABLE basicUnsafeMove #-} - {-# INLINABLE basicSet #-} - basicLength (UMV_Labeled' v) = VGM.basicLength v - basicUnsafeSlice i len (UMV_Labeled' v) = UMV_Labeled' $ VGM.basicUnsafeSlice i len v - basicOverlaps (UMV_Labeled' v1) (UMV_Labeled' v2) = VGM.basicOverlaps v1 v2 - basicUnsafeNew = error "basicUnsafeNew should never be called" --- basicUnsafeNew len = liftM UMV_Labeled' $ VGM.basicUnsafeNew len - basicUnsafeRead (UMV_Labeled' v) i = do - (!x,!y) <- VGM.basicUnsafeRead v i - return $ Labeled' x y - basicUnsafeWrite (UMV_Labeled' v) i (Labeled' x y) = VGM.basicUnsafeWrite v i (x,y) - basicUnsafeCopy (UMV_Labeled' v1) (UMV_Labeled' v2) = VGM.basicUnsafeCopy v1 v2 - basicUnsafeMove (UMV_Labeled' v1) (UMV_Labeled' v2) = VGM.basicUnsafeMove v1 v2 - basicSet (UMV_Labeled' v1) (Labeled' x y) = VGM.basicSet v1 (x,y) - -newtype instance VU.Vector (Labeled' x y) = UV_Labeled' (VU.Vector (x,y)) - -instance - ( VUM.Unbox x - , VUM.Unbox y - ) => VG.Vector VU.Vector (Labeled' x y) - where - - {-# INLINABLE basicUnsafeFreeze #-} - {-# INLINABLE basicUnsafeThaw #-} - {-# INLINABLE basicLength #-} - {-# INLINABLE basicUnsafeSlice #-} - {-# INLINABLE basicUnsafeIndexM #-} - basicUnsafeFreeze (UMV_Labeled' v) = liftM UV_Labeled' $ VG.basicUnsafeFreeze v - basicUnsafeThaw (UV_Labeled' v) = liftM UMV_Labeled' $ VG.basicUnsafeThaw v - basicLength (UV_Labeled' v) = VG.basicLength v - basicUnsafeSlice i len (UV_Labeled' v) = UV_Labeled' $ VG.basicUnsafeSlice i len v - basicUnsafeIndexM (UV_Labeled' v) i = do - (!x,!y) <- VG.basicUnsafeIndexM v i - return $ Labeled' x y --} diff --git a/src/SubHask/Algebra/Container.hs b/src/SubHask/Algebra/Container.hs index 0762114..ce22eb9 100644 --- a/src/SubHask/Algebra/Container.hs +++ b/src/SubHask/Algebra/Container.hs @@ -5,20 +5,9 @@ module SubHask.Algebra.Container where import Control.Monad -import GHC.Prim -import Control.Monad -import GHC.TypeLits -import qualified Prelude as P -import Prelude (tail,head,last) - -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set import SubHask.Algebra -import SubHask.Algebra.Ord import SubHask.Category -import SubHask.Compatibility.Base -import SubHask.SubType import SubHask.Internal.Prelude import SubHask.TemplateHaskell.Deriving @@ -35,13 +24,12 @@ data Box v = Box mkMutable [t| forall v. Box v |] -invar_Box_ordered :: (Lattice v, HasScalar v) => Box v -> Logic v +invar_Box_ordered :: Lattice v => Box v -> Logic v invar_Box_ordered b = largest b >= smallest b type instance Scalar (Box v) = Scalar v type instance Logic (Box v) = Logic v type instance Elem (Box v) = v -type instance SetElem (Box v) v' = Box v' -- misc classes @@ -53,22 +41,22 @@ instance (Lattice v, Arbitrary v) => Arbitrary (Box v) where -- comparison -instance (Eq v, HasScalar v) => Eq_ (Box v) where +instance (Eq v, HasScalar v) => Eq (Box v) where b1==b2 = smallest b1 == smallest b2 && largest b1 == largest b2 -- FIXME: -- the following instances are "almost" valid --- POrd_, however, can't be correct without adding an empty element to the Box +-- POrd, however, can't be correct without adding an empty element to the Box -- should we do this? Would it hurt efficiency? -- --- instance (Lattice v, HasScalar v) => POrd_ (Box v) where +-- instance (Lattice v, HasScalar v) => POrd (Box v) where -- inf b1 b2 = Box -- { smallest = sup (smallest b1) (smallest b2) -- , largest = inf (largest b1) (largest b2) -- } -- --- instance (Lattice v, HasScalar v) => Lattice_ (Box v) where +-- instance (Lattice v, HasScalar v) => Lattice (Box v) where -- sup = (+) -- algebra @@ -102,7 +90,7 @@ deriveHierarchy ''Jaccard ] instance - ( Lattice_ a + ( Lattice a , Field (Scalar a) , Normed a , Logic (Scalar a) ~ Logic a @@ -131,40 +119,42 @@ instance , Eq (Elem a) , Eq a , ClassicalLogic (Scalar a) + , ClassicalLogic a + , ClassicalLogic (Elem a) , HasScalar a ) => Metric (Hamming a) where {-# INLINE distance #-} distance (Hamming xs) (Hamming ys) = - {-# SCC distance_Hamming #-} go (toList xs) (toList ys) 0 where - go [] [] i = i - go xs [] i = i + fromIntegral (size xs) - go [] ys i = i + fromIntegral (size ys) - go (x:xs) (y:ys) i = go xs ys $ i + if x==y + go :: [Elem a] -> [Elem a] -> Scalar a -> Scalar a + go [] [] i = i + go xs' [] i = i + fromIntegral (size xs') + go [] ys' i = i + fromIntegral (size ys') + go (x:xs') (y:ys') i = go xs' ys' $ i + if x==y then 0 else 1 {-# INLINE distanceUB #-} distanceUB (Hamming xs) (Hamming ys) dist = - {-# SCC distanceUB_Hamming #-} go (toList xs) (toList ys) 0 where - go xs ys tot = if tot > dist + go xs' ys' tot = if tot > dist then tot - else go_ xs ys tot + else go_ xs' ys' tot where - go_ (x:xs) (y:ys) i = go xs ys $ i + if x==y + go_ (x:xs'') (y:ys'') i = go xs'' ys'' $ i + if x==y then 0 else 1 go_ [] [] i = i - go_ xs [] i = i + fromIntegral (size xs) - go_ [] ys i = i + fromIntegral (size ys) + go_ xs'' [] i = i + fromIntegral (size xs'') + go_ [] ys'' i = i + fromIntegral (size ys'') ---------------------------------------- +{- -- | The Levenshtein distance is a type of edit distance, but it is often referred to as THE edit distance. -- -- FIXME: The implementation could be made faster in a number of ways; @@ -187,18 +177,19 @@ instance , Show a , HasScalar a , ClassicalLogic (Scalar a) + , ClassicalLogic (Elem a) + , ClassicalLogic a , Bounded (Scalar a) ) => Metric (Levenshtein a) where {-# INLINE distance #-} distance (Levenshtein xs) (Levenshtein ys) = - {-# SCC distance_Levenshtein #-} fromIntegral $ dist (toList xs) (toList ys) -- | this function stolen from -- https://www.haskell.org/haskellwiki/Edit_distance -dist :: Eq a => [a] -> [a] -> Int +dist :: (ClassicalLogic a, Eq a) => [a] -> [a] -> Int dist a b = last (if lab == 0 then mainDiag @@ -206,24 +197,31 @@ dist a b then lowers P.!! (lab - 1) else{- < 0 -} uppers P.!! (-1 - lab)) where - mainDiag = oneDiag a b (head uppers) (-1 : head lowers) - uppers = eachDiag a b (mainDiag : uppers) -- upper diagonals - lowers = eachDiag b a (mainDiag : lowers) -- lower diagonals - eachDiag a [] diags = [] - eachDiag a (bch:bs) (lastDiag:diags) = oneDiag a bs nextDiag lastDiag : eachDiag a bs diags + mainDiag = oneDiag a b (head uppers) (-1 : head lowers) :: [Int] + uppers = eachDiag a b (mainDiag : uppers) ::[[Int]] -- upper diagonals + lowers = eachDiag b a (mainDiag : lowers) ::[[Int]] -- lower diagonals + eachDiag _ (_:bs) (lastDiag:diags) = oneDiag a bs nextDiag lastDiag : eachDiag a bs diags where nextDiag = head (tail diags) - oneDiag a b diagAbove diagBelow = thisdiag + eachDiag _ _ _ = [] + + oneDiag _ _ diagAbove diagBelow = thisdiag :: [[Int]] where - doDiag [] b nw n w = [] - doDiag a [] nw n w = [] - doDiag (ach:as) (bch:bs) nw n w = me : (doDiag as bs me (tail n) (tail w)) - where - me = if ach == bch then nw else 1 + min3 (head w) nw (head n) firstelt = 1 + head diagBelow + thisdiag = firstelt : doDiag a b firstelt diagAbove (tail diagBelow) + + doDiag [] _ _ _ _ = [] + doDiag _ [] _ _ _ = [] + doDiag (ach:as) (bch:bs) nw n w = me : (doDiag as bs me (tail n) (tail w)) + where + me = if ach == (bch::[Int]) then nw else 1 + min3 (head w) nw (head n) + lab :: Int lab = size a - size b + + min3 :: Ord b => b -> b -> b -> b min3 x y z = if x < y then x else min y z +-} ---------------------------------------- @@ -281,73 +279,79 @@ instance Foldable s => Foldable (Uncompensated s) where -- FIXME: there are more container orderings that probably deserve implementation newtype Lexical a = Lexical { unLexical :: a } -deriveHierarchy ''Lexical [ ''Eq_, ''Foldable, ''Constructible, ''Monoid ] --- deriveHierarchy ''Lexical [ ''Eq_, ''Monoid ] +deriveHierarchy ''Lexical [ ''Eq, ''Foldable, ''Constructible, ''Monoid ] +-- deriveHierarchy ''Lexical [ ''Eq, ''Monoid ] instance - (Logic a~Bool + ( Logic a~Bool , Ord (Elem a) , Foldable a - , Eq_ a - ) => POrd_ (Lexical a) + , Eq a + , ClassicalLogic (Elem a) + ) => POrd (Lexical a) where + inf a1 a2 = if a1 [Elem a] -> Logic a go (x:xs) (y:ys) = if xy - then False + then false else go xs ys - go [] [] = False - go [] _ = True - go _ [] = False + go [] [] = false + go [] _ = true + go _ [] = false -instance (Logic a~Bool, Ord (Elem a), Foldable a, Eq_ a) => MinBound_ (Lexical a) where +instance (Logic a~Bool, ClassicalLogic (Elem a), Ord (Elem a), Foldable a, Eq a) => MinBound (Lexical a) where minBound = Lexical zero -instance (Logic a~Bool, Ord (Elem a), Foldable a, Eq_ a) => Lattice_ (Lexical a) where +instance (Logic a~Bool, ClassicalLogic (Elem a), Ord (Elem a), Foldable a, Eq a) => Lattice (Lexical a) where sup a1 a2 = if a1>a2 then a1 else a2 (Lexical a1)>(Lexical a2) = go (toList a1) (toList a2) where + go :: [Elem a] -> [Elem a] -> Logic a go (x:xs) (y:ys) = if x>y - then True + then true else if x Ord_ (Lexical a) where +instance (Logic a~Bool, ClassicalLogic (Elem a), Ord (Elem a), Foldable a, Eq a) => Ord (Lexical a) where --------------------------------------- newtype ComponentWise a = ComponentWise { unComponentWise :: a } -deriveHierarchy ''ComponentWise [ ''Eq_, ''Foldable, ''Monoid ] +deriveHierarchy ''ComponentWise [ ''Eq, ''Foldable, ''Monoid ] -- deriveHierarchy ''ComponentWise [ ''Monoid ] class (Boolean (Logic a), Logic (Elem a) ~ Logic a) => SimpleContainerLogic a instance (Boolean (Logic a), Logic (Elem a) ~ Logic a) => SimpleContainerLogic a --- instance (SimpleContainerLogic a, Eq_ (Elem a), Foldable a) => Eq_ (ComponentWise a) where +-- instance (SimpleContainerLogic a, Eq (Elem a), Foldable a) => Eq (ComponentWise a) where -- (ComponentWise a1)==(ComponentWise a2) = toList a1==toList a2 -instance (SimpleContainerLogic a, Eq_ a, POrd_ (Elem a), Foldable a) => POrd_ (ComponentWise a) where +instance (SimpleContainerLogic a, Eq a, POrd (Elem a), Foldable a) => POrd (ComponentWise a) where inf (ComponentWise a1) (ComponentWise a2) = fromList $ go (toList a1) (toList a2) where + go :: [Elem a] -> [Elem a] -> [Elem a] go (x:xs) (y:ys) = inf x y:go xs ys go _ _ = [] -instance (SimpleContainerLogic a, Eq_ a, POrd_ (Elem a), Foldable a) => MinBound_ (ComponentWise a) where +instance (SimpleContainerLogic a, Eq a, POrd (Elem a), Foldable a) => MinBound (ComponentWise a) where minBound = ComponentWise zero -instance (SimpleContainerLogic a, Eq_ a, Lattice_ (Elem a), Foldable a) => Lattice_ (ComponentWise a) where +instance (SimpleContainerLogic a, Eq a, Lattice (Elem a), Foldable a) => Lattice (ComponentWise a) where sup (ComponentWise a1) (ComponentWise a2) = fromList $ go (toList a1) (toList a2) where + go :: [Elem a] -> [Elem a] -> [Elem a] go (x:xs) (y:ys) = sup x y:go xs ys go xs [] = xs go [] ys = ys diff --git a/src/SubHask/Algebra/Group.hs b/src/SubHask/Algebra/Group.hs index 12744fb..19171c3 100644 --- a/src/SubHask/Algebra/Group.hs +++ b/src/SubHask/Algebra/Group.hs @@ -11,8 +11,6 @@ import qualified Prelude as P import SubHask.Algebra import SubHask.Category -import SubHask.Mutable -import SubHask.SubType import SubHask.Internal.Prelude import SubHask.TemplateHaskell.Deriving @@ -23,69 +21,13 @@ newtype NonNegative t = NonNegative { unNonNegative :: t } deriveHierarchy ''NonNegative [ ''Enum, ''Boolean, ''Rig, ''Metric ] -instance (Ord t, Group t) => Cancellative (NonNegative t) where +instance (Ord t, ClassicalLogic t, Group t) => Cancellative (NonNegative t) where (NonNegative t1)-(NonNegative t2) = if diff>zero then NonNegative diff else NonNegative zero where diff=t1-t2 -------------------- - -{- -newtype a +> b = HomHask { unHomHask :: a -> b } -infixr +> - -unsafeHomHask2 :: (a -> b -> c) -> (a +> b +> c) -unsafeHomHask2 f = HomHask (\a -> HomHask $ \b -> f a b) - -instance Category (+>) where - type ValidCategory (+>) a = () - id = HomHask id - (HomHask a).(HomHask b) = HomHask $ a.b - -instance Sup (+>) (->) (->) -instance Sup (->) (+>) (->) -instance (+>) <: (->) where - embedType_ = Embed2 unHomHask - -instance Monoidal (+>) where - type Tensor (+>) = (,) - tensor = unsafeHomHask2 $ \a b -> (a,b) - -instance Braided (+>) where - braid = HomHask $ \(a,b) -> (b,a) - unbraid = braid - -instance Closed (+>) where - curry (HomHask f) = HomHask $ \ a -> HomHask $ \b -> f (a,b) - uncurry (HomHask f) = HomHask $ \ (a,b) -> unHomHask (f a) b - -mkSubtype [t|Int|] [t|Integer|] 'toInteger - -[subhask| -poop :: (Semigroup' g, Ring g) => g +> g -poop = (+:1) -|] - -class Semigroup' a where - (+:) :: a +> a +> a - -instance Semigroup' Int where (+:) = unsafeHomHask2 (+) - -instance Semigroup' [a] where (+:) = unsafeHomHask2 (+) - -f :: Integer +> Integer -f = HomHask $ \i -> i+1 - -n1 = NonNegative 5 :: NonNegative Int -n2 = NonNegative 3 :: NonNegative Int -i1 = 5 :: Int -i2 = 3 :: Int -j1 = 5 :: Integer -j2 = 3 :: Integer --} - ------------------------------------------------------------------------------- -- integers modulo n @@ -96,14 +38,10 @@ class Quotient a (b::k) where -- | The type of equivalence classes created by a mod b. newtype (/) (a :: *) (b :: k) = Mod a --- mkDefaultMutable [t| forall a b. a/b |] - --- newtype instance Mutable m (a/b) = Mutable_Mod (Mutable m a) - instance (Quotient a b, Arbitrary a) => Arbitrary (a/b) where arbitrary = liftM mkQuotient arbitrary -deriveHierarchyFiltered ''(/) [ ''Eq_, ''P.Ord ] [''Arbitrary] +deriveHierarchyFiltered ''(/) [ ''Eq, ''P.Ord ] [''Arbitrary] instance (Semigroup a, Quotient a b) => Semigroup (a/b) where (Mod z1) + (Mod z2) = mkQuotient $ z1 + z2 @@ -128,8 +66,6 @@ instance (Rig a, Quotient a b) => Rig (a/b) where instance (Ring a, Quotient a b) => Ring (a/b) where fromInteger i = mkQuotient $ fromInteger i -type instance ((a/b)> Module (a/b) where (Mod a) .* r = mkQuotient $ a .* r @@ -145,9 +81,10 @@ instance KnownNat n => Quotient Integer n mkQuotient i = Mod $ i `P.mod` (natVal (Proxy::Proxy n)) -- | Extended Euclid's algorithm is used to calculate inverses in modular arithmetic -extendedEuclid :: (Eq t, Integral t) => t -> t -> (t,t,t,t,t,t) +extendedEuclid :: forall t. (Eq t, ClassicalLogic t, Integral t) => t -> t -> (t,t,t,t,t,t) extendedEuclid a b = go zero one one zero b a where + go :: t -> t -> t -> t -> t -> t -> (t,t,t,t,t,t) go s1 s0 t1 t0 r1 r0 = if r1==zero then (s1,s0,t1,t0,undefined,r0) else go s1' s0' t1' t0' r1' r0' @@ -169,9 +106,7 @@ extendedEuclid a b = go zero one one zero b a -- See . newtype Galois (p::Nat) (k::Nat) = Galois (Z (p^k)) -type instance Galois p k >< Integer = Galois p k - -deriveHierarchy ''Galois [''Eq_,''Ring] +deriveHierarchy ''Galois [''Eq,''Ring] instance KnownNat (p^k) => Module (Galois p k) where z .* i = Galois (Mod i) * z @@ -231,7 +166,7 @@ data GrothendieckGroup g where -- See for more detail. newtype VedicSquare (n::Nat) = VedicSquare (Z n) -deriveHierarchy ''VedicSquare [''Eq_] +deriveHierarchy ''VedicSquare [''Eq] instance KnownNat n => Semigroup (VedicSquare n) where (VedicSquare v1)+(VedicSquare v2) = VedicSquare $ v1*v2 diff --git a/src/SubHask/Algebra/Logic.hs b/src/SubHask/Algebra/Logic.hs index f2d9357..3214f79 100644 --- a/src/SubHask/Algebra/Logic.hs +++ b/src/SubHask/Algebra/Logic.hs @@ -1,14 +1,14 @@ +-- | +-- +-- See "Plausibility Measures: A User's Guide" from UAI 1995 module SubHask.Algebra.Logic where import Control.Monad -import qualified Prelude as P import Test.QuickCheck.Gen (suchThat,oneof) import SubHask.Algebra import SubHask.Category -import SubHask.Compatibility.Base -import SubHask.SubType import SubHask.Internal.Prelude import SubHask.TemplateHaskell.Deriving @@ -25,30 +25,26 @@ type Goedel = Goedel_ Rational newtype Goedel_ r = Goedel_ r -deriveHierarchyFiltered ''Goedel_ [ ''Eq_ ] [ ''Arbitrary ] +deriveHierarchyFiltered ''Goedel_ [ ''Eq ] [ ''Arbitrary ] -instance (OrdRing_ r, Arbitrary r) => Arbitrary (Goedel_ r) where +instance (OrdRing_ r, ClassicalLogic r, Arbitrary r) => Arbitrary (Goedel_ r) where arbitrary = fmap Goedel_ $ arbitrary `suchThat` ((>=0) && (<=1)) -instance OrdRing_ r => POrd_ (Goedel_ r) where --- inf (Goedel_ r1) (Goedel_ r2) = Goedel_ $ max 0 (r1 + r2 - 1) +instance OrdRing_ r => POrd (Goedel_ r) where inf (Goedel_ r1) (Goedel_ r2) = Goedel_ $ min r1 r2 --- inf (Goedel_ r1) (Goedel_ r2) = Goedel_ $ r1*r2 -instance OrdRing_ r => Lattice_ (Goedel_ r) where --- sup (Goedel_ r1) (Goedel_ r2) = Goedel_ $ min 1 (r1 + r2) +instance OrdRing_ r => Lattice (Goedel_ r) where sup (Goedel_ r1) (Goedel_ r2) = Goedel_ $ max r1 r2 --- sup l1 l2 = not $ inf (not l1) (not l2) -instance OrdRing_ r => Ord_ (Goedel_ r) +instance OrdRing_ r => Ord (Goedel_ r) -instance OrdRing_ r => MinBound_ (Goedel_ r) where +instance OrdRing_ r => MinBound (Goedel_ r) where minBound = Goedel_ 0 instance OrdRing_ r => Bounded (Goedel_ r) where maxBound = Goedel_ 1 -instance OrdRing_ r => Heyting (Goedel_ r) where +instance (OrdRing_ r, ClassicalLogic r) => Heyting (Goedel_ r) where -- (Goedel_ r1)==>(Goedel_ r2) = if r1 <= r2 then Goedel_ 1 else Goedel_ (1 - r1 + r2) (Goedel_ r1)==>(Goedel_ r2) = if r1 <= r2 then Goedel_ 1 else Goedel_ r2 @@ -75,29 +71,29 @@ instance Arbitrary H3 where type instance Logic H3 = Bool -instance Eq_ H3 where +instance Eq H3 where HTrue == HTrue = True HFalse == HFalse = True HUnknown == HUnknown = True _ == _ = False -instance POrd_ H3 where +instance POrd H3 where inf HTrue HTrue = HTrue inf HTrue HUnknown = HUnknown inf HUnknown HTrue = HUnknown inf HUnknown HUnknown = HUnknown inf _ _ = HFalse -instance Lattice_ H3 where +instance Lattice H3 where sup HFalse HFalse = HFalse sup HFalse HUnknown = HUnknown sup HUnknown HFalse = HUnknown sup HUnknown HUnknown = HUnknown sup _ _ = HTrue -instance Ord_ H3 +instance Ord H3 -instance MinBound_ H3 where +instance MinBound H3 where minBound = HFalse instance Bounded H3 where @@ -136,29 +132,29 @@ instance Arbitrary K3 where type instance Logic K3 = Bool -instance Eq_ K3 where +instance Eq K3 where KTrue == KTrue = True KFalse == KFalse = True KUnknown == KUnknown = True _ == _ = False -instance POrd_ K3 where +instance POrd K3 where inf KTrue KTrue = KTrue inf KTrue KUnknown = KUnknown inf KUnknown KTrue = KUnknown inf KUnknown KUnknown = KUnknown inf _ _ = KFalse -instance Lattice_ K3 where +instance Lattice K3 where sup KFalse KFalse = KFalse sup KFalse KUnknown = KUnknown sup KUnknown KFalse = KUnknown sup KUnknown KUnknown = KUnknown sup _ _ = KTrue -instance Ord_ K3 +instance Ord K3 -instance MinBound_ K3 where +instance MinBound K3 where minBound = KFalse instance Bounded K3 where @@ -173,29 +169,24 @@ newtype Boolean2Ring b = Boolean2Ring b deriveHierarchy ''Boolean2Ring [ ''Boolean ] -mkBoolean2Ring :: Boolean b => b -> Boolean2Ring b -mkBoolean2Ring = Boolean2Ring - -instance (IsMutable b, Boolean b, ValidLogic b) => Semigroup (Boolean2Ring b) where +instance (IsMutable b, Boolean b, Eq b) => Semigroup (Boolean2Ring b) where (Boolean2Ring b1)+(Boolean2Ring b2) = Boolean2Ring $ (b1 || b2) && not (b1 && b2) -instance (IsMutable b, Boolean b, ValidLogic b) => Abelian (Boolean2Ring b) +instance (IsMutable b, Boolean b, Eq b) => Abelian (Boolean2Ring b) -instance (IsMutable b, Boolean b, ValidLogic b) => Monoid (Boolean2Ring b) where +instance (IsMutable b, Boolean b, Eq b) => Monoid (Boolean2Ring b) where zero = Boolean2Ring $ false -instance (IsMutable b, Boolean b, ValidLogic b) => Cancellative (Boolean2Ring b) where +instance (IsMutable b, Boolean b, Eq b) => Cancellative (Boolean2Ring b) where (-)=(+) --- b1-b2 = b1+negate b2 -instance (IsMutable b, Boolean b, ValidLogic b) => Group (Boolean2Ring b) where +instance (IsMutable b, Boolean b, Eq b) => Group (Boolean2Ring b) where negate = id --- negate (Boolean2Ring b) = Boolean2Ring $ not b -instance (IsMutable b, Boolean b, ValidLogic b) => Rg (Boolean2Ring b) where +instance (IsMutable b, Boolean b, Eq b) => Rg (Boolean2Ring b) where (Boolean2Ring b1)*(Boolean2Ring b2) = Boolean2Ring $ b1 && b2 -instance (IsMutable b, Boolean b, ValidLogic b) => Rig (Boolean2Ring b) where +instance (IsMutable b, Boolean b, Eq b) => Rig (Boolean2Ring b) where one = Boolean2Ring $ true -instance (IsMutable b, Boolean b, ValidLogic b) => Ring (Boolean2Ring b) +instance (IsMutable b, Boolean b, Eq b) => Ring (Boolean2Ring b) diff --git a/src/SubHask/Algebra/Matrix.hs b/src/SubHask/Algebra/Matrix.hs index 2d67bbb..7d58a51 100644 --- a/src/SubHask/Algebra/Matrix.hs +++ b/src/SubHask/Algebra/Matrix.hs @@ -1,7 +1,4 @@ -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# OPTIONS_GHC -fno-warn-unused-binds #-} {-# OPTIONS_GHC -fno-warn-missing-methods #-} -{-# LANGUAGE OverloadedStrings #-} module SubHask.Algebra.Matrix ( Matrix (..) @@ -12,7 +9,6 @@ module SubHask.Algebra.Matrix , row , col , (!!) - , colLength , Matrix'(..) ) where @@ -29,19 +25,17 @@ data family Matrix vect r (a::k) (b::k) type ValidMatrix vect r = ( FiniteModule vect - , r ~ Scalar (Elem vect) , Hilbert vect + , r ~ Scalar (Elem vect) + , Index vect ~ Int , VectorSpace r , Prim r - , Index vect ~ Int ) type instance Scalar (Matrix vect r m n) = Scalar r type instance Logic (Matrix vect r m n) = Logic r -type instance Matrix vect r m n >< a = Matrix vect (r> (r -> r -> r) -> Matrix vect r (a::Symbol) (b::Symbol) @@ -137,17 +130,17 @@ binopDyn f m1@(Matrix_Dynamic vect1 l1) m2@(Matrix_Dynamic vect2 l2) = if -- algebra instance - (Prim r, Monoid r, ValidMatrix vect r) => + (Monoid r, ValidMatrix vect r) => Semigroup (Matrix vect r (a::Symbol) (b::Symbol)) where {-# INLINE (+) #-} ; (+) = binopDyn (+) instance - (Monoid r, Cancellative r, Prim r, ValidMatrix vect r) + (Monoid r, Cancellative r, ValidMatrix vect r) => Cancellative (Matrix vect r (a::Symbol) (b::Symbol)) where {-# INLINE (-) #-} ; (-) = binopDyn (-) instance - (Monoid r, Prim r, ValidMatrix vect r) => + (Monoid r, ValidMatrix vect r) => Monoid (Matrix vect r (a::Symbol) (b::Symbol)) where {-# INLINE zero #-} zero = unsafeInlineIO $ do @@ -155,24 +148,24 @@ instance return $ Matrix_Dynamic vect 0 instance - (Group r, Prim r, ValidMatrix vect r) => + (Group r, ValidMatrix vect r) => Group (Matrix vect r (a::Symbol) (b::Symbol)) where {-# INLINE negate #-} negate v = monopDyn negate v instance - (Monoid r, Abelian r, Prim r, ValidMatrix vect r) => + (Monoid r, Abelian r, ValidMatrix vect r) => Abelian (Matrix vect r (a::Symbol) (b::Symbol)) instance - (Module r, Prim r, ValidMatrix vect r) => + (Module r, ValidMatrix vect r) => Module (Matrix vect r (a::Symbol) (b::Symbol)) where {-# INLINE (.*) #-} ; (.*) v r = monopDyn (.*r) v type instance Actor (Matrix vect r (a::Symbol) (b::Symbol)) = Actor r instance - (Action r, Semigroup r, Prim r, ValidMatrix vect r) => + (Action r, ValidMatrix vect r) => Action (Matrix vect r (a::Symbol) (b::Symbol)) where {-# INLINE (.+) #-} (.+) v r = monopDyn (.+r) v @@ -185,7 +178,7 @@ instance ones = undefined instance - (VectorSpace r, Prim r, ValidMatrix vect r) => + (VectorSpace r, ValidMatrix vect r) => VectorSpace (Matrix vect r (a::Symbol) (b::Symbol)) where {-# INLINE (./) #-} ; (./) v r = monopDyn (./r) v {-# INLINE (./.) #-} ; (./.) = binopDyn (./.) @@ -194,20 +187,20 @@ instance -- container instance - (ValidMatrix vect r, Monoid r, ValidLogic r, Prim r, IsScalar r) + (ValidMatrix vect r, Monoid r, ValidScalar r) => IxContainer (Matrix vect r (a::Symbol) (b::Symbol)) where {-# INLINE (!) #-} (!) m@(Matrix_Dynamic _ l) i = m!!(i `div` l, i `mod` l) instance - (Prim r, FreeModule r, ValidMatrix vect r, ValidLogic r, IsScalar r) + (FreeModule r, ValidMatrix vect r, ValidScalar r) => FiniteModule (Matrix vect r (a::Symbol) (b::Symbol)) where {-# INLINE dim #-} dim m = colLength m * rowLength m - {-# INLINABLE unsafeToModule #-} +-- {-# INLINABLE unsafeToModule #-} -- unsafeToModule xs = unsafeToModuleM r xs {-# INLINE row #-} @@ -263,22 +256,16 @@ data Matrix' vect r (a::Symbol) (b::Symbol) where Id :: (ValidMatrix vect r) => - {-#UNPACK#-}!(Scalar r) -> Matrix' vect r (a::Symbol) (a::Symbol) + !(Scalar r) -> Matrix' vect r (a::Symbol) (a::Symbol) Mat :: (ValidMatrix vect r) => - {-#UNPACK#-}!(Matrix vect r (a::Symbol) (b::Symbol)) + !(Matrix vect r (a::Symbol) (b::Symbol)) -> Matrix' vect r (a::Symbol) (b::Symbol) type instance Scalar (Matrix' vect r (a::Symbol) (b::Symbol)) = Scalar r type instance Logic (Matrix' vect r (a::Symbol) (b::Symbol)) = Bool -type instance Matrix' vect r (a::Symbol) (b::Symbol) >< a = - Tensor_Linear (Matrix' vect r (a::Symbol) (b::Symbol)) a -type family Tensor_Linear a b where - Tensor_Linear (Matrix' vect r (a::Symbol) (b::Symbol)) c = - Matrix' vect r (a::Symbol) (b::Symbol) - deriving instance ( ValidMatrix vect (Scalar r), Show (Scalar r) ) => Show (Matrix' vect r (a::Symbol) (b::Symbol)) diff --git a/src/SubHask/Algebra/Metric.hs b/src/SubHask/Algebra/Metric.hs index 6a780bc..b7fab47 100644 --- a/src/SubHask/Algebra/Metric.hs +++ b/src/SubHask/Algebra/Metric.hs @@ -4,12 +4,9 @@ module SubHask.Algebra.Metric import SubHask.Category import SubHask.Algebra -import SubHask.Algebra.Ord --- import SubHask.Monad --- import SubHask.Compatibility.Base import SubHask.Internal.Prelude import Control.Monad - +import GHC.Classes (Ord) import qualified Data.List as L import System.IO @@ -26,6 +23,8 @@ printTriDistances m1 m2 m3 = do -- A metric is a tree metric iff two of these perfect matchings have the same weight. -- This is called the 4 points condition. -- printQuadDistances :: (Ord (Scalar m), Show (Scalar m), Metric m) => m -> m -> m -> m -> IO () +printQuadDistances :: (GHC.Classes.Ord (Scalar t), Show (Scalar t), Metric t) => + t -> t -> t -> t -> IO () printQuadDistances m1 m2 m3 m4 = do forM_ xs $ \(match,dist) -> do putStrLn $ match ++ " = " ++ show dist @@ -43,6 +42,7 @@ printQuadDistances m1 m2 m3 m4 = do ] , distance n1 n2 + distance n3 n4 ) + mkMatching _ = undefined -------------------------------------------------------------------------------- @@ -66,7 +66,6 @@ invar_Ball_radius b = radius b >= 0 type instance Scalar (Ball v) = Scalar v type instance Logic (Ball v) = Logic v type instance Elem (Ball v) = v -type instance SetElem (Ball v) v' = Ball v' -- misc classes @@ -85,28 +84,21 @@ instance (NFData v, NFData (Scalar v)) => NFData (Ball v) where -- comparison -instance (Eq v, HasScalar v) => Eq_ (Ball v) where +instance (Metric v, Logic (Scalar v)~Logic v) => Eq (Ball v) where b1 == b2 = radius b1 == radius b2 && center b1 == center b2 -- algebra -instance (Metric v, HasScalar v, ClassicalLogic v) => Semigroup (Ball v) where +instance (Metric v, Logic (Scalar v)~Logic v) => Semigroup (Ball v) where b1+b2 = b1 { radius = radius b2 + radius b1 + distance (center b1) (center b2) } --- b1+b2 = b1 { radius = radius b2 + max (radius b1) (distance (center b1) (center b2)) } - --- b1+b2 = b1' { radius = max (radius b1') (radius b2' + distance (center b1') (center b2')) } --- where --- (b1',b2') = if radius b1 > radius b2 --- then (b1,b2) --- else (b2,b1) -- container -instance (Metric v, HasScalar v, ClassicalLogic v) => Constructible (Ball v) where +instance (Metric v, Logic (Scalar v)~Logic v) => Constructible (Ball v) where singleton v = Ball 0 v -instance (Metric v, HasScalar v, ClassicalLogic v) => Container (Ball v) where +instance (Metric v, Logic (Scalar v)~Logic v) => Container (Ball v) where elem v b = not $ isFartherThan v (center b) (radius b) -------------------------------------------------------------------------------- diff --git a/src/SubHask/Algebra/Ord.hs b/src/SubHask/Algebra/Ord.hs index ec2b564..1789bc7 100644 --- a/src/SubHask/Algebra/Ord.hs +++ b/src/SubHask/Algebra/Ord.hs @@ -9,13 +9,10 @@ import qualified GHC.Arr as Arr import Data.Array.ST hiding (freeze,thaw) import Control.Monad import Control.Monad.Random -import Control.Monad.ST import Prelude (take) import SubHask.Algebra import SubHask.Category -import SubHask.Mutable -import SubHask.SubType import SubHask.Internal.Prelude import SubHask.TemplateHaskell.Deriving @@ -31,13 +28,13 @@ instance Show a => Show (WithPreludeOrd a) where -- | FIXME: for some reason, our deriving mechanism doesn't work on Show here; -- It causes's Set's show to enter an infinite loop -deriveHierarchyFiltered ''WithPreludeOrd [ ''Eq_, ''Enum, ''Boolean, ''Ring, ''Metric ] [ ''Show ] +deriveHierarchyFiltered ''WithPreludeOrd [ ''Eq, ''Enum, ''Boolean, ''Ring, ''Metric ] [ ''Show ] -instance Eq a => P.Eq (WithPreludeOrd a) where +instance (Eq a, ClassicalLogic a) => P.Eq (WithPreludeOrd a) where {-# INLINE (==) #-} a==b = a==b -instance Ord a => P.Ord (WithPreludeOrd a) where +instance (Ord a, ClassicalLogic a) => P.Ord (WithPreludeOrd a) where {-# INLINE (<=) #-} a<=b = a<=b @@ -46,21 +43,21 @@ instance Ord a => P.Ord (WithPreludeOrd a) where -- -- FIXME: -- We should put this in the container hierarchy so we can sort any data type -sort :: Ord a => [a] -> [a] +sort :: (Ord a, ClassicalLogic a) => [a] -> [a] sort = map unWithPreludeOrd . L.sort . map WithPreludeOrd -- | Randomly shuffles a list in time O(n log n); see http://www.haskell.org/haskellwiki/Random_shuffle -shuffle :: (Eq a, MonadRandom m) => [a] -> m [a] +shuffle :: MonadRandom m => [a] -> m [a] shuffle xs = do let l = length xs rands <- take l `liftM` getRandomRs (0, l-1) let ar = runSTArray ( do - ar <- Arr.thawSTArray (Arr.listArray (0, l-1) xs) + ar' <- Arr.thawSTArray (Arr.listArray (0, l-1) xs) forM_ (L.zip [0..(l-1)] rands) $ \(i, j) -> do - vi <- Arr.readSTArray ar i - vj <- Arr.readSTArray ar j - Arr.writeSTArray ar j vi - Arr.writeSTArray ar i vj - return ar + vi <- Arr.readSTArray ar' i + vj <- Arr.readSTArray ar' j + Arr.writeSTArray ar' j vi + Arr.writeSTArray ar' i vj + return ar' ) return (Arr.elems ar) diff --git a/src/SubHask/Algebra/Parallel.hs b/src/SubHask/Algebra/Parallel.hs index 4cf3c58..ff22d5f 100644 --- a/src/SubHask/Algebra/Parallel.hs +++ b/src/SubHask/Algebra/Parallel.hs @@ -2,6 +2,7 @@ -- And if you believe that @NC /= P@, then every parallel algorithm is induced by a monoid in this manner. module SubHask.Algebra.Parallel ( parallel + , parallelN , disableMultithreading , Partitionable (..) , law_Partitionable_length @@ -148,12 +149,12 @@ class (Monoid t, Foldable t, Constructible t) => Partitionable t where partitionInterleaved :: Int -> t -> [t] partitionInterleaved i t = map (\(x:xs) -> fromList1 x xs) $ partitionInterleaved_list i $ toList t -law_Partitionable_length :: (ClassicalLogic t, Partitionable t) => Int -> t -> Bool +law_Partitionable_length :: (Partitionable t) => Int -> t -> Bool law_Partitionable_length n t | n > 0 = length (partition n t) <= n | otherwise = True -law_Partitionable_monoid :: (ClassicalLogic t, Eq_ t, Partitionable t) => Int -> t -> Bool +law_Partitionable_monoid :: (ClassicalLogic t, Eq t, Partitionable t) => Int -> t -> Bool law_Partitionable_monoid n t | n > 0 = sum (partition n t) == t | otherwise = True @@ -164,11 +165,11 @@ parfoldtree1 :: Monoid a => [a] -> a parfoldtree1 as = case go as of [] -> zero [a] -> a - as -> parfoldtree1 as + as' -> parfoldtree1 as' where go [] = [] go [a] = [a] - go (a1:a2:as) = par a12 $ a12:go as + go (a1:a2:as'') = par a12 $ a12:go as'' where a12=a1+a2 @@ -184,22 +185,22 @@ partitionBlocked_list :: Int -> [a] -> [[a]] partitionBlocked_list n xs = go xs where go [] = [] - go xs = a:go b + go xs' = a:go b where - (a,b) = P.splitAt len xs + (a,b) = P.splitAt len xs' - size = length xs - len = size `div` n - + if size `rem` n == 0 then 0 else 1 + size' = length xs + len = size' `div` n + + if size' `rem` n == 0 then 0 else 1 -- | This is an alternative definition for list partitioning. -- It should be faster on large lists because it only requires one traversal. -- But it also breaks parallelism for non-commutative operations. {-# INLINABLE partitionInterleaved_list #-} partitionInterleaved_list :: Int -> [a] -> [[a]] -partitionInterleaved_list n xs = [map snd $ P.filter (\(i,x)->i `mod` n==j) ixs | j<-[0..n-1]] +partitionInterleaved_list n xs = [map snd $ P.filter (\(i,_)->i `mod` n==j) ixs | j<-[0..n-1]] where ixs = addIndex 0 xs - addIndex i [] = [] - addIndex i (x:xs) = (i,x):(addIndex (i+1) xs) + addIndex _ [] = [] + addIndex i (x:xs') = (i,x):(addIndex (i+1) xs') diff --git a/src/SubHask/Algebra/Random.hs b/src/SubHask/Algebra/Random.hs deleted file mode 100644 index d60fe03..0000000 --- a/src/SubHask/Algebra/Random.hs +++ /dev/null @@ -1,14 +0,0 @@ -module SubHask.Algebra.Random - where - -import SubHask.Algebra -import SubHask.Category -import SubHask.Monad - -class Random t where - sample :: Monad cat m => t -> m (Elem t) - -class Monad Hask m => RandGen m where - - -data family Normal :: a -> * diff --git a/src/SubHask/Algebra/Ring.hs b/src/SubHask/Algebra/Ring.hs index 0ed1308..dec944b 100644 --- a/src/SubHask/Algebra/Ring.hs +++ b/src/SubHask/Algebra/Ring.hs @@ -1,9 +1,10 @@ +{-# OPTIONS_GHC -fno-warn-missing-methods #-} + module SubHask.Algebra.Ring where import SubHask.Algebra import SubHask.Category -import SubHask.Internal.Prelude -------------------------------------------------------------------------------- @@ -14,11 +15,10 @@ newtype Componentwise v = Componentwise { unComponentwise :: v } type instance Scalar (Componentwise v) = Scalar v type instance Logic (Componentwise v) = Logic v type instance Elem (Componentwise v) = Scalar v -type instance SetElem (Componentwise v) v' = Componentwise v' instance IsMutable (Componentwise v) -instance Eq_ v => Eq_ (Componentwise v) where +instance Eq v => Eq (Componentwise v) where (Componentwise v1)==(Componentwise v2) = v1==v2 instance Semigroup v => Semigroup (Componentwise v) where @@ -45,7 +45,3 @@ instance FiniteModule v => Ring (Componentwise v) instance (FiniteModule v, VectorSpace v) => Field (Componentwise v) where (Componentwise v1)/(Componentwise v2) = Componentwise $ v1./.v2 - --- instance (ValidLogic v, FiniteModule v) => IxContainer (Componentwise v) where --- values (Componentwise v) = values v - diff --git a/src/SubHask/Algebra/Trans/Kernel.hs b/src/SubHask/Algebra/Trans/Kernel.hs deleted file mode 100644 index 49a0ba3..0000000 --- a/src/SubHask/Algebra/Trans/Kernel.hs +++ /dev/null @@ -1,106 +0,0 @@ -module SubHask.Algebra.Trans.Kernel - where - -import qualified Prelude as P -import SubHask -import SubHask.TemplateHaskell.Deriving - -{- -kernel2distance :: (Floating (Scalar v), VectorSpace v) => (v -> v -> Scalar v) -> v -> v -> Scalar v -kernel2distance kernel v1 v2 = sqrt $ kernel v1 v1 - kernel v1 v2 - kernel v2 v1 + kernel v2 v2 - -------------------------------------------------------------------------------- --- generic - --- FIXME: use a dependently typed kernel like this for everything --- create a couple of standard static ones -data WithKernel (kernel::k) v where - WithKernel :: (v -> v -> Scalar v) -> v -> WithKernel k v - -type instance Scalar (WithKernel k v) = Scalar v -type instance Logic (WithKernel k v) = Logic v - -instance Eq v => Eq_ (WithKernel k v) where - (WithKernel _ v1)==(WithKernel _ v2) = v1==v2 - -instance - ( Ord (Scalar v) - , Floating (Scalar v) - , VectorSpace v - , Eq v - ) => Metric (WithKernel k v) - where - distance (WithKernel k v1) (WithKernel _ v2) = kernel2distance k v1 v2 - -sameKernel :: WithKernel k1 v -> WithKernel k2 v -> WithKernel k2 v -sameKernel (WithKernel k1 v1) (WithKernel k2 _) = WithKernel k2 v1 - -------------------------------------------------------------------------------- --- polynomial - -newtype Polynomial (n::Nat) v = Polynomial v - -deriveHierarchy ''Polynomial - [ ''Ord - , ''Boolean - , ''VectorSpace - ] - -instance (KnownNat n, Hilbert v) => Metric (Polynomial n v) where - distance = kernel2distance polykernel - where - polykernel (Polynomial v1) (Polynomial v2) = (1+v1<>v2)**n - n = fromIntegral $ natVal (Proxy::Proxy n) - -------------------------------------------------------------------------------- --- ExponentialKernel - -newtype ExponentialKernel (n::Nat) v = ExponentialKernel v - -deriveHierarchy ''ExponentialKernel - [ ''Ord - , ''Boolean - , ''VectorSpace - ] - -instance (KnownNat n, Hilbert v) => Metric (ExponentialKernel n v) where - distance = kernel2distance rbf - where - rbf (ExponentialKernel v1) (ExponentialKernel v2) = exp $ -(size $ v1 - v2) / sigma2 - sigma2=10 - -------------------------------------------------------------------------------- --- RBF - -newtype RBF (n::Nat) v = RBF v - -deriveHierarchy ''RBF - [ ''Ord - , ''Boolean - , ''VectorSpace - ] - -instance (KnownNat n, Hilbert v) => Metric (RBF n v) where - distance = kernel2distance rbf - where - rbf (RBF v1) (RBF v2) = exp $ -(size $ v1 - v2)**2 / sigma2 - sigma2=1/100 - -------------------------------------------------------------------------------- --- Sigmoid - -newtype Sigmoid (n::Nat) v = Sigmoid v - -deriveHierarchy ''Sigmoid - [ ''Ord - , ''Boolean - , ''VectorSpace - ] - -instance (Hilbert v) => Metric (Sigmoid n v) where - distance = kernel2distance sigmoid - where - sigmoid (Sigmoid v1) (Sigmoid v2) = tanh $ alpha * v1<>v2 + beta - alpha=1/10000 - beta=0 --} diff --git a/src/SubHask/Algebra/Vector.hs b/src/SubHask/Algebra/Vector.hs index 34b2766..8bf9565 100644 --- a/src/SubHask/Algebra/Vector.hs +++ b/src/SubHask/Algebra/Vector.hs @@ -1,3 +1,6 @@ +{-# OPTIONS_GHC -fno-warn-missing-methods #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} + -- | Dense vectors and linear algebra operations. -- -- NOTE: @@ -18,12 +21,10 @@ module SubHask.Algebra.Vector ( SVector (..) , UVector (..) , ValidUVector - , ValidSVector , Unbox , type (+>) , SMatrix , unsafeMkSMatrix - , unsafeToModule -- * Debug , safeNewByteArray @@ -35,34 +36,23 @@ import qualified Prelude as P import Control.Monad.Primitive import Control.Monad import Data.Primitive hiding (sizeOf) -import Debug.Trace import qualified Data.Primitive as Prim import Foreign.Ptr import Foreign.ForeignPtr import Foreign.Marshal.Utils import Test.QuickCheck.Gen (frequency) -import qualified Data.Vector.Generic as VG -import qualified Data.Vector.Generic.Mutable as VGM import qualified Data.Vector.Unboxed as VU -import qualified Data.Vector.Unboxed.Mutable as VUM import qualified Data.Vector.Storable as VS --- import qualified Data.Packed.Matrix as HM import qualified Numeric.LinearAlgebra as HM -import qualified Numeric.LinearAlgebra.HMatrix as HM -import qualified Numeric.LinearAlgebra.Data as HM import SubHask.Algebra import SubHask.Category -import SubHask.Compatibility.Base import SubHask.Internal.Prelude import SubHask.SubType import Data.Csv (FromRecord,FromField,parseRecord) -import System.IO.Unsafe -import Unsafe.Coerce - -------------------------------------------------------------------------------- -- rewrite rules for faster static parameters -- @@ -97,16 +87,16 @@ type instance Scalar (UVector n r) = Scalar r type instance Logic (UVector n r) = Logic r -- type instance UVector n r >< a = UVector n (r>< b = Tensor_UVector (UVector m a) b -type family Tensor_UVector a b where - Tensor_UVector (UVector n r1) (UVector m r2) = UVector n r1 +> UVector m r2 - Tensor_UVector (UVector n r1) r1 = UVector n r1 -- (r1>< b = Tensor_UVector (UVector m a) b +-- type family Tensor_UVector a b where +-- Tensor_UVector (UVector n r1) (UVector m r2) = UVector n r1 +> UVector m r2 +-- Tensor_UVector (UVector n r1) r1 = UVector n r1 -- (r1> Show (UVector (n::Symbol) r) where +instance (Show r, Prim r) => Show (UVector (n::Symbol) r) where show (UVector_Dynamic arr off n) = if isZero n then "zero" else show $ go (extendDimensions n-1) [] @@ -125,19 +115,19 @@ instance (Show r, Monoid r, Prim r) => Show (UVector (n::Symbol) r) where where x = indexByteArray arr (off+i) :: r -instance (Arbitrary r, ValidUVector n r, FreeModule r, IsScalar r) => Arbitrary (UVector (n::Symbol) r) where +instance (Arbitrary r, ValidUVector n r, FreeModule r, ValidScalar r) => Arbitrary (UVector (n::Symbol) r) where arbitrary = frequency [ (1,return zero) , (9,fmap unsafeToModule $ replicateM 27 arbitrary) ] -instance (Show r, Monoid r, Prim r) => CoArbitrary (UVector (n::Symbol) r) where +instance (Show r, Prim r) => CoArbitrary (UVector (n::Symbol) r) where coarbitrary = coarbitraryShow -instance (NFData r, Prim r) => NFData (UVector (n::Symbol) r) where - rnf (UVector_Dynamic arr off n) = seq arr () +instance NFData (UVector (n::Symbol) r) where + rnf (UVector_Dynamic arr _ _) = seq arr () -instance (FromField r, ValidUVector n r, IsScalar r, FreeModule r) => FromRecord (UVector (n::Symbol) r) where +instance (FromField r, ValidUVector n r, ValidScalar r, FreeModule r) => FromRecord (UVector (n::Symbol) r) where parseRecord r = do rs :: [r] <- parseRecord r return $ unsafeToModule rs @@ -162,8 +152,8 @@ instance Prim r => IsMutable (UVector (n::Symbol) r) where let b = (extendDimensions n)*Prim.sizeOf (undefined::r) if n==0 then do - ref <- newPrimRef $ UVector_Dynamic arr1 off1 n - return $ Mutable_UVector ref + ref' <- newPrimRef $ UVector_Dynamic arr1 off1 n + return $ Mutable_UVector ref' else unsafePrimToPrim $ do marr2 <- safeNewByteArray b 16 copyByteArray marr2 0 arr1 off1 b @@ -171,8 +161,8 @@ instance Prim r => IsMutable (UVector (n::Symbol) r) where ref2 <- newPrimRef (UVector_Dynamic arr2 0 n) return $ Mutable_UVector ref2 - write (Mutable_UVector ref) (UVector_Dynamic arr2 off2 n2) = do - (UVector_Dynamic arr1 off1 n1) <- readPrimRef ref + write (Mutable_UVector ref') (UVector_Dynamic arr2 off2 n2) = do + (UVector_Dynamic arr1 off1 n1) <- readPrimRef ref' unsafePrimToPrim $ if -- both ptrs null: do nothing | n1==0 && n2==0 -> return () @@ -182,11 +172,11 @@ instance Prim r => IsMutable (UVector (n::Symbol) r) where marr1' <- safeNewByteArray b 16 copyByteArray marr1' 0 arr2 off2 b arr1' <- unsafeFreezeByteArray marr1' - unsafePrimToPrim $ writePrimRef ref (UVector_Dynamic arr1' 0 n2) + unsafePrimToPrim $ writePrimRef ref' (UVector_Dynamic arr1' 0 n2) -- only arr2 null: make arr1 null | n2==0 -> do - writePrimRef ref (UVector_Dynamic arr2 0 n1) + writePrimRef ref' (UVector_Dynamic arr2 0 n1) -- both ptrs valid: perform a normal copy | otherwise -> do @@ -199,35 +189,17 @@ instance Prim r => IsMutable (UVector (n::Symbol) r) where -- algebra extendDimensions :: Int -> Int -extendDimensions = roundUpToNearest 4 -- i+4-i`rem`4 - --- extendDimensions :: Int -> Int --- extendDimensions x = x+r --- where --- m = 4 --- s = x`rem`m --- r = if s==0 then 0 else m-s +extendDimensions = roundUpToNearest 4 safeNewByteArray :: PrimMonad m => Int -> Int -> m (MutableByteArray (PrimState m)) safeNewByteArray b 16 = do let n=extendDimensions $ b`quot`4 marr <- newAlignedPinnedByteArray b 16 --- writeByteArray marr (n-0) (0::Float) --- writeByteArray marr (n-1) (0::Float) --- writeByteArray marr (n-2) (0::Float) --- writeByteArray marr (n-3) (0::Float) setByteArray marr 0 n (0::Float) - --- trace ("n="++show n) $ return () --- a <- forM [0..n-1] $ \i -> do --- v :: Float <- readByteArray marr i --- return $ unsafeInlineIO $ P.putStrLn $ "marr!"+show i+" = "+show v --- deepseq a $ return marr - return marr {-# INLINE binopDynUV #-} -binopDynUV :: forall a b n m. +binopDynUV :: forall a n. ( Prim a , Monoid a ) => (a -> a -> a) -> UVector (n::Symbol) a -> UVector (n::Symbol) a -> UVector (n::Symbol) a @@ -245,13 +217,13 @@ binopDynUV f v1@(UVector_Dynamic arr1 off1 n1) v2@(UVector_Dynamic arr2 off2 n2) where go _ (-1) = return () go marr3 i = do - let v1 = indexByteArray arr1 (off1+i) - v2 = indexByteArray arr2 (off2+i) - writeByteArray marr3 i (f v1 v2) + let v1' = indexByteArray arr1 (off1+i) + v2' = indexByteArray arr2 (off2+i) + writeByteArray marr3 i (f v1' v2') go marr3 (i-1) {-# INLINE monopDynUV #-} -monopDynUV :: forall a b n m. +monopDynUV :: forall a n. ( Prim a ) => (a -> a) -> UVector (n::Symbol) a -> UVector (n::Symbol) a monopDynUV f v@(UVector_Dynamic arr1 off1 n) = if n==0 @@ -270,81 +242,11 @@ monopDynUV f v@(UVector_Dynamic arr1 off1 n) = if n==0 writeByteArray marr2 i (f v1) go marr2 (i-1) -{- -{-# INLINE binopDynUVM #-} -binopDynUVM :: forall a b n m. - ( PrimBase m - , Prim a - , Prim b - , Monoid a - , Monoid b - ) => (a -> b -> a) -> Mutable m (UVector (n::Symbol) a) -> UVector n b -> m () -binopDynUVM f (Mutable_UVector ref) (UVector_Dynamic arr2 off2 n2) = do - (UVector_Dynamic arr1 off1 n1) <- readPrimRef ref - - let runop arr1 arr2 n = unsafePrimToPrim $ - withForeignPtr arr1 $ \p1 -> - withForeignPtr arr2 $ \p2 -> - go (plusPtr p1 off1) (plusPtr p2 off2) (n-1) - - unsafePrimToPrim $ if - -- both vectors are zero: do nothing - | isNull arr1 && isNull arr2 -> return () - - -- only left vector is zero: allocate space and overwrite old vector - -- FIXME: this algorithm requires two passes over the left vector - | isNull arr1 -> do - arr1' <- zerofp n2 - unsafePrimToPrim $ writePrimRef ref (UVector_Dynamic arr1' 0 n2) - runop arr1' arr2 n2 - - -- only right vector is zero: use a temporary zero vector to run like normal - -- FIXME: this algorithm requires an unneeded memory allocation and memory pass - | isNull arr2 -> do - arr2' <- zerofp n1 - runop arr1 arr2' n1 - - -- both vectors nonzero: run like normal - | otherwise -> runop arr1 arr2 n1 - - where - go _ _ (-1) = return () - go p1 p2 i = do - v1 <- peekElemOff p1 i - v2 <- peekElemOff p2 i - pokeElemOff p1 i (f v1 v2) - go p1 p2 (i-1) - -{-# INLINE monopDynM #-} -monopDynM :: forall a b n m. - ( PrimMonad m - , Prim a - ) => (a -> a) -> Mutable m (UVector (n::Symbol) a) -> m () -monopDynM f (Mutable_UVector ref) = do - (UVector_Dynamic arr1 off1 n) <- readPrimRef ref - if isNull arr1 - then return () - else unsafePrimToPrim $ - withForeignPtr arr1 $ \p1 -> - go (plusPtr p1 off1) (n-1) - - where - go _ (-1) = return () - go p1 i = do - v1 <- peekElemOff p1 i - pokeElemOff p1 i (f v1) - go p1 (i-1) - -------------------- - --} instance (Monoid r, Prim r) => Semigroup (UVector (n::Symbol) r) where {-# INLINE (+) #-} ; (+) = binopDynUV (+) --- {-# INLINE (+=) #-} ; (+=) = binopDynUVM (+) instance (Monoid r, Cancellative r, Prim r) => Cancellative (UVector (n::Symbol) r) where {-# INLINE (-) #-} ; (-) = binopDynUV (-) --- {-# INLINE (-=) #-} ; (-=) = binopDynUVM (-) instance (Monoid r, Prim r) => Monoid (UVector (n::Symbol) r) where {-# INLINE zero #-} @@ -361,32 +263,27 @@ instance (Monoid r, Abelian r, Prim r) => Abelian (UVector (n::Symbol) r) instance (Module r, ValidUVector n r) => Module (UVector (n::Symbol) r) where {-# INLINE (.*) #-} ; (.*) v r = monopDynUV (.*r) v --- {-# INLINE (.*=) #-} ; (.*=) v r = monopDynM (.*r) v type instance Actor (UVector n r) = Actor r -instance (Action r, Semigroup r, Prim r) => Action (UVector (n::Symbol) r) where +instance (Action r, Prim r) => Action (UVector (n::Symbol) r) where {-# INLINE (.+) #-} (.+) v r = monopDynUV (.+r) v instance (FreeModule r, ValidUVector n r) => FreeModule (UVector (n::Symbol) r) where {-# INLINE (.*.) #-} ; (.*.) = binopDynUV (.*.) --- {-# INLINE (.*.=) #-} ; (.*.=) = binopDynUVM (.*.) instance (VectorSpace r, ValidUVector n r) => VectorSpace (UVector (n::Symbol) r) where {-# INLINE (./) #-} ; (./) v r = monopDynUV (./r) v --- {-# INLINE (./=) #-} ; (./=) v r = monopDynM (./r) v - {-# INLINE (./.) #-} ; (./.) = binopDynUV (./.) --- {-# INLINE (./.=) #-} ; (./.=) = binopDynUVM (./.) ---------------------------------------- -- container -instance (Monoid r, ValidLogic r, Prim r, IsScalar r) => IxContainer (UVector (n::Symbol) r) where +instance (Monoid r, Eq r, Prim r, ValidScalar r) => IxContainer (UVector (n::Symbol) r) where {-# INLINE (!) #-} - (!) (UVector_Dynamic arr off n) i = indexByteArray arr (off+i) + (!) (UVector_Dynamic arr off _) i = indexByteArray arr (off+i) {-# INLINABLE toIxList #-} toIxList (UVector_Dynamic arr off n) = P.zip [0..] $ go (n-1) [] @@ -394,10 +291,7 @@ instance (Monoid r, ValidLogic r, Prim r, IsScalar r) => IxContainer (UVector (n go (-1) xs = xs go i xs = go (i-1) (indexByteArray arr (off+i) : xs) --- imap f v = unsafeToModule $ imap f $ values v - - -instance (FreeModule r, ValidUVector n r, ValidLogic r, IsScalar r) => FiniteModule (UVector (n::Symbol) r) where +instance (FreeModule r, ValidUVector n r, Eq r, ValidScalar r) => FiniteModule (UVector (n::Symbol) r) where {-# INLINE dim #-} dim (UVector_Dynamic _ _ n) = n @@ -412,21 +306,21 @@ instance (FreeModule r, ValidUVector n r, ValidLogic r, IsScalar r) => FiniteMod where n = length xs - go marr [] (-1) = return () - go marr (x:xs) i = do + go _ [] (-1) = return () + go marr (x:xs') i = do writeByteArray marr i x - go marr xs (i-1) + go marr xs' (i-1) ---------------------------------------- -- comparison -isConst :: (Prim r, Eq_ r, ValidLogic r) => UVector (n::Symbol) r -> r -> Logic r +isConst :: (Prim r, Eq r) => UVector (n::Symbol) r -> r -> Logic r isConst (UVector_Dynamic arr1 off1 n1) c = go (off1+n1-1) where go (-1) = true go i = indexByteArray arr1 i==c && go (i-1) -instance (Eq r, Monoid r, Prim r) => Eq_ (UVector (n::Symbol) r) where +instance (Eq r, Monoid r, Prim r) => Eq (UVector (n::Symbol) r) where {-# INLINE (==) #-} v1@(UVector_Dynamic arr1 off1 n1)==v2@(UVector_Dynamic arr2 off2 n2) = if | isZero n1 && isZero n2 -> true @@ -435,35 +329,10 @@ instance (Eq r, Monoid r, Prim r) => Eq_ (UVector (n::Symbol) r) where | otherwise -> go (n1-1) where go (-1) = true - go i = v1==v2 && go (i-1) + go i = v1'==v2' && go (i-1) where - v1 = indexByteArray arr1 (off1+i) :: r - v2 = indexByteArray arr2 (off2+i) :: r - -{- - - -{-# INLINE innerp #-} --- innerp :: UVector 200 Float -> UVector 200 Float -> Float -innerp v1 v2 = go 0 (n-1) - - where - n = 200 --- n = nat2int (Proxy::Proxy n) - - go !tot !i = if i<4 - then goEach tot i - else - go (tot+(v1!(i ) * v2!(i )) - +(v1!(i-1) * v2!(i-1)) - +(v1!(i-2) * v2!(i-2)) - +(v1!(i-3) * v2!(i-3)) - ) (i-4) - - goEach !tot !i = if i<0 - then tot - else goEach (tot+(v1!i - v2!i) * (v1!i - v2!i)) (i-1) --} + v1' = indexByteArray arr1 (off1+i) :: r + v2' = indexByteArray arr2 (off2+i) :: r ---------------------------------------- -- distances @@ -472,16 +341,16 @@ instance ( Prim r , ExpField r , Normed r - , Ord_ r + , Ord r , Logic r~Bool - , IsScalar r + , ValidScalar r , VectorSpace r ) => Metric (UVector (n::Symbol) r) where {-# INLINE[2] distance #-} - distance v1@(UVector_Dynamic arr1 off1 n1) v2@(UVector_Dynamic arr2 off2 n2) - = {-# SCC distance_UVector #-} if + distance v1@(UVector_Dynamic _ _ n1) v2@(UVector_Dynamic _ _ n2) + = if | isZero n1 -> size v2 | isZero n2 -> size v1 | otherwise -> sqrt $ go 0 (n1-1) @@ -500,8 +369,8 @@ instance else goEach (tot + (v1!i-v2!i).*.(v1!i-v2!i)) (i-1) {-# INLINE[2] distanceUB #-} - distanceUB v1@(UVector_Dynamic arr1 off1 n1) v2@(UVector_Dynamic arr2 off2 n2) ub - = {-# SCC distanceUB_UVector #-} if + distanceUB v1@(UVector_Dynamic _ _ n1) v2@(UVector_Dynamic _ _ n2) ub + = if | isZero n1 -> size v2 | isZero n2 -> size v1 | otherwise -> sqrt $ go 0 (n1-1) @@ -523,9 +392,9 @@ instance then tot else goEach (tot + (v1!i-v2!i).*.(v1!i-v2!i)) (i-1) -instance (VectorSpace r, Prim r, IsScalar r, ExpField r) => Normed (UVector (n::Symbol) r) where +instance (VectorSpace r, Prim r, ValidScalar r, ExpField r) => Normed (UVector (n::Symbol) r) where {-# INLINE size #-} - size v@(UVector_Dynamic arr off n) = if isZero n + size v@(UVector_Dynamic _ off n) = if isZero n then 0 else sqrt $ go 0 (off+n-1) where @@ -544,15 +413,28 @@ instance (VectorSpace r, Prim r, IsScalar r, ExpField r) => Normed (UVector (n:: instance ( VectorSpace r , ValidUVector n r - , IsScalar r + , ValidScalar r , ExpField r - , Real r ) => Banach (UVector (n::Symbol) r) +-- | Construct an "UMatrix" +unsafeMkUMatrix :: + ( VectorSpace (UVector m r) + , VectorSpace (UVector n r) + , ToFromVector (UVector m r) + , ToFromVector (UVector n r) + , MatrixField r + , P.Num (HM.Vector r) + ) => Int -> Int -> [r] -> UMatrix r m n +unsafeMkUMatrix m n rs = Mat_ $ (m HM.>< n) rs + +-- | A slightly more convenient type for linear functions between "UVector"s +type UMatrix r m n = UVector m r +> UVector n r + instance ( VectorSpace r , ValidUVector n r - , IsScalar r + , ValidScalar r , ExpField r , Real r , OrdField r @@ -561,6 +443,13 @@ instance ) => Hilbert (UVector (n::Symbol) r) where + type Square (UVector (n::Symbol) r) = UVector n r +> UVector n r + + v1>) #-} v1@(UVector_Dynamic _ _ n)<>v2@(UVector_Dynamic _ _ _) = if isZero n then 0 @@ -580,8 +469,8 @@ instance else goEach (tot+(v1!i * v2!i)) (i-1) instance MatrixField r => ToFromVector (UVector (n::Symbol) r) where - toVector (UVector_Dynamic fp off n) = undefined - fromVector v = UVector_Dynamic fp off n + toVector (UVector_Dynamic _ _ _) = undefined + fromVector _ = UVector_Dynamic fp off n where (fp,off,n) = undefined -- VS.unsafeToForeignPtr v @@ -589,33 +478,6 @@ instance MatrixField r => Normed (UVector m r +> UVector n r) where size (Id_ r) = r size (Mat_ m) = HM.det m --- | A slightly more convenient type for linear functions between "UVector"s -type UMatrix r m n = UVector m r +> UVector n r - --- | Construct an "UMatrix" -unsafeMkUMatrix :: - ( VectorSpace (UVector m r) - , VectorSpace (UVector n r) - , ToFromVector (UVector m r) - , ToFromVector (UVector n r) - , MatrixField r - , P.Num (HM.Vector r) - ) => Int -> Int -> [r] -> UMatrix r m n -unsafeMkUMatrix m n rs = Mat_ $ (m HM.>< n) rs - -instance - ( FiniteModule (UVector n r) - , VectorSpace (UVector n r) - , MatrixField r - , ToFromVector (UVector n r) - , P.Num (HM.Vector r) - ) => TensorAlgebra (UVector n r) - where - v1> Bool isNull fp = unsafeInlineIO $ withForeignPtr fp $ \p -> (return $ p P.== nullPtr) -- | allocates a ForeignPtr that is filled with n "zero"s -zerofp :: forall n r. (Storable r, Monoid r) => Int -> IO (ForeignPtr r) +zerofp :: forall r. (Storable r, Monoid r) => Int -> IO (ForeignPtr r) zerofp n = do fp <- mallocForeignPtrBytes b withForeignPtr fp $ \p -> go p (n-1) @@ -645,24 +507,16 @@ data family SVector (n::k) r type instance Scalar (SVector n r) = Scalar r type instance Logic (SVector n r) = Logic r --- type instance SVector m a >< b = VectorOuterProduct (SVector m a) b --- type family VectorOuterProduct a b where --- -- VectorOuterProduct (SVector m a) (SVector n a) = SVector m a --- -- VectorOuterProduct (SVector m a) (SVector n a) = Matrix a m n --- VectorOuterProduct (SVector m a) a = SVector m a -- (a>< a = SVector n (r>< b = Tensor_SVector (SVector m a) b -type family Tensor_SVector a b where - Tensor_SVector (SVector n r1) (SVector m r2) = SVector n r1 +> SVector m r2 - Tensor_SVector (SVector n r1) r1 = SVector n r1 -- (r1>< b = Tensor_SVector (SVector m a) b +-- type family Tensor_SVector a b where +-- Tensor_SVector (SVector n r1) (SVector m r2) = SVector n r1 +> SVector m r2 +-- Tensor_SVector (SVector n r1) r1 = SVector n r1 -- (r1> Show (SVector (n::Symbol) r) where +instance (Show r, ValidSVector n r) => Show (SVector (n::Symbol) r) where show (SVector_Dynamic fp off n) = if isNull fp then "zero" else show $ unsafeInlineIO $ go (n-1) [] @@ -681,16 +535,16 @@ instance (Show r, Monoid r, ValidSVector n r) => Show (SVector (n::Symbol) r) wh x <- peekElemOff p (off+i) go (i-1) (x:xs) -instance (Arbitrary r, ValidSVector n r, FreeModule r, IsScalar r) => Arbitrary (SVector (n::Symbol) r) where +instance (Arbitrary r, ValidSVector n r, FreeModule r, ValidScalar r) => Arbitrary (SVector (n::Symbol) r) where arbitrary = frequency [ (1,return zero) , (9,fmap unsafeToModule $ replicateM 27 arbitrary) ] -instance (NFData r, ValidSVector n r) => NFData (SVector (n::Symbol) r) where - rnf (SVector_Dynamic fp off n) = seq fp () +instance NFData (SVector (n::Symbol) r) where + rnf (SVector_Dynamic fp _ _) = seq fp () -instance (FromField r, ValidSVector n r, IsScalar r, FreeModule r) => FromRecord (SVector (n::Symbol) r) where +instance (FromField r, ValidSVector n r, ValidScalar r, FreeModule r) => FromRecord (SVector (n::Symbol) r) where parseRecord r = do rs :: [r] <- parseRecord r return $ unsafeToModule rs @@ -721,8 +575,8 @@ instance (ValidSVector n r) => IsMutable (SVector (n::Symbol) r) where ref2 <- newPrimRef (SVector_Dynamic fp2 0 n) return $ Mutable_SVector ref2 - write (Mutable_SVector ref) (SVector_Dynamic fp2 off2 n2) = do - (SVector_Dynamic fp1 off1 n1) <- readPrimRef ref + write (Mutable_SVector ref) (SVector_Dynamic fp2 _ n2) = do + (SVector_Dynamic fp1 _ n1) <- readPrimRef ref unsafePrimToPrim $ if -- both ptrs null: do nothing | isNull fp1 && isNull fp2 -> return () @@ -748,11 +602,11 @@ instance (ValidSVector n r) => IsMutable (SVector (n::Symbol) r) where -- algebra {-# INLINE binopDyn #-} -binopDyn :: forall a b n m. +binopDyn :: forall a n. ( Storable a , Monoid a ) => (a -> a -> a) -> SVector (n::Symbol) a -> SVector (n::Symbol) a -> SVector (n::Symbol) a -binopDyn f v1@(SVector_Dynamic fp1 off1 n1) v2@(SVector_Dynamic fp2 off2 n2) = if +binopDyn f v1@(SVector_Dynamic fp1 off1 n1) v2@(SVector_Dynamic fp2 off2 _) = if | isNull fp1 && isNull fp2 -> v1 | isNull fp1 -> monopDyn (f zero) v2 | isNull fp2 -> monopDyn (\a -> f a zero) v1 @@ -768,13 +622,13 @@ binopDyn f v1@(SVector_Dynamic fp1 off1 n1) v2@(SVector_Dynamic fp2 off2 n2) = i where go _ _ _ (-1) = return () go p1 p2 p3 i = do - v1 <- peekElemOff p1 i - v2 <- peekElemOff p2 i - pokeElemOff p3 i (f v1 v2) + v1' <- peekElemOff p1 i + v2' <- peekElemOff p2 i + pokeElemOff p3 i (f v1' v2') go p1 p2 p3 (i-1) {-# INLINE monopDyn #-} -monopDyn :: forall a b n m. +monopDyn :: forall a n. ( Storable a ) => (a -> a) -> SVector (n::Symbol) a -> SVector (n::Symbol) a monopDyn f v@(SVector_Dynamic fp1 off1 n) = if isNull fp1 @@ -805,9 +659,9 @@ binopDynM :: forall a b n m. binopDynM f (Mutable_SVector ref) (SVector_Dynamic fp2 off2 n2) = do (SVector_Dynamic fp1 off1 n1) <- readPrimRef ref - let runop fp1 fp2 n = unsafePrimToPrim $ - withForeignPtr fp1 $ \p1 -> - withForeignPtr fp2 $ \p2 -> + let runop fp1' fp2' n = unsafePrimToPrim $ + withForeignPtr fp1' $ \p1 -> + withForeignPtr fp2' $ \p2 -> go (plusPtr p1 off1) (plusPtr p2 off2) (n-1) unsafePrimToPrim $ if @@ -839,7 +693,7 @@ binopDynM f (Mutable_SVector ref) (SVector_Dynamic fp2 off2 n2) = do go p1 p2 (i-1) {-# INLINE monopDynM #-} -monopDynM :: forall a b n m. +monopDynM :: forall a n m. ( PrimMonad m , Storable a ) => (a -> a) -> Mutable m (SVector (n::Symbol) a) -> m () @@ -881,15 +735,15 @@ instance (Group r, ValidSVector n r) => Group (SVector (n::Symbol) r) where instance (Monoid r, Abelian r, ValidSVector n r) => Abelian (SVector (n::Symbol) r) -instance (Module r, ValidSVector n r, IsScalar r) => Module (SVector (n::Symbol) r) where +instance (Module r, ValidSVector n r, ValidScalar r) => Module (SVector (n::Symbol) r) where {-# INLINE (.*) #-} ; (.*) v r = monopDyn (.*r) v {-# INLINE (.*=) #-} ; (.*=) v r = monopDynM (.*r) v -instance (FreeModule r, ValidSVector n r, IsScalar r) => FreeModule (SVector (n::Symbol) r) where +instance (FreeModule r, ValidSVector n r, ValidScalar r) => FreeModule (SVector (n::Symbol) r) where {-# INLINE (.*.) #-} ; (.*.) = binopDyn (.*.) {-# INLINE (.*.=) #-} ; (.*.=) = binopDynM (.*.) -instance (VectorSpace r, ValidSVector n r, IsScalar r) => VectorSpace (SVector (n::Symbol) r) where +instance (VectorSpace r, ValidSVector n r, ValidScalar r) => VectorSpace (SVector (n::Symbol) r) where {-# INLINE (./) #-} ; (./) v r = monopDyn (./r) v {-# INLINE (./=) #-} ; (./=) v r = monopDynM (./r) v @@ -901,15 +755,15 @@ instance (VectorSpace r, ValidSVector n r, IsScalar r) => VectorSpace (SVector ( instance ( Monoid r - , ValidLogic r + , Eq r , ValidSVector n r - , IsScalar r + , ValidScalar r , FreeModule r ) => IxContainer (SVector (n::Symbol) r) where {-# INLINE (!) #-} - (!) (SVector_Dynamic fp off n) i = unsafeInlineIO $ withForeignPtr fp $ \p -> peekElemOff p (off+i) + (!) (SVector_Dynamic fp off _) i = unsafeInlineIO $ withForeignPtr fp $ \p -> peekElemOff p (off+i) {-# INLINABLE toIxList #-} toIxList v = P.zip [0..] $ go (dim v-1) [] @@ -920,9 +774,9 @@ instance {-# INLINABLE imap #-} imap f v = unsafeToModule $ imap f $ values v - type ValidElem (SVector n r) e = (ClassicalLogic e, IsScalar e, FiniteModule e, ValidSVector n e) + type ValidElem (SVector n r) e = (ClassicalLogic e, ValidScalar e, FiniteModule e, ValidSVector n e) -instance (FreeModule r, ValidLogic r, ValidSVector n r, IsScalar r) => FiniteModule (SVector (n::Symbol) r) where +instance (FreeModule r, Eq r, ValidSVector n r, ValidScalar r) => FiniteModule (SVector (n::Symbol) r) where {-# INLINE dim #-} dim (SVector_Dynamic _ _ n) = n @@ -936,15 +790,15 @@ instance (FreeModule r, ValidLogic r, ValidSVector n r, IsScalar r) => FiniteMod where n = length xs - go p [] (-1) = return () - go p (x:xs) i = do + go _ [] (-1) = return () + go p (x:xs') i = do pokeElemOff p i x - go p xs (i-1) + go p xs' (i-1) ---------------------------------------- -- comparison -instance (Eq r, Monoid r, ValidSVector n r) => Eq_ (SVector (n::Symbol) r) where +instance (Eq r, Monoid r, ClassicalLogic r, ValidSVector n r) => Eq (SVector (n::Symbol) r) where {-# INLINE (==) #-} (SVector_Dynamic fp1 off1 n1)==(SVector_Dynamic fp2 off2 n2) = unsafeInlineIO $ if | isNull fp1 && isNull fp2 -> return true @@ -956,7 +810,7 @@ instance (Eq r, Monoid r, ValidSVector n r) => Eq_ (SVector (n::Symbol) r) where outer (plusPtr p1 off1) (plusPtr p2 off2) (n1-1) where checkZero :: Ptr r -> Int -> IO Bool - checkZero p (-1) = return true + checkZero _ (-1) = return true checkZero p i = do x <- peekElemOff p i if isZero x @@ -980,15 +834,15 @@ instance ( ValidSVector n r , ExpField r , Normed r - , Ord_ r + , Ord r , Logic r~Bool - , IsScalar r + , ValidScalar r , VectorSpace r ) => Metric (SVector (n::Symbol) r) where {-# INLINE[2] distance #-} - distance v1@(SVector_Dynamic fp1 _ n) v2@(SVector_Dynamic fp2 _ _) = {-# SCC distance_SVector #-} if + distance v1@(SVector_Dynamic fp1 _ n) v2@(SVector_Dynamic fp2 _ _) = if | isNull fp1 -> size v2 | isNull fp2 -> size v1 | otherwise -> sqrt $ go 0 (n-1) @@ -1006,7 +860,7 @@ instance else goEach (tot+(v1!i - v2!i) * (v1!i - v2!i)) (i-1) {-# INLINE[2] distanceUB #-} - distanceUB v1@(SVector_Dynamic fp1 _ n) v2@(SVector_Dynamic fp2 _ _) ub = {-# SCC distanceUB_SVector #-}if + distanceUB v1@(SVector_Dynamic fp1 _ n) v2@(SVector_Dynamic fp2 _ _) ub = if | isNull fp1 -> size v2 | isNull fp2 -> size v1 | otherwise -> sqrt $ go 0 (n-1) @@ -1027,7 +881,7 @@ instance then tot else goEach (tot+(v1!i - v2!i) * (v1!i - v2!i)) (i-1) -instance (VectorSpace r, ValidSVector n r, IsScalar r, ExpField r) => Normed (SVector (n::Symbol) r) where +instance (VectorSpace r, ValidSVector n r, ValidScalar r, ExpField r) => Normed (SVector (n::Symbol) r) where {-# INLINE size #-} size v@(SVector_Dynamic fp _ n) = if isNull fp then 0 @@ -1048,15 +902,28 @@ instance (VectorSpace r, ValidSVector n r, IsScalar r, ExpField r) => Normed (SV instance ( VectorSpace r , ValidSVector n r - , IsScalar r + , ValidScalar r , ExpField r - , Real r ) => Banach (SVector (n::Symbol) r) +-- | A slightly more convenient type for linear functions between "SVector"s +type SMatrix r m n = SVector m r +> SVector n r + +-- | Construct an "SMatrix" +unsafeMkSMatrix :: + ( VectorSpace (SVector m r) + , VectorSpace (SVector n r) + , ToFromVector (SVector m r) + , ToFromVector (SVector n r) + , MatrixField r + , P.Num (HM.Vector r) + ) => Int -> Int -> [r] -> SMatrix r m n +unsafeMkSMatrix m n rs = Mat_ $ (m HM.>< n) rs + instance ( VectorSpace r , ValidSVector n r - , IsScalar r + , ValidScalar r , ExpField r , Real r , OrdField r @@ -1065,6 +932,13 @@ instance ) => Hilbert (SVector (n::Symbol) r) where + type Square (SVector (n::Symbol) r) = SVector n r +> SVector n r + + v1>) #-} v1@(SVector_Dynamic fp1 _ _)<>v2@(SVector_Dynamic fp2 _ n) = if isNull fp1 || isNull fp2 then 0 @@ -1105,7 +979,7 @@ instance , Arbitrary r , ValidSVector n r , FreeModule r - , IsScalar r + , ValidScalar r ) => Arbitrary (SVector (n::Nat) r) where arbitrary = do @@ -1114,14 +988,12 @@ instance where n = nat2int (Proxy::Proxy n) -instance (NFData r, ValidSVector n r) => NFData (SVector (n::Nat) r) where +instance ValidSVector n r => NFData (SVector (n::Nat) r) where rnf (SVector_Nat fp) = seq fp () static2dynamic :: forall n m r. KnownNat n => SVector (n::Nat) r -> SVector (m::Symbol) r static2dynamic (SVector_Nat fp) = SVector_Dynamic fp 0 $ nat2int (Proxy::Proxy n) --------------------- - newtype instance Mutable m (SVector (n::Nat) r) = Mutable_SVector_Nat (ForeignPtr r) instance (KnownNat n, ValidSVector n r) => IsMutable (SVector (n::Nat) r) where @@ -1153,11 +1025,11 @@ instance (KnownNat n, ValidSVector n r) => IsMutable (SVector (n::Nat) r) where -- algebra {-# INLINE binopStatic #-} -binopStatic :: forall a b n m. +binopStatic :: forall a n. ( Storable a , KnownNat n ) => (a -> a -> a) -> SVector n a -> SVector n a -> SVector n a -binopStatic f v1@(SVector_Nat fp1) v2@(SVector_Nat fp2) = unsafeInlineIO $ do +binopStatic f (SVector_Nat fp1) (SVector_Nat fp2) = unsafeInlineIO $ do fp3 <- mallocForeignPtrBytes b withForeignPtr fp1 $ \p1 -> withForeignPtr fp2 $ \p2 -> @@ -1172,29 +1044,16 @@ binopStatic f v1@(SVector_Nat fp1) v2@(SVector_Nat fp2) = unsafeInlineIO $ do go _ _ _ (-1) = return () go p1 p2 p3 i = do x0 <- peekElemOff p1 i --- x1 <- peekElemOff p1 (i-1) --- x2 <- peekElemOff p1 (i-2) --- x3 <- peekElemOff p1 (i-3) - y0 <- peekElemOff p2 i --- y1 <- peekElemOff p2 (i-1) --- y2 <- peekElemOff p2 (i-2) --- y3 <- peekElemOff p2 (i-3) - pokeElemOff p3 i (f x0 y0) --- pokeElemOff p3 (i-1) (f x1 y1) --- pokeElemOff p3 (i-2) (f x2 y2) --- pokeElemOff p3 (i-3) (f x3 y3) - go p1 p2 p3 (i-1) --- go p1 p2 p3 (i-4) {-# INLINE monopStatic #-} -monopStatic :: forall a b n m. +monopStatic :: forall a n. ( Storable a , KnownNat n ) => (a -> a) -> SVector n a -> SVector n a -monopStatic f v@(SVector_Nat fp1) = unsafeInlineIO $ do +monopStatic f (SVector_Nat fp1) = unsafeInlineIO $ do fp2 <- mallocForeignPtrBytes b withForeignPtr fp1 $ \p1 -> withForeignPtr fp2 $ \p2 -> @@ -1234,7 +1093,7 @@ binopStaticM f (Mutable_SVector_Nat fp1) (SVector_Nat fp2) = unsafePrimToPrim $ go p1 p2 (i-1) {-# INLINE monopStaticM #-} -monopStaticM :: forall a b n m. +monopStaticM :: forall a n m. ( PrimMonad m , Storable a , KnownNat n @@ -1252,8 +1111,6 @@ monopStaticM f (Mutable_SVector_Nat fp1) = unsafePrimToPrim $ pokeElemOff p1 i (f v1) go p1 (i-1) -------------------- - instance (KnownNat n, Semigroup r, ValidSVector n r) => Semigroup (SVector (n::Nat) r) where {-# INLINE (+) #-} ; (+) = binopStatic (+) {-# INLINE (+=) #-} ; (+=) = binopStaticM (+) @@ -1280,15 +1137,15 @@ instance (KnownNat n, Group r, ValidSVector n r) => Group (SVector (n::Nat) r) w instance (KnownNat n, Abelian r, ValidSVector n r) => Abelian (SVector (n::Nat) r) -instance (KnownNat n, Module r, ValidSVector n r, IsScalar r) => Module (SVector (n::Nat) r) where +instance (KnownNat n, Module r, ValidSVector n r, ValidScalar r) => Module (SVector (n::Nat) r) where {-# INLINE (.*) #-} ; (.*) v r = monopStatic (.*r) v {-# INLINE (.*=) #-} ; (.*=) v r = monopStaticM (.*r) v -instance (KnownNat n, FreeModule r, ValidSVector n r, IsScalar r) => FreeModule (SVector (n::Nat) r) where +instance (KnownNat n, FreeModule r, ValidSVector n r, ValidScalar r) => FreeModule (SVector (n::Nat) r) where {-# INLINE (.*.) #-} ; (.*.) = binopStatic (.*.) {-# INLINE (.*.=) #-} ; (.*.=) = binopStaticM (.*.) -instance (KnownNat n, VectorSpace r, ValidSVector n r, IsScalar r) => VectorSpace (SVector (n::Nat) r) where +instance (KnownNat n, VectorSpace r, ValidSVector n r, ValidScalar r) => VectorSpace (SVector (n::Nat) r) where {-# INLINE (./) #-} ; (./) v r = monopStatic (./r) v {-# INLINE (./=) #-} ; (./=) v r = monopStaticM (./r) v @@ -1301,9 +1158,9 @@ instance (KnownNat n, VectorSpace r, ValidSVector n r, IsScalar r) => VectorSpac instance ( KnownNat n , Monoid r - , ValidLogic r + , Eq r , ValidSVector n r - , IsScalar r + , ValidScalar r , FreeModule r ) => IxContainer (SVector (n::Nat) r) where @@ -1320,19 +1177,19 @@ instance {-# INLINABLE imap #-} imap f v = unsafeToModule $ imap f $ values v - type ValidElem (SVector n r) e = (ClassicalLogic e, IsScalar e, FiniteModule e, ValidSVector n e) + type ValidElem (SVector n r) e = (ClassicalLogic e, ValidScalar e, FiniteModule e, ValidSVector n e) instance ( KnownNat n , FreeModule r - , ValidLogic r + , Eq r , ValidSVector n r - , IsScalar r + , ValidScalar r ) => FiniteModule (SVector (n::Nat) r) where {-# INLINE dim #-} - dim v = nat2int (Proxy::Proxy n) + dim _ = nat2int (Proxy::Proxy n) {-# INLINABLE unsafeToModule #-} unsafeToModule xs = if n /= length xs @@ -1345,16 +1202,16 @@ instance where n = nat2int (Proxy::Proxy n) - go p [] (-1) = return () - go p (x:xs) i = do + go _ [] (-1) = return () + go p (x:xs') i = do pokeElemOff p i x - go p xs (i-1) + go p xs' (i-1) ---------------------------------------- -- comparison -instance (KnownNat n, Eq_ r, ValidLogic r, ValidSVector n r) => Eq_ (SVector (n::Nat) r) where +instance (KnownNat n, Eq r, Eq r, ValidSVector n r) => Eq (SVector (n::Nat) r) where {-# INLINE (==) #-} (SVector_Nat fp1)==(SVector_Nat fp2) = unsafeInlineIO $ withForeignPtr fp1 $ \p1 -> @@ -1363,6 +1220,7 @@ instance (KnownNat n, Eq_ r, ValidLogic r, ValidSVector n r) => Eq_ (SVector (n: where n = nat2int (Proxy::Proxy n) + outer :: Ptr r -> Ptr r -> Int -> IO (Logic r) outer p1 p2 = go where go (-1) = return true @@ -1380,9 +1238,9 @@ instance , ValidSVector n r , ExpField r , Normed r - , Ord_ r + , Ord r , Logic r~Bool - , IsScalar r + , ValidScalar r , VectorSpace r , ValidSVector "dyn" r ) => Metric (SVector (n::Nat) r) @@ -1391,24 +1249,9 @@ instance -- For some reason, using the dynamic vector is a little faster than a straight implementation {-# INLINE[2] distance #-} distance v1 v2 = distance (static2dynamic v1) (static2dynamic v2 :: SVector "dyn" r) --- distance v1 v2 = sqrt $ go 0 (n-1) --- where --- n = nat2int (Proxy::Proxy n) --- --- go !tot !i = if i<4 --- then goEach tot i --- else go (tot+(v1!(i ) - v2!(i )) .*. (v1!(i ) - v2!(i )) --- +(v1!(i-1) - v2!(i-1)) .*. (v1!(i-1) - v2!(i-1)) --- +(v1!(i-2) - v2!(i-2)) .*. (v1!(i-2) - v2!(i-2)) --- +(v1!(i-3) - v2!(i-3)) .*. (v1!(i-3) - v2!(i-3)) --- ) (i-4) --- --- goEach !tot !i = if i<0 --- then tot --- else goEach (tot+(v1!i - v2!i) * (v1!i - v2!i)) (i-1) {-# INLINE[2] distanceUB #-} - distanceUB v1 v2 ub = {-# SCC distanceUB_SVector #-} sqrt $ go 0 (n-1) + distanceUB v1 v2 ub = sqrt $ go 0 (n-1) where n = nat2int (Proxy::Proxy n) ub2 = ub*ub @@ -1431,7 +1274,7 @@ instance ( KnownNat n , VectorSpace r , ValidSVector n r - , IsScalar r + , ValidScalar r , ExpField r ) => Normed (SVector (n::Nat) r) where @@ -1456,18 +1299,15 @@ instance ( KnownNat n , VectorSpace r , ValidSVector n r - , IsScalar r + , ValidScalar r , ExpField r - , Real r - , ValidSVector n r , ValidSVector "dyn" r ) => Banach (SVector (n::Nat) r) instance ( KnownNat n , VectorSpace r - , ValidSVector n r - , IsScalar r + , ValidScalar r , ExpField r , Real r , OrdField r @@ -1478,6 +1318,13 @@ instance ) => Hilbert (SVector (n::Nat) r) where + type Square (SVector (n::Nat) r) = SVector n r +> SVector n r + + v1>) #-} v1<>v2 = go 0 (n-1) where @@ -1496,164 +1343,16 @@ instance then tot else goEach (tot+(v1!i * v2!i)) (i-1) - +-------------------------------------------------------------------------------- type MatrixField r = - ( IsScalar r + ( ValidScalar r , VectorSpace r , Field r , HM.Field r , HM.Container HM.Vector r , HM.Product r - ) - -{- -data Matrix r (m::k1) (n::k2) where - Zero :: Matrix r m n - Id :: {-#UNPACK#-}!r -> Matrix r m m - Diag :: {-#UNPACK#-}!(SVector m r) -> Matrix r m m - Mat :: {-#UNPACK#-}!(HM.Matrix r) -> Matrix r m n - -type instance Scalar (Matrix r m n) = Scalar r -type instance (Matrix r m n)> Int -> Int -> [r] -> Matrix r m n -mkMatrix m n rs = Mat $ (m HM.>< n) rs - --------------------------------------------------------------------------------- --- class instances - -deriving instance - ( MatrixField r - , Show (SVector n r) - , Show r - ) => Show (Matrix r m n) - ----------------------------------------- --- misc - -instance (Storable r, NFData r) => NFData (Matrix r m n) where - rnf (Id r) = () - rnf (Mat m) = rnf m - ----------------------------------------- --- category - -instance MatrixField r => Category (Matrix r) where - type ValidCategory (Matrix r) a = () - - id = Id 1 - - (Id r1).(Id r2) = Id (r1*r2) - (Id r ).(Mat m ) = Mat $ HM.scale r m - (Mat m ).(Id r ) = Mat $ HM.scale r m - (Mat m1).(Mat m2) = Mat $ m2 HM.<> m1 - -instance MatrixField r => Matrix r (m::Symbol) (n::Symbol) <: (SVector m r -> SVector n r) where - embedType_ = Embed0 $ embedType go - where - go :: Matrix r m n -> SVector m r -> SVector n r - go (Id r) (SVector_Dynamic fp off n) = (SVector_Dynamic fp off n).*r - go (Mat m) (SVector_Dynamic fp off n) = SVector_Dynamic fp' off' n' - where - (fp',off',n') = VS.unsafeToForeignPtr $ m HM.<> VS.unsafeFromForeignPtr fp off n - -type family ToHask (cat :: ka -> kb -> *) (a :: ka) (b :: kb) :: * where - ToHask (Matrix r) a b = SVector r a -> SVector r b - -infixr 0 $$$ --- ($$$) :: (Matrix r a b <: (SVector a r -> SVector b r)) => Matrix r a b -> SVector a r -> SVector b r -($$$) :: (Matrix r a b <: ToHask (Matrix r) a b) => Matrix r a b -> ToHask (Matrix r) a b -($$$) = embedType - -instance MatrixField r => Dagger (Matrix r) where - dagger (Id r) = Id r - dagger (Mat m) = Mat $ HM.trans m - ----------------------------------------- --- size - -instance MatrixField r => Normed (Matrix r m n) where - size (Id r) = r - size (Mat m) = HM.det m - ----------------------------------------- --- algebra - -instance MatrixField r => Semigroup (Matrix r m n) where - (Id r1)+(Id r2) = Id (r1+r2) - (Id r )+(Mat m ) = Mat $ HM.scale r (HM.ident (HM.rows m)) `HM.add` m - (Mat m )+(Id r ) = Mat $ m `HM.add` HM.scale r (HM.ident (HM.rows m)) - (Mat m1)+(Mat m2) = Mat $ m1 `HM.add` m2 - -instance MatrixField r => Monoid (Matrix r m n) where - zero = Zero - -instance MatrixField r => Cancellative (Matrix r m n) where - (Id r1)-(Id r2) = Id (r1-r2) - (Id r )-(Mat m ) = Mat $ HM.scale r (HM.ident (HM.rows m)) `HM.sub` m - (Mat m )-(Id r ) = Mat $ m `HM.sub` HM.scale r (HM.ident (HM.rows m)) - (Mat m1)-(Mat m2) = Mat $ m1 `HM.sub` m2 - -instance MatrixField r => Group (Matrix r m n) where - negate (Id r) = Id $ negate r - negate (Mat m) = Mat $ HM.scale (-1) m - -instance MatrixField r => Abelian (Matrix r m n) - -------------------- --- modules - -instance MatrixField r => Module (Matrix r m n) where - (Id r1) .* r2 = Id $ r1*r2 - (Mat m) .* r2 = Mat $ HM.scale r2 m - -instance MatrixField r => FreeModule (Matrix r m n) where - (Id r1) .*. (Id r2) = Id $ r1*r2 - (Id r ) .*. (Mat m ) = Mat $ HM.scale r (HM.ident (HM.rows m)) `HM.mul` m - (Mat m ) .*. (Id r ) = Mat $ m `HM.mul` HM.scale r (HM.ident (HM.rows m)) - (Mat m1) .*. (Mat m2) = Mat $ m1 `HM.mul` m2 - -instance MatrixField r => VectorSpace (Matrix r m n) where - (Id r1) ./. (Id r2) = Id $ r1/r2 - (Id r ) ./. (Mat m ) = Mat $ HM.scale r (HM.ident (HM.rows m)) `HM.divide` m - (Mat m ) ./. (Id r ) = Mat $ m `HM.divide` HM.scale r (HM.ident (HM.rows m)) - (Mat m1) ./. (Mat m2) = Mat $ m1 `HM.divide` m2 - -------------------- --- rings --- --- NOTE: matrices are only a ring when their dimensions are equal - -instance MatrixField r => Rg (Matrix r m m) where - (*) = (>>>) - -instance MatrixField r => Rig (Matrix r m m) where - one = id - -instance MatrixField r => Ring (Matrix r m m) where - fromInteger i = Id $ fromInteger i - -instance MatrixField r => Field (Matrix r m m) where - fromRational r = Id $ fromRational r - - reciprocal (Id r ) = Id $ reciprocal r - reciprocal (Mat m) = Mat $ HM.inv m - ----------------------------------------- - -instance - ( FiniteModule (SVector n r) - , VectorSpace (SVector n r) - , MatrixField r - ) => TensorAlgebra (SVector n r) - where - v1> VS.Vector (Scalar a) @@ -1675,9 +1374,7 @@ instance (KnownNat n, MatrixField r) => ToFromVector (SVector (n::Nat) r) where n = nat2int (Proxy::Proxy n) fromVector v = SVector_Nat fp where - (fp,off,n) = VS.unsafeToForeignPtr v - ---------- + (fp,_,_) = VS.unsafeToForeignPtr v apMat_ :: ( Scalar a~Scalar b @@ -1688,8 +1385,6 @@ apMat_ :: ) => HM.Matrix (Scalar a) -> a -> b apMat_ m a = fromVector $ HM.flatten $ m HM.<> HM.asColumn (toVector a) ---------------------------------------- - data a +> b where Zero :: ( Module a @@ -1698,7 +1393,7 @@ data a +> b where Id_ :: ( VectorSpace b - ) => {-#UNPACK#-}!(Scalar b) -> b +> b + ) => !(Scalar b) -> b +> b Mat_ :: ( MatrixField (Scalar b) @@ -1714,28 +1409,12 @@ data a +> b where type instance Scalar (a +> b) = Scalar b type instance Logic (a +> b) = Bool -type instance (a +> b) >< c = Tensor_Linear (a +> b) c -type family Tensor_Linear a b where --- Tensor_SVector (SVector n r1) (SVector m r2) = SVector n r1 +> SVector m r2 --- Tensor_Linear (a +> b) (c +> d) = (a +> b) +> (c +> d) - Tensor_Linear (a +> b) c = a +> b +-- type instance (a +> b) >< c = Tensor_Linear (a +> b) c +-- type family Tensor_Linear a b where +-- Tensor_Linear (a +> b) c = a +> b mkMutable [t| forall a b. a +> b |] --- | A slightly more convenient type for linear functions between "SVector"s -type SMatrix r m n = SVector m r +> SVector n r - --- | Construct an "SMatrix" -unsafeMkSMatrix :: - ( VectorSpace (SVector m r) - , VectorSpace (SVector n r) - , ToFromVector (SVector m r) - , ToFromVector (SVector n r) - , MatrixField r - , P.Num (HM.Vector r) - ) => Int -> Int -> [r] -> SMatrix r m n -unsafeMkSMatrix m n rs = Mat_ $ (m HM.>< n) rs - -------------------------------------------------------------------------------- -- instances @@ -1753,11 +1432,11 @@ instance Category (+>) where Zero . (Id_ _ ) = Zero Zero . (Mat_ _ ) = Zero - (Id_ r ) . Zero = Zero + (Id_ _ ) . Zero = Zero (Id_ r1) . (Id_ r2) = Id_ (r1*r2) (Id_ r ) . (Mat_ m ) = Mat_ $ HM.scale r m - (Mat_ m1) . Zero = Zero + (Mat_ _) . Zero = Zero (Mat_ m ) . (Id_ r ) = Mat_ $ HM.scale r m (Mat_ m1) . (Mat_ m2) = Mat_ $ m1 HM.<> m2 @@ -1778,6 +1457,7 @@ instance Dagger (+>) where trans (Mat_ m) = Mat_ $ HM.tr' m instance Groupoid (+>) where + inverse Zero = undefined inverse (Id_ r) = Id_ $ reciprocal r inverse (Mat_ m) = Mat_ $ HM.inv m @@ -1786,6 +1466,7 @@ instance Groupoid (+>) where -- FIXME: what's the norm of a tensor? instance MatrixField r => Normed (SVector m r +> SVector n r) where + size Zero = zero size (Id_ r) = r size (Mat_ m) = HM.det m @@ -1836,6 +1517,8 @@ instance (VectorSpace a, VectorSpace b) => FreeModule (a +> b) where instance (VectorSpace a, VectorSpace b) => VectorSpace (a +> b) where Zero ./. _ = Zero + (Id_ _) ./. Zero = undefined + (Mat_ _) ./. Zero = undefined (Id_ r1) ./. (Id_ r2) = Id_ $ r1/r2 (Id_ r ) ./. (Mat_ m ) = Mat_ $ (HM.scale r (HM.ident (HM.rows m))) P./ m (Mat_ m ) ./. (Id_ r ) = Mat_ $ m P./ HM.scale r (HM.ident (HM.rows m)) @@ -1858,18 +1541,7 @@ instance VectorSpace a => Ring (a +> a) where instance VectorSpace a => Field (a +> a) where fromRational r = Id_ $ fromRational r + reciprocal Zero = undefined reciprocal (Id_ r ) = Id_ $ reciprocal r reciprocal (Mat_ m) = Mat_ $ HM.inv m -instance - ( FiniteModule (SVector n r) - , VectorSpace (SVector n r) - , MatrixField r - , ToFromVector (SVector n r) - , P.Num (HM.Vector r) - ) => TensorAlgebra (SVector n r) - where - v1> Ptr Float -> Int -> IO Float foreign import ccall unsafe "distanceUB_l2_m128" distanceUB_l2_m128 :: Ptr Float -> Ptr Float -> Int -> Float -> IO Float --- foreign import ccall unsafe "distance_l2_m128" distance_l2_m128_c --- :: Ptr Float -> Ptr Float -> CInt -> IO Float --- --- distance_l2_m128 :: Ptr Float -> Ptr Float -> Int -> IO Float --- distance_l2_m128 p1 p2 i = distance_l2_m128_c p1 p2 (P.fromIntegral i) --- --- foreign import ccall unsafe "distanceUB_l2_m128" distanceUB_l2_m128_c --- :: Ptr Float -> Ptr Float -> CInt -> Float -> IO Float --- --- distanceUB_l2_m128 :: Ptr Float -> Ptr Float -> Int -> Float -> IO Float --- distanceUB_l2_m128 p1 p2 i = distanceUB_l2_m128_c p1 p2 (P.fromIntegral i) - ------------------------------------------ - {-# INLINE distance_l2_m128_UVector_Dynamic #-} distance_l2_m128_UVector_Dynamic :: UVector (s::Symbol) Float -> UVector (s::Symbol) Float -> Float distance_l2_m128_UVector_Dynamic (UVector_Dynamic arr1 off1 n) (UVector_Dynamic arr2 off2 _) - = {-# SCC distance_l2_m128_UVector_Dynamic #-} unsafeInlineIO $ distance_l2_m128 p1 p2 n + = unsafeInlineIO $ distance_l2_m128 p1 p2 n where p1 = plusPtr (unsafeCoerce $ byteArrayContents arr1) (off1*sizeOfFloat) p2 = plusPtr (unsafeCoerce $ byteArrayContents arr2) (off2*sizeOfFloat) @@ -79,17 +56,15 @@ distance_l2_m128_UVector_Dynamic (UVector_Dynamic arr1 off1 n) (UVector_Dynamic {-# INLINE distanceUB_l2_m128_UVector_Dynamic #-} distanceUB_l2_m128_UVector_Dynamic :: UVector (s::Symbol) Float -> UVector (s::Symbol) Float -> Float -> Float distanceUB_l2_m128_UVector_Dynamic (UVector_Dynamic arr1 off1 n) (UVector_Dynamic arr2 off2 _) ub - = {-# SCC distanceUB_l2_m128_UVector_Dynamic #-}unsafeInlineIO $ distanceUB_l2_m128 p1 p2 n ub + = unsafeInlineIO $ distanceUB_l2_m128 p1 p2 n ub where p1 = plusPtr (unsafeCoerce $ byteArrayContents arr1) (off1*sizeOfFloat) p2 = plusPtr (unsafeCoerce $ byteArrayContents arr2) (off2*sizeOfFloat) ------------------------------------------ - {-# INLINE distance_l2_m128_SVector_Dynamic #-} distance_l2_m128_SVector_Dynamic :: SVector (s::Symbol) Float -> SVector (s::Symbol) Float -> Float distance_l2_m128_SVector_Dynamic (SVector_Dynamic fp1 off1 n) (SVector_Dynamic fp2 off2 _) - = {-# SCC distance_l2_m128_SVector_Dynamic #-}unsafeInlineIO $ + = unsafeInlineIO $ withForeignPtr fp1 $ \p1 -> withForeignPtr fp2 $ \p2 -> distance_l2_m128 (plusPtr p1 $ off1*sizeOfFloat) (plusPtr p2 $ off2*sizeOfFloat) n @@ -97,7 +72,7 @@ distance_l2_m128_SVector_Dynamic (SVector_Dynamic fp1 off1 n) (SVector_Dynamic f {-# INLINE distanceUB_l2_m128_SVector_Dynamic #-} distanceUB_l2_m128_SVector_Dynamic :: SVector (s::Symbol) Float -> SVector (s::Symbol) Float -> Float -> Float distanceUB_l2_m128_SVector_Dynamic (SVector_Dynamic fp1 off1 n) (SVector_Dynamic fp2 off2 _) ub - = {-# SCC distanceUB_l2_m128_SVector_Dynamic #-}unsafeInlineIO $ + = unsafeInlineIO $ withForeignPtr fp1 $ \p1 -> withForeignPtr fp2 $ \p2 -> distanceUB_l2_m128 (plusPtr p1 $ off1*sizeOfFloat) (plusPtr p2 $ off2*sizeOfFloat) n ub diff --git a/src/SubHask/Category.hs b/src/SubHask/Category.hs index 215c5a6..293ac03 100644 --- a/src/SubHask/Category.hs +++ b/src/SubHask/Category.hs @@ -1,4 +1,6 @@ {-# LANGUAGE NoAutoDeriveTypeable #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} + -- | SubHask supports two ways to encode categories in Haskell. -- -- **Method 1** @@ -49,6 +51,7 @@ module SubHask.Category Category (..) , (<<<) , (>>>) + , Cat -- * Hask , Hask @@ -62,15 +65,15 @@ module SubHask.Category , snd -- * Special types of categories - , Concrete (..) + , Concrete , Monoidal (..) --- , (><) + -- FIXME: conflict with SubHask.Algebra + -- , (><) , Braided (..) - , Symmetric (..) + , Symmetric , Cartesian (..) , const , const2 --- , duplicate , Closed (..) , Groupoid (..) @@ -83,14 +86,10 @@ module SubHask.Category , ProofOf ) where -import GHC.Prim import SubHask.Internal.Prelude import SubHask.SubType import qualified Prelude as P --- required for compilation because these are defined properly in the Algebra.hs file -import GHC.Exts (fromListN,fromString) - ------------------------------------------------------------------------------- -- | This 'Category' class modifies the one in the Haskell standard to include the 'ValidCategory' type constraint. @@ -241,7 +240,7 @@ withCategory _ f = embedType2 f -- | FIXME: This would be a useful function to have, but I'm not sure how to implement it yet! embed2 :: (subcat <: cat) => subcat a (subcat a b) -> cat a (cat a b) -embed2 f = undefined +embed2 _ = undefined ------------------------------------------------------------------------------- @@ -255,16 +254,16 @@ embed2 f = undefined class ( Category cat , ValidCategory cat (TUnit cat) - ) => Monoidal cat + ) => Monoidal (cat :: * -> * -> *) where - type Tensor cat :: k -> k -> k + type Tensor cat :: * -> * -> * tensor :: ( ValidCategory cat a , ValidCategory cat b ) => cat a (cat b (Tensor cat a b)) - type TUnit cat :: k + type TUnit cat :: * tunit :: proxy cat -> TUnit cat instance Monoidal (->) where @@ -332,12 +331,12 @@ class Symmetric cat => Cartesian cat where -- | "fst" specialized to Hask to aid with type inference -- FIXME: this will not be needed with injective types fst :: (a,b) -> a -fst (a,b) = a +fst (a,_) = a -- | "snd" specialized to Hask to aid with type inference -- FIXME: this will not be needed with injective types snd :: (a,b) -> b -snd (a,b) = b +snd (_,b) = b -- | Creates an arrow that ignores its first parameter. const :: @@ -358,9 +357,9 @@ const2 :: const2 a b = initial a . terminal b instance Cartesian ((->) :: * -> * -> *) where - fst_ (a,b) = a - snd_ (a,b) = b - terminal a _ = () + fst_ (a,_) = a + snd_ (_,b) = b + terminal _ _ = () initial a _ = a -- | Closed monoidal categories allow currying, and closed braided categories allow flipping. diff --git a/src/SubHask/Category/Algebra/HMatrix.hs.old b/src/SubHask/Category/Algebra/HMatrix.hs.old deleted file mode 100644 index c7bfe06..0000000 --- a/src/SubHask/Category/Algebra/HMatrix.hs.old +++ /dev/null @@ -1,298 +0,0 @@ -{-# OPTIONS_GHC -XNoRebindableSyntax #-} - -module SubHask.Category.Algebra.HMatrix - ( VS.Vector - , Linear --- , mkMatrix --- , trans --- --- , GL --- , unsafeProveGL --- , proveGL --- --- , SO --- , O --- , Sp - ) - where - -import qualified Prelude as P - -import Foreign.Storable -import qualified Data.Vector.Generic as VG -import qualified Data.Vector.Storable as VS - -import qualified Numeric.LinearAlgebra as HM -import qualified Data.Packed.Matrix as HM - -import SubHask.Internal.Prelude -import SubHask.Algebra -import SubHask.Category -import SubHask.Category.Algebra.Vector - -import Debug.Trace - -------------------------------------------------------------------------------- - --- mkMatrix :: Storable r => Int -> Int -> [r] -> (VS.Vector r `Linear` VS.Vector r) --- mkMatrix r c xs = Matrix $ AddUnit' $ (r HM.>< c) xs --- --- x = mkMatrix 3 3 [1..10] :: VS.Vector Double `Linear` VS.Vector Double --- y = mkMatrix 3 3 [2..10] :: VS.Vector Double `Linear` VS.Vector Double --- z = mkMatrix 3 2 [2..10] :: VS.Vector Double `Linear` VS.Vector Double --- t = mkMatrix 2 2 [2..10] :: VS.Vector Double `Linear` VS.Vector Double --- t' = unsafeProveGL t - ---------- - -data Linear a b - = Matrix (HM.Matrix (Scalar a)) - | Tensor - | Unit --- deriving (Read,Show) - -deriving instance (HM.Element (Scalar a), Show (Scalar a)) => Show (Linear a b) - --- deriving instance HM.Container HM.Matrix r => Semigroup (VS.Vector r `Linear` VS.Vector r) --- deriving instance HM.Container HM.Matrix r => Monoid (VS.Vector r `Linear` VS.Vector r) --- instance HM.Container HM.Matrix r => Abelian (VS.Vector r `Linear` VS.Vector r) --- --- instance HM.Container HM.Matrix r => Group (VS.Vector r `Linear` VS.Vector r) where --- {-# INLINE negate #-} --- negate (Matrix Unit') = Matrix $ Unit' --- negate (Matrix (AddUnit' m)) = Matrix $ AddUnit' $ HM.scale (-1) m - -type instance Scalar (VS.Vector r `Linear` VS.Vector r) = Scalar r - --- instance (IsScalar r, Ring r, HM.Container HM.Matrix r) => Module (VS.Vector r `Linear` VS.Vector r) where --- {-# INLINE (.*) #-} --- r .* (Matrix Unit') = Matrix Unit' --- r .* (Matrix (AddUnit' m)) = Matrix $ AddUnit' $ HM.scale r m --- --- instance (IsScalar r, Field r, HM.Container HM.Matrix r) => VectorSpace (VS.Vector r `Linear` VS.Vector r) - ---------- - -class ValidLinear a -instance ValidLinear (VS.Vector r) -instance ValidLinear (Linear a b) - -instance Category Linear where - type ValidCategory Linear a b = --- ( a ~ VS.Vector (Scalar a) --- , b ~ VS.Vector (Scalar b) --- , a ~ b - ( ValidLinear a - , ValidLinear b - , Scalar a ~ Scalar b - , HM.Container HM.Matrix (Scalar a) - , HM.Product (Scalar a) - ) - - {-# INLINE id #-} - id = Unit - --- {-# INLINE (.) #-} --- a . Unit = a --- Unit . b = b --- (Matrix a) . (Matrix b) = Matrix $ a HM.<> b --- Tensor . Tensor = Tensor - --- instance SubCategory Linear (->) where --- {-# INLINE embed #-} --- embed _ = id --- embed (Matrix m) v = v HM.<> m - -embed' :: - ( a ~ a0 (Scalar a) - , b ~ b0 (Scalar a) - , HM.Mul a0 HM.Matrix b0 - , HM.Product (Scalar a) - ) => Linear a b -> a -> b -embed' (Matrix m) v = v HM.<> m - --- instance Monoidal Linear where --- type Tensor Linear = Linear --- type Unit Linear = () --- {-# INLINE tensor #-} --- tensor = Tensor --- --- instance Dagger (Linear r) where --- {-# INLINE dagger #-} --- dagger (Matrix Unit') = Matrix Unit' --- dagger (Matrix (AddUnit' m)) = Matrix $ AddUnit' $ HM.trans m - --- {-# INLINE trans #-} --- trans :: --- ( IsScalar r --- , HM.Container HM.Vector r --- , HM.Product r --- ) => (VS.Vector r `Linear` VS.Vector r) -> (VS.Vector r `Linear` VS.Vector r) --- trans = dagger - -------------------- - -instance HM.Container HM.Matrix r => Semigroup (HM.Matrix r) where - m1 + m2 = m1 `HM.add` m2 --- m1 + m2 = HM.liftMatrix (VG.zipWith (+) $ HM.flatten m1) m2 - - -------------------------------------------------------------------------------- - -{- --- | The general linear group is the group of all invertible matrices. --- --- Note: In standard notation, the group operation is given by matrix --- multiplication. We continue to use matrix addition as the group operation, --- however, and matrix multiplication becomes the category @(.)@ operation. --- Thus, @GL@ is the version of "Linear" that is also a "Groupoid". --- --- See or --- for more info. - -newtype GL a b = GL (Linear a b) - -deriving instance Read (Linear a b) => Read (GL a b) -deriving instance Show (Linear a b) => Show (GL a b) - -type instance Scalar (GL a b) = Scalar (Linear a b) - -deriving instance Semigroup (Linear a b) => Semigroup (GL a b) -deriving instance Abelian (Linear a b) => Abelian (GL a b) -deriving instance Monoid (Linear a b) => Monoid (GL a b) -deriving instance Group (Linear a b) => Group (GL a b) -deriving instance Module (Linear a b) => Module (GL a b) -deriving instance VectorSpace (Linear a b) => VectorSpace (GL a b) - -instance Category Linear => Category GL where - type ValidCategory GL a b = - ( ValidCategory Linear a b - , HM.Field (Scalar a) - , Eq (Scalar a) - ) - - id = GL id - (GL a).(GL b) = GL $ a.b - -instance SubCategory cat Linear => SubCategory cat GL where - embed (GL m) = embed m - -instance Dagger GL where - dagger (GL m) = GL $ dagger m - -instance Groupoid GL where - inverse (GL (Matrix (Unit'))) = GL (Matrix (Unit')) - inverse (GL (Matrix (AddUnit' m))) = GL (Matrix (AddUnit' $ HM.inv m)) - -unsafeProveGL :: Linear a b -> GL a b -unsafeProveGL = GL - -proveGL :: ValidCategory GL a b => Linear a b -> Maybe (GL a b) -proveGL x@(Matrix Unit') = Just $ GL x -proveGL x@(Matrix (AddUnit' m)) = if HM.det m /= 0 - then Just $ GL x - else Nothing - -------------------------------------------------------------------------------- - --- | The orthogonal group "O" is the subgroup of "GL" that corresponds with --- rotations (i.e. all transformations that preserve Euclidean distances). --- --- See or --- for more info. -newtype O a b = O (GL a b) - -deriving instance Read (GL a b) => Read (O a b) -deriving instance Show (GL a b) => Show (O a b) - -type instance Scalar (O a b) = Scalar (GL a b) - -deriving instance Semigroup (GL a b) => Semigroup (O a b) -deriving instance Abelian (GL a b) => Abelian (O a b) -deriving instance Monoid (GL a b) => Monoid (O a b) -deriving instance Group (GL a b) => Group (O a b) -deriving instance Module (GL a b) => Module (O a b) -deriving instance VectorSpace (GL a b) => VectorSpace (O a b) - -instance Category GL => Category O where - type ValidCategory O a b = (ValidCategory GL a b) - id = O id - (O a).(O b) = O $ a.b - -instance SubCategory cat GL => SubCategory cat O where - embed (O m) = embed m - -instance Dagger O where - dagger (O m) = O $ dagger m - -instance Groupoid O where - inverse (O m) = O $ inverse m - -------------------------------------------------------------------------------- - --- | The special orthogonal group "SO" is the subgroup of "O" with determinant --- 1. This group is also called the special linear group. --- --- See . -newtype SO a b = SO (O a b) - -deriving instance Read (O a b) => Read (SO a b) -deriving instance Show (O a b) => Show (SO a b) - -type instance Scalar (SO a b) = Scalar (O a b) - -deriving instance Semigroup (O a b) => Semigroup (SO a b) -deriving instance Abelian (O a b) => Abelian (SO a b) -deriving instance Monoid (O a b) => Monoid (SO a b) -deriving instance Group (O a b) => Group (SO a b) -deriving instance Module (O a b) => Module (SO a b) -deriving instance VectorSpace (O a b) => VectorSpace (SO a b) - -instance Category O => Category SO where - type ValidCategory SO a b = (ValidCategory O a b) - id = SO id - (SO a).(SO b) = SO $ a.b - -instance SubCategory cat O => SubCategory cat SO where - embed (SO m) = embed m - -instance Dagger SO where - dagger (SO m) = SO $ dagger m - -instance Groupoid SO where - inverse (SO m) = SO $ inverse m - -------------------------------------------------------------------------------- - --- | The symplectic group is the group of symplectic matrices. Because all --- symplectic matrices have determinant 1, this is a subgroup of "SO". --- --- See . -newtype Sp a b = Sp (SO a b) - -deriving instance Read (SO a b) => Read (Sp a b) -deriving instance Show (SO a b) => Show (Sp a b) - -type instance Scalar (Sp a b) = Scalar (SO a b) - -deriving instance Semigroup (SO a b) => Semigroup (Sp a b) -deriving instance Abelian (SO a b) => Abelian (Sp a b) -deriving instance Monoid (SO a b) => Monoid (Sp a b) -deriving instance Group (SO a b) => Group (Sp a b) -deriving instance Module (SO a b) => Module (Sp a b) -deriving instance VectorSpace (SO a b) => VectorSpace (Sp a b) - -instance Category SO => Category Sp where - type ValidCategory Sp a b = (ValidCategory SO a b) - id = Sp id - (Sp a).(Sp b) = Sp $ a.b - -instance SubCategory cat SO => SubCategory cat Sp where - embed (Sp m) = embed m - -instance Dagger Sp where - dagger (Sp m) = Sp $ dagger m - -instance Groupoid Sp where - inverse (Sp m) = Sp $ inverse m --} diff --git a/src/SubHask/Category/Algebra/TypeParams.hs b/src/SubHask/Category/Algebra/TypeParams.hs deleted file mode 100644 index 5af665b..0000000 --- a/src/SubHask/Category/Algebra/TypeParams.hs +++ /dev/null @@ -1,61 +0,0 @@ -module SubHask.Category.Algebra.TypeParams - where - -import Data.Params -import Data.Params.PseudoPrim -import qualified Data.Params.Vector.Unboxed as PVU -import qualified Data.Vector.Generic as VG - -import SubHask.Internal.Prelude -import SubHask.Algebra - -------------------------------------------------------------------------------- - -instance - ( Monoid r - , KnownNat len - , PseudoPrim r - ) => Semigroup (PVU.Vector (Static len) r) - where - v1 + v2 = VG.zipWith (+) v1 v2 - -instance - ( Monoid r - , KnownNat len - , PseudoPrim r - ) => Monoid (PVU.Vector (Static len) r) - where - zero = VG.replicate (viewParam PVU._len (undefined :: PVU.Vector (Static len) r)) zero - -instance - ( Abelian r - , KnownNat len - , PseudoPrim r - ) => Abelian (PVU.Vector (Static len) r) - -instance - ( Group r - , KnownNat len - , PseudoPrim r - ) => Group (PVU.Vector (Static len) r) - where - negate v = VG.map negate v - -type instance Scalar (PVU.Vector (Static len) r) = Scalar r - -instance - ( Module r - , KnownNat len - , PseudoPrim r - ) => Module (PVU.Vector (Static len) r) - where - r .* v = VG.map (r.*) v - v *. r = VG.map (*.r) v - -instance - ( VectorSpace r - , KnownNat len - , PseudoPrim r - ) => VectorSpace (PVU.Vector (Static len) r) - where - v /. r = VG.map (/.r) v diff --git a/src/SubHask/Category/Finite.hs b/src/SubHask/Category/Finite.hs index 671f299..3678e99 100644 --- a/src/SubHask/Category/Finite.hs +++ b/src/SubHask/Category/Finite.hs @@ -29,8 +29,6 @@ module SubHask.Category.Finite ) where -import Control.Monad -import GHC.Prim import GHC.TypeLits import Data.Proxy import qualified Data.Map as Map @@ -41,7 +39,6 @@ import SubHask.Algebra import SubHask.Algebra.Group import SubHask.Category import SubHask.Internal.Prelude -import SubHask.SubType import SubHask.TemplateHaskell.Deriving ------------------------------------------------------------------------------- @@ -59,10 +56,10 @@ instance KnownNat n => FiniteType (Z n) where type Order (Z n) = n index i = ZIndex i deZIndex (ZIndex i) = i - enumerate = [ mkQuotient i | i <- [0..n - 1] ] + enumerate = map mkQuotient [0..n-1] where n = natVal (Proxy :: Proxy n) - getOrder z = natVal (Proxy :: Proxy n) + getOrder _ = natVal (Proxy :: Proxy n) -- | The 'ZIndex' class is a newtype wrapper around the natural numbers 'Z'. -- @@ -70,7 +67,7 @@ instance KnownNat n => FiniteType (Z n) where -- newtype ZIndex a = ZIndex (Z (Order a)) -deriveHierarchy ''ZIndex [ ''Eq_, ''P.Ord ] +deriveHierarchy ''ZIndex [ ''Eq, ''P.Ord ] -- | Swap the phantom type between two indices. swapZIndex :: Order a ~ Order b => ZIndex a -> ZIndex b @@ -96,19 +93,10 @@ instance Category SparseFunction where (SparseFunction f1).(SparseFunction f2) = SparseFunction (Map.map (\a -> find a f1) f2) where - find k map = case Map.lookup k map of + find k map' = case Map.lookup k map' of Just v -> v Nothing -> swapZIndex k --- instance Sup SparseFunction (->) (->) --- instance Sup (->) SparseFunction (->) --- instance SparseFunction <: (->) where --- embedType_ = Embed2 $ map2function f --- where --- map2function map k = case Map.lookup (index k) map of --- Just v -> deZIndex v --- Nothing -> deZIndex $ swapZIndex $ index k - -- | Generates a sparse representation of a 'Hask' function. -- This proof will always succeed, although it may be computationally expensive if the 'Order' of a and b is large. proveSparseFunction :: @@ -128,11 +116,10 @@ list2sparseFunction :: ) => [Z (Order a)] -> SparseFunction a b list2sparseFunction xs = SparseFunction $ Map.fromList $ go xs where + go [] = undefined go (y:[]) = [(ZIndex y, ZIndex $ P.head xs)] go (y1:y2:ys) = (ZIndex y1,ZIndex y2):go (y2:ys) -------------------------------------------------------------------------------- - data SparseFunctionMonoid a b where SparseFunctionMonoid :: ( FiniteType a @@ -156,55 +143,10 @@ instance Category SparseFunctionMonoid where (SparseFunctionMonoid f1).(SparseFunctionMonoid f2) = SparseFunctionMonoid (Map.map (\a -> find a f1) f2) where - find k map = case Map.lookup k map of + find k map' = case Map.lookup k map' of Just v -> v Nothing -> index zero --- instance Sup SparseFunctionMonoid (->) (->) --- instance Sup (->) SparseFunctionMonoid (->) --- instance (SparseFunctionMonoid <: (->)) where --- embedType_ = Embed2 $ map2function f --- where --- map2function map k = case Map.lookup (index k) map of --- Just v -> deZIndex v --- Nothing -> zero - ---------------------------------------- - -{- -instance (FiniteType b, Semigroup b) => Semigroup (SparseFunctionMonoid a b) where - (SparseFunctionMonoid f1)+(SparseFunctionMonoid f2) = SparseFunctionMonoid $ Map.unionWith go f1 f2 - where - go b1 b2 = index $ deZIndex b1 + deZIndex b2 - -instance - ( FiniteType a - , FiniteType b - , Monoid a - , Monoid b - , Order a ~ Order b - ) => Monoid (SparseFunctionMonoid a b) where - zero = SparseFunctionMonoid $ Map.empty - -instance - ( FiniteType b - , Abelian b - ) => Abelian (SparseFunctionMonoid a b) - -instance (FiniteType b, Group b) => Group (SparseFunctionMonoid a b) where - negate (SparseFunctionMonoid f) = SparseFunctionMonoid $ Map.map (index.negate.deZIndex) f - -type instance Scalar (SparseFunctionMonoid a b) = Scalar b - -instance (FiniteType b, Module b) => Module (SparseFunctionMonoid a b) where - r *. (SparseFunctionMonoid f) = SparseFunctionMonoid $ Map.map (index.(r*.).deZIndex) f - -instance (FiniteType b, VectorSpace b) => VectorSpace (SparseFunctionMonoid a b) where - (SparseFunctionMonoid f) ./ r = SparseFunctionMonoid $ Map.map (index.(./r).deZIndex) f --} - -------------------------------------------------------------------------------- - -- | Represents finite functions as a hash table associating input/output value pairs. data DenseFunction (a :: *) (b :: *) where DenseFunction :: @@ -224,9 +166,6 @@ instance Category DenseFunction where (DenseFunction f).(DenseFunction g) = DenseFunction $ VU.map (f VU.!) g --- instance SubCategory DenseFunction (->) where --- embed (DenseFunction f) = \x -> deZIndex $ int2index $ f VU.! (index2int $ index x) - -- | Generates a dense representation of a 'Hask' function. -- This proof will always succeed; however, if the 'Order' of the finite types -- are very large, it may take a long time. diff --git a/src/SubHask/Category/HMatrix.hs b/src/SubHask/Category/HMatrix.hs deleted file mode 100644 index 53777c6..0000000 --- a/src/SubHask/Category/HMatrix.hs +++ /dev/null @@ -1,25 +0,0 @@ -module SubHask.Category.HMatrix - where - -import GHC.Prim - -import Control.DeepSeq -import Data.Typeable -import qualified Prelude as P -import qualified Data.Vector.Generic as VG -import qualified Data.Vector.Generic.Mutable as VGM -import qualified Data.Vector.Storable as VS -import qualified Numeric.LinearAlgebra as LA - -import SubHask.Algebra -import SubHask.Category -import SubHask.Category.Trans.Linear -import SubHask.Internal.Prelude - -------------------------------------------------------------------------------- - -data family HMatrix a b -data instance HMatrix (VS.Vector a) (VS.Vector a) = Matrix (LA.Matrix a) - -instance Category HMatrix where - diff --git a/src/SubHask/Category/Linear.hs b/src/SubHask/Category/Linear.hs deleted file mode 100644 index 00807a1..0000000 --- a/src/SubHask/Category/Linear.hs +++ /dev/null @@ -1,30 +0,0 @@ -module SubHask.Category.Linear - where - -import GHC.Prim - -import Control.DeepSeq -import Data.Typeable -import qualified Prelude as P -import qualified Data.Map as Map -import qualified Data.Vector.Generic as VG -import qualified Data.Vector.Generic.Mutable as VGM -import qualified Data.Vector.Storable as VS - --- import qualified Numeric.LinearAlgebra as LA - -import Data.Params.Vector.Unboxed - -import SubHask.Algebra -import SubHask.Category -import SubHask.Category.Finite -import SubHask.Internal.Prelude - -------------------------------------------------------------------------------- - -class Category cat => Linear cat where - - -------------------------------------------------------------------------------- --- vectors - diff --git a/src/SubHask/Category/Linear/Objects.hs b/src/SubHask/Category/Linear/Objects.hs deleted file mode 100644 index 9f3dfae..0000000 --- a/src/SubHask/Category/Linear/Objects.hs +++ /dev/null @@ -1,148 +0,0 @@ --- {-# LANGUAGE OverlappingInstances #-} - -module SubHask.Category.Linear - where - -import GHC.Prim - -import Control.DeepSeq -import Data.Primitive -import Data.Typeable -import qualified Prelude as P -import qualified Data.Map as Map -import qualified Data.Vector.Generic as VG -import qualified Data.Vector.Generic.Mutable as VGM -import qualified Data.Vector.Storable as VS - -import Data.Params -import Data.Params.Vector -import qualified Data.Params.Vector.Unboxed as PVU - -import SubHask.Algebra -import SubHask.Category -import SubHask.Category.Finite -import SubHask.Internal.Prelude - -------------------------------------------------------------------------------- --- dense vectors - ---------------------------------------- --- unboxed - -u = VG.fromList [1..10] :: PVU.Vector Automatic Double -v = VG.fromList [2..11] :: PVU.Vector Automatic Double - -u' = VG.fromList [1..10] :: PVU.Vector (Static 10) Double -v' = VG.fromList [2..11] :: PVU.Vector (Static 10) Double - -u'' = withParam (len 10) ( VG.fromList [1..10::Double] :: PVU.Vector RunTime Double ) -v'' = withParam (len 10) ( VG.fromList [2..11::Double] :: PVU.Vector RunTime Double ) - -instance - ( ValidVector (PVU.Vector len) elem - , Monoid elem - ) => Monoid (PVU.Vector len elem) - where - - zero = VG.replicate (param_len (undefined::PVU.Vector len elem)) zero - v1+v2 = VG.zipWith (+) v1 v2 - -instance - ( ValidVector (PVU.Vector len) elem - , Abelian elem - ) => Abelian (PVU.Vector len elem) - -instance - ( ValidVector (PVU.Vector len) elem - , Group elem - ) => Group (PVU.Vector len elem) - where - negate = VG.map negate - -type instance Scalar (PVU.Vector len elem) = Scalar elem - -instance - ( ValidVector (PVU.Vector len) elem - , Module r elem - ) => Module r (PVU.Vector len elem) - where - - r .* v = VG.map (r .*) v - -instance - ( ValidVector (PVU.Vector len) elem - , Module elem elem - ) => Module (PVU.Vector len elem) (PVU.Vector len elem) - where - - v1 .* v2 = VG.zipWith (.*) v1 v2 - --- instance --- ( VG.Vector (PVU.Vector len) elem --- , PVU.Param_len (PVU.Vector len elem) --- , VectorSpace r elem --- ) => VectorSpace r (PVU.Vector len elem) --- where --- v /. r = VG.map (/.r) v --- --- instance --- ( VG.Vector (PVU.Vector len) elem --- , PVU.Param_len (PVU.Vector len elem) --- , VectorSpace (Scalar elem) elem --- , IsScalar elem --- ) => InnerProductSpace (PVU.Vector len elem) --- where - - -- TODO: which of these is correct? --- v1 <> v2 = VG.foldl' (+) zero $ VG.zipWith (*) v1 v2 --- v1 <> v2 = VG.foldl' (+) zero $ VG.zipWith (.*) v1 v2 - - -------------------------------------------------------------------------------- --- sparse free vector space - -newtype SparseFreeVector r a = SparseFreeVector (Map.Map a r) - deriving (Read,Show,Typeable) - -instance (NFData r, NFData a) => NFData (SparseFreeVector r a) where - rnf (SparseFreeVector m) = rnf m - -mkSparseFreeVector :: (Ring r, Ord a) => [a] -> SparseFreeVector r a -mkSparseFreeVector xs = SparseFreeVector $ Map.fromList $ map (,one) xs - -------------------- - -type instance Scalar (SparseFreeVector r a) = Scalar r - -instance (Ord a, Abelian r) => Abelian (SparseFreeVector r a) -instance (Ord a, Monoid r) => Monoid (SparseFreeVector r a) where - zero = SparseFreeVector $ Map.empty - (SparseFreeVector m1)+(SparseFreeVector m2) = SparseFreeVector $ Map.unionWith (+) m1 m2 - -instance (Ord a, Group r) => Group (SparseFreeVector r a) where - negate (SparseFreeVector m1) = SparseFreeVector $ Map.map negate m1 - -instance (Ord a, Ring r) => Module r (SparseFreeVector r a) where - r .* (SparseFreeVector m) = SparseFreeVector $ Map.map (r*) m - -instance (Ord a, Field r) => VectorSpace r (SparseFreeVector r a) - -instance (Ord a, Field r, IsScalar r) => InnerProductSpace (SparseFreeVector r a) where - (SparseFreeVector m1)<>(SparseFreeVector m2) = Map.foldr (+) zero $ Map.intersectionWith (*) m1 m2 - --- instance (Ord a, Field r, IsScalar r) => OuterProduct (SparseFreeVector r a) where --- type Outer (SparseFreeVector r a) = SparseFreeVector r (a,a) --- (SparseFreeVector m1)><(SparseFreeVector m2) = SparseFreeVector $ Map.fromList --- [ ((k1,k2),v1*v2) --- | (k1,v1) <- Map.toList m1 --- , (k2,v2) <- Map.toList m2 --- ] - -instance (Ord a, Floating r, IsScalar r) => MetricSpace (SparseFreeVector r a) where - distance (SparseFreeVector v1) (SparseFreeVector v2) = - sqrt $ Map.foldl (+) zero $ Map.map (\a -> a*a) $ Map.unionWith (-) v1 v2 - -instance (Ord a, Floating r, IsScalar r) => HilbertSpace (SparseFreeVector r a) - -x = mkSparseFreeVector $ words "this is a test" :: SparseFreeVector Double String -y = mkSparseFreeVector $ words "this is not" :: SparseFreeVector Double String diff --git a/src/SubHask/Category/Polynomial.hs b/src/SubHask/Category/Polynomial.hs index a8f1284..d19bf7a 100644 --- a/src/SubHask/Category/Polynomial.hs +++ b/src/SubHask/Category/Polynomial.hs @@ -7,12 +7,8 @@ import qualified Prelude as P import SubHask.Internal.Prelude import SubHask.Category import SubHask.Algebra -import SubHask.Monad import SubHask.SubType -------------------------------------------------------------------------------- - - -- | The type of polynomials over an arbitrary ring. -- -- See for more detail. @@ -25,19 +21,19 @@ type Polynomial a = Polynomial_ a a -- Can/Should we generalize this to allow polynomials between types? -- data Polynomial_ a b where - Polynomial_ :: (ValidLogic a, Ring a, a~b) => {-#UNPACK#-}![a] -> Polynomial_ a b + Polynomial_ :: (Eq a, Ring a, a~b) => ![a] -> Polynomial_ a b mkMutable [t| forall a b. Polynomial_ a b |] -instance (Eq r, Show r) => Show (Polynomial_ r r) where - show (Polynomial_ xs) = concat $ intersperse " + " $ filter (/=[]) $ reverse $ imap go xs +instance (Eq r, ClassicalLogic r, Show r) => Show (Polynomial_ r r) where + show (Polynomial_ xs) = concat $ intersperse " + " $ filter (/=[]) $ reverse $ P.map go $ P.zip [0..] xs where -- FIXME: -- The code below results in prettier output but incurs an "Eq" constraint that confuses ghci - go :: Int -> r -> String - go 0 x = when (zero/=x) $ show x - go 1 x = when (zero/=x) $ when (one/=x) (show x) ++ "x" - go i x = when (zero/=x) $ when (one/=x) (show x) ++ "x^" ++ show i + go :: (Int,r) -> String + go (0,x) = when (zero/=x) $ show x + go (1,x) = when (zero/=x) $ when (one/=x) (show x) ++ "x" + go (i,x) = when (zero/=x) $ when (one/=x) (show x) ++ "x^" ++ show i when :: Monoid a => Bool -> a -> a when cond x = if cond then x else zero @@ -52,79 +48,75 @@ mkMutable [t| forall a. ProofOf Polynomial_ a |] instance Ring a => Semigroup (ProofOf Polynomial_ a) where (ProofOf p1)+(ProofOf p2) = ProofOf $ p1+p2 -instance (ValidLogic a, Ring a) => Cancellative (ProofOf Polynomial_ a) where +instance (Eq a, Ring a) => Cancellative (ProofOf Polynomial_ a) where (ProofOf p1)-(ProofOf p2) = ProofOf $ p1-p2 -instance (ValidLogic a, Ring a) => Monoid (ProofOf Polynomial_ a) where +instance (Eq a, Ring a) => Monoid (ProofOf Polynomial_ a) where zero = ProofOf zero instance (Ring a, Abelian a) => Abelian (ProofOf Polynomial_ a) -instance (ValidLogic a, Ring a) => Group (ProofOf Polynomial_ a) where +instance (Eq a, Ring a) => Group (ProofOf Polynomial_ a) where negate (ProofOf p) = ProofOf $ negate p -instance (ValidLogic a, Ring a) => Rg (ProofOf Polynomial_ a) where +instance (Eq a, Ring a) => Rg (ProofOf Polynomial_ a) where (ProofOf p1)*(ProofOf p2) = ProofOf $ p1*p2 -instance (ValidLogic a, Ring a) => Rig (ProofOf Polynomial_ a) where +instance (Eq a, Ring a) => Rig (ProofOf Polynomial_ a) where one = ProofOf one -instance (ValidLogic a, Ring a) => Ring (ProofOf Polynomial_ a) where +instance (Eq a, Ring a) => Ring (ProofOf Polynomial_ a) where fromInteger i = ProofOf $ fromInteger i -provePolynomial :: (ValidLogic a, Ring a) => (ProofOf Polynomial_ a -> ProofOf Polynomial_ a) -> Polynomial_ a a +provePolynomial :: (Eq a, Ring a) => (ProofOf Polynomial_ a -> ProofOf Polynomial_ a) -> Polynomial_ a a provePolynomial f = unProofOf $ f $ ProofOf $ Polynomial_ [0,1] ---------------------------------------- type instance Scalar (Polynomial_ a b) = Scalar b type instance Logic (Polynomial_ a b) = Logic b -instance Eq b => Eq_ (Polynomial_ a b) where +instance Eq b => Eq (Polynomial_ a b) where (Polynomial_ xs)==(Polynomial_ ys) = xs==ys instance Ring r => Semigroup (Polynomial_ r r) where (Polynomial_ p1)+(Polynomial_ p2) = Polynomial_ $ sumList (+) p1 p2 -instance (ValidLogic r, Ring r) => Monoid (Polynomial_ r r) where +instance (Eq r, Ring r) => Monoid (Polynomial_ r r) where zero = Polynomial_ [] -instance (ValidLogic r, Ring r) => Cancellative (Polynomial_ r r) where +instance (Eq r, Ring r) => Cancellative (Polynomial_ r r) where (Polynomial_ p1)-(Polynomial_ p2) = Polynomial_ $ sumList (-) p1 p2 -instance (ValidLogic r, Ring r) => Group (Polynomial_ r r) where +instance (Eq r, Ring r) => Group (Polynomial_ r r) where negate (Polynomial_ p) = Polynomial_ $ P.map negate p instance (Ring r, Abelian r) => Abelian (Polynomial_ r r) -instance (ValidLogic r, Ring r) => Rg (Polynomial_ r r) where +instance (Eq r, Ring r) => Rg (Polynomial_ r r) where (Polynomial_ p1)*(Polynomial_ p2) = Polynomial_ $ P.foldl (sumList (+)) [] $ go p1 zero where - go [] i = [] + go [] _ = [] go (x:xs) i = (P.replicate i zero ++ P.map (*x) p2):go xs (i+one) -instance (ValidLogic r, Ring r) => Rig (Polynomial_ r r) where +instance (Eq r, Ring r) => Rig (Polynomial_ r r) where one = Polynomial_ [one] -instance (ValidLogic r, Ring r) => Ring (Polynomial_ r r) where +instance (Eq r, Ring r) => Ring (Polynomial_ r r) where fromInteger i = Polynomial_ [fromInteger i] -type instance Polynomial_ r r >< r = Polynomial_ r r - -instance IsScalar r => Module (Polynomial_ r r) where +instance ValidScalar r => Module (Polynomial_ r r) where (Polynomial_ xs) .* r = Polynomial_ $ P.map (*r) xs -instance IsScalar r => FreeModule (Polynomial_ r r) where +instance ValidScalar r => FreeModule (Polynomial_ r r) where (Polynomial_ xs) .*. (Polynomial_ ys) = Polynomial_ $ P.zipWith (*) xs ys ones = Polynomial_ $ P.repeat one -sumList f [] ys = ys -sumList f xs [] = xs +sumList :: (t -> t -> t) -> [t] -> [t] -> [t] +sumList _ [] ys = ys +sumList _ xs [] = xs sumList f (x:xs) (y:ys) = f x y:sumList f xs ys ---------------------------------------- - instance Category Polynomial_ where - type ValidCategory Polynomial_ a = (ValidLogic a, Ring a) + type ValidCategory Polynomial_ a = (Eq a, Ring a) id = Polynomial_ [zero, one] (Polynomial_ xs) . p2@(Polynomial_ _) = Polynomial_ (map (\x -> Polynomial_ [x]) xs) $ p2 @@ -142,8 +134,6 @@ evalPolynomial_ (Polynomial_ xs) r = sum $ imap go xs where go i x = x*pow r i -------------------------------------------------------------------------------- - -- FIXME: -- Polynomial_s should use the derivative interface from the Derivative module -- diff --git a/src/SubHask/Category/Product.hs b/src/SubHask/Category/Product.hs index cbd2ef9..ea8a3c5 100644 --- a/src/SubHask/Category/Product.hs +++ b/src/SubHask/Category/Product.hs @@ -1,14 +1,7 @@ module SubHask.Category.Product where -import GHC.Prim -import qualified Prelude as P - import SubHask.Category -import SubHask.Internal.Prelude -import GHC.Exts - -------------------------------------------------------------------------------- data (><) cat1 cat2 a b = Product (cat1 a b, cat2 a b) diff --git a/src/SubHask/Category/Slice.hs b/src/SubHask/Category/Slice.hs index 791377b..4b6d3bd 100644 --- a/src/SubHask/Category/Slice.hs +++ b/src/SubHask/Category/Slice.hs @@ -1,14 +1,7 @@ module SubHask.Category.Slice where -import GHC.Prim -import qualified Prelude as P - import SubHask.Category -import SubHask.Algebra -import SubHask.Internal.Prelude - -------------------------------------------------------------------------------- data Comma cat1 cat2 cat3 a b = Comma (cat1 a b) (cat2 a b) @@ -27,11 +20,6 @@ instance id = Comma id id (Comma f1 g1).(Comma f2 g2) = Comma (f1.f2) (g1.g2) --- runComma :: ValidCategory (Comma cat1 cat2 cat3) a b => --- (Comma cat1 cat2 cat3) a b -> cat3 a b -> cat3 a b - -------------------------------------------------------------------------------- - data (cat / (obj :: *)) (a :: *) (b :: *) = Slice (cat a b) instance Category cat => Category (cat/obj) where diff --git a/src/SubHask/Category/Trans/Algebra.hs b/src/SubHask/Category/Trans/Algebra.hs deleted file mode 100644 index 2444180..0000000 --- a/src/SubHask/Category/Trans/Algebra.hs +++ /dev/null @@ -1,144 +0,0 @@ -module SubHask.Category.Trans.Algebra --- ( --- Mon --- , MonT --- , unsafeProveMonT --- ) - where - -import Debug.Trace - -import GHC.Prim -import GHC.TypeLits -import Data.Proxy -import qualified Prelude as P - -import SubHask.Internal.Prelude -import SubHask.Category -import SubHask.Algebra -import SubHask.Category.Trans.Common - -------------------------------------------------------------------------------- - -type Mon a b = MonT (->) a b - -class Category cat => MonoidHom cat - -newtype MonT cat (a :: *) (b :: *) = MonT (cat a b) - --- mkCatTrans ''MonT ''Monoid - - -instance Category cat => MonoidHom (MonT cat) - -unsafeProveMonoidHom :: - ( Monoid a - , Monoid b - ) => cat a b -> MonT cat a b -unsafeProveMonoidHom = MonT - - -------------------------------------------------------------------------------- - -type Grp a b = GrpT (->) a b - -class MonoidHom cat => GroupHom cat - -newtype GrpT cat (a :: *) (b :: *) = GrpT (cat a b) - --- mkCatTrans ''GrpT ''Group - -instance Category cat => MonoidHom (GrpT cat) -instance Category cat => GroupHom (GrpT cat) - -unsafeProveGroupHom :: - ( Group a - , Group b - ) => cat a b -> GrpT cat a b -unsafeProveGroupHom = GrpT - -------------------------------------------------------------------------------- - -type Mod a b = ModT (->) a b - -class GroupHom cat => ModuleHom cat - -newtype ModT cat (a :: *) (b :: *) = ModT (cat a b) - --- mkCatTrans ''ModT ''Module - -instance Category cat => MonoidHom (ModT cat) -instance Category cat => GroupHom (ModT cat) -instance Category cat => ModuleHom (ModT cat) - -unsafeProveModuleHom :: - ( Module a - , Module b - ) => cat a b -> ModT cat a b -unsafeProveModuleHom = ModT - -------------------------------------------------------------------------------- - -type Vect a b = LinearT (->) a b - -class ModuleHom cat => Linear cat - -newtype LinearT cat (a :: *) (b :: *) = LinearT (cat a b) - --- mkCatTrans ''LinearT ''VectorSpace - -instance Category cat => MonoidHom (LinearT cat) -instance Category cat => GroupHom (LinearT cat) -instance Category cat => ModuleHom (LinearT cat) -instance Category cat => Linear (LinearT cat) - --- newtype Linear r a b = Linear (a r -> b r) --- --- instance Category (Linear r) where --- type ValidCategory (Linear r) (a :: * -> *) (b :: * -> *) = () --- id = Linear id --- (Linear f1).(Linear f2) = Linear $ f1.f2 - -------------------------------------------------------------------------------- - -type Lip a b = LipT (->) a b - --- | See for more details. -class Category cat => Lipschitz cat where - lipschitzModulus :: cat a b -> Scalar b - -data LipT cat (a :: *) (b :: *) = LipT !(Scalar b) !(cat a b) - ---mkCatTrans ''LipT ''MetricSpace - -instance Category cat => Category (LipT cat) where - type ValidCategory (LipT cat) a = - ( MetricSpace a - , ValidCategory cat a - ) - - {-# INLINE id #-} - id = LipT one id - - {-# INLINE (.) #-} - (LipT m1 f1).(LipT m2 f2) = LipT (m1*m2) (f1.f2) - -instance Category cat => Lipschitz (LipT cat) where - {-# INLINE lipschitzModulus #-} - lipschitzModulus (LipT m _) = m - -------------------- - -type Met a b = MetT (->) a b - --- | See for more details. -class Category cat => Short cat - -newtype MetT cat (a :: *) (b :: *) = MetT (cat a b) - --- mkCatTrans ''MetT ''MetricSpace - -instance Category cat => Short (MetT cat) -instance Category cat => Lipschitz (MetT cat) where - {-# INLINE lipschitzModulus #-} - lipschitzModulus _ = one diff --git a/src/SubHask/Category/Trans/Bijective.hs b/src/SubHask/Category/Trans/Bijective.hs index af3d14e..2e211c9 100644 --- a/src/SubHask/Category/Trans/Bijective.hs +++ b/src/SubHask/Category/Trans/Bijective.hs @@ -13,24 +13,14 @@ module SubHask.Category.Trans.Bijective , BijectiveT , proveBijective , unsafeProveBijective + , unInjectiveT + , unSurjectiveT + , unBijectiveT ) where import SubHask.Category -import SubHask.Algebra import SubHask.SubType -import SubHask.Internal.Prelude - - --- newtype instance ProofOf InjectiveT a = ProofOf { unProofOf :: a } --- --- instance Semigroup a => Semigroup (ProofOf InjectiveT a) where --- (ProofOf a1)+(ProofOf a2) = ProofOf (a1+a2) --- --- proveInjective :: (ProofOf InjectiveT a -> ProofOf InjectiveT b) -> InjectiveT (->) a b --- proveInjective f = InjectiveT $ \a -> unProofOf $ f $ ProofOf a - -------------------------------------------------------------------------------- -- | Injective (one-to-one) functions map every input to a unique output. See -- for more detail. @@ -50,11 +40,9 @@ instance Sup b a c => Sup a (InjectiveT b) c instance (subcat <: cat) => InjectiveT subcat <: cat where embedType_ = Embed2 (\ (InjectiveT f) -> embedType2 f) -unsafeProveInjective :: Concrete cat => cat a b -> InjectiveT cat a b +unsafeProveInjective :: cat a b -> InjectiveT cat a b unsafeProveInjective = InjectiveT -------------------- - -- | Surjective (onto) functions can take on every value in the range. See -- for more detail. class Concrete cat => Surjective cat @@ -73,11 +61,9 @@ instance Sup b a c => Sup a (SurjectiveT b) c instance (subcat <: cat) => SurjectiveT subcat <: cat where embedType_ = Embed2 (\ (SurjectiveT f) -> embedType2 f) -unsafeProveSurjective :: Concrete cat => cat a b -> SurjectiveT cat a b +unsafeProveSurjective :: cat a b -> SurjectiveT cat a b unsafeProveSurjective = SurjectiveT -------------------- - -- | Bijective functions are both injective and surjective. See -- for more detail. class (Injective cat, Surjective cat) => Bijective cat @@ -101,23 +87,5 @@ instance (subcat <: cat) => BijectiveT subcat <: cat where proveBijective :: (Injective cat, Surjective cat) => cat a b -> BijectiveT cat a b proveBijective = BijectiveT -unsafeProveBijective :: Concrete cat => cat a b -> BijectiveT cat a b +unsafeProveBijective :: cat a b -> BijectiveT cat a b unsafeProveBijective = BijectiveT - -{- -data BijectiveT cat a b = BijectiveT (cat a b) (cat b a) - -instance SubCategory cat subcat => SubCategory cat (BijectiveT subcat) where - embed (BijectiveT f fi) = embed f - -instance Category cat => Groupoid (BijectiveT cat) where - inverse (BijectiveT f fi) = BijectiveT fi f - -instance Category cat => Category (BijectiveT cat) where - type ValidCategory (BijectiveT cat) a b = (ValidCategory cat a b, ValidCategory cat b a) - id = BijectiveT id id - (BijectiveT f fi).(BijectiveT g gi) = BijectiveT (f.g) (gi.fi) - -unsafeProveBijective :: cat a b -> cat b a -> BijectiveT cat a b -unsafeProveBijective f fi = BijectiveT f fi --} diff --git a/src/SubHask/Category/Trans/Constrained.hs b/src/SubHask/Category/Trans/Constrained.hs index 4862a92..0c3508d 100644 --- a/src/SubHask/Category/Trans/Constrained.hs +++ b/src/SubHask/Category/Trans/Constrained.hs @@ -11,25 +11,18 @@ module SubHask.Category.Trans.Constrained ) where -import GHC.Prim -import qualified Prelude as P - import SubHask.Algebra import SubHask.Category import SubHask.SubType import SubHask.Internal.Prelude -------------------------------------------------------------------------------- - -type EqHask = ConstrainedT '[Eq_ ] Hask -type OrdHask = ConstrainedT '[Ord_] Hask +type EqHask = ConstrainedT '[Eq ] Hask +type OrdHask = ConstrainedT '[Ord] Hask type family AppConstraints (f :: [* -> Constraint]) (a :: *) :: Constraint type instance AppConstraints '[] a = (ClassicalLogic a) type instance AppConstraints (x ': xs) a = (x a, AppConstraints xs a) ---------- - data ConstrainedT (xs :: [* -> Constraint]) cat (a :: *) (b :: *) where ConstrainedT :: ( AppConstraints xs a @@ -44,14 +37,12 @@ proveConstrained :: ) => cat a b -> ConstrainedT xs cat a b proveConstrained = ConstrainedT -proveEqHask :: (Eq a, Eq b) => (a -> b) -> (a `EqHask` b) +proveEqHask :: (ClassicalLogic a, ClassicalLogic b, Eq a, Eq b) => (a -> b) -> (a `EqHask` b) proveEqHask = proveConstrained -proveOrdHask :: (Ord a, Ord b) => (a -> b) -> (a `OrdHask` b) +proveOrdHask :: (ClassicalLogic a, ClassicalLogic b, Ord a, Ord b) => (a -> b) -> (a `OrdHask` b) proveOrdHask = proveConstrained ---------- - instance Category cat => Category (ConstrainedT xs cat) where type ValidCategory (ConstrainedT xs cat) (a :: *) = @@ -74,17 +65,3 @@ instance (AppConstraints xs (TUnit cat), Monoidal cat) => Monoidal (ConstrainedT type TUnit (ConstrainedT xs cat) = TUnit cat tunit _ = tunit (Proxy::Proxy cat) - --- instance (AppConstraints xs (TUnit cat), Braided cat) => Braided (ConstrainedT xs cat) where --- braid = braid (Proxy :: Proxy cat) --- unbraid = unbraid (Proxy :: Proxy cat) - --- instance (AppConstraints xs (TUnit cat), Symmetric cat) => Symmetric (ConstrainedT xs cat) - --- instance (AppConstraints xs (TUnit cat), Cartesian cat) => Cartesian (ConstrainedT xs cat) where --- fst = ConstrainedT fst --- snd = ConstrainedT snd --- --- terminal a = ConstrainedT $ terminal a --- initial a = ConstrainedT $ initial a - diff --git a/src/SubHask/Category/Trans/Continuous.hs b/src/SubHask/Category/Trans/Continuous.hs deleted file mode 100644 index ad1f900..0000000 --- a/src/SubHask/Category/Trans/Continuous.hs +++ /dev/null @@ -1,14 +0,0 @@ -module SubHask.Category.Trans.Continuous - where - -import SubHask.Internal.Prelude -import SubHask.Category -import SubHask.Algebra - -data C0T cat a b where - C0T :: cat a b -> C0T cat a b - -instance Category cat => Category (C0T cat) where - type ValidCategory (C0T cat) a = ValidCategory cat a - id = C0T id - (C0T f).(C0T g) = C0T $ f.g diff --git a/src/SubHask/Category/Trans/Derivative.hs b/src/SubHask/Category/Trans/Derivative.hs index ab469a4..ce2dbc1 100644 --- a/src/SubHask/Category/Trans/Derivative.hs +++ b/src/SubHask/Category/Trans/Derivative.hs @@ -1,5 +1,5 @@ {-# LANGUAGE IncoherentInstances #-} - +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -- | This module provides a category transformer for automatic differentiation. -- -- There are many alternative notions of a generalized derivative. @@ -21,15 +21,11 @@ module SubHask.Category.Trans.Derivative where import SubHask.Algebra -import SubHask.Algebra.Vector import SubHask.Category import SubHask.SubType import SubHask.Internal.Prelude -import qualified Prelude as P - -------------------------------------------------------------------------------- - -- | This is essentially just a translation of the "Numeric.AD.Forward.Forward" type -- for use with the SubHask numeric hierarchy. -- @@ -75,6 +71,11 @@ instance Field a => Field (Forward a) where --------- +-- | FIXME: +-- This represents the tensor product; +-- it doesn't belong here! +type family (><) a b + proveC1 :: (a ~ (a> (Forward a -> Forward a) -> C1 (a -> a) proveC1 f = Diffn (\a -> val $ f $ Forward a one) $ Diff0 $ \a -> val' $ f $ Forward a one @@ -104,33 +105,47 @@ instance Diff 0 <: (->) where where unDiff0 :: Diff 0 a b -> a -> b unDiff0 (Diff0 f) = f + unDiff0 (Diffn _ _) = undefined instance Diff n <: (->) where embedType_ = Embed2 unDiffn where unDiffn :: Diff n a b -> a -> b - unDiffn (Diffn f f') = f + unDiffn (Diffn f _) = f + unDiffn (Diff0 _) = undefined + -- -- FIXME: these subtyping instance should be made more generic -- the problem is that type families aren't currently powerful enough -- instance Sup (Diff 0) (Diff 1) (Diff 0) instance Sup (Diff 1) (Diff 0) (Diff 0) -instance Diff 1 <: Diff 0 where embedType_ = Embed2 m2n where m2n (Diffn f f') = Diff0 f +instance Diff 1 <: Diff 0 + where embedType_ = Embed2 m2n + where m2n (Diffn f _) = Diff0 f + m2n (Diff0 _) = undefined instance Sup (Diff 0) (Diff 2) (Diff 0) instance Sup (Diff 2) (Diff 0) (Diff 0) -instance Diff 2 <: Diff 0 where embedType_ = Embed2 m2n where m2n (Diffn f f') = Diff0 f +instance Diff 2 <: Diff 0 + where embedType_ = Embed2 m2n + where m2n (Diffn f _) = Diff0 f + m2n (Diff0 _) = undefined instance Sup (Diff 1) (Diff 2) (Diff 1) instance Sup (Diff 2) (Diff 1) (Diff 1) -instance Diff 2 <: Diff 1 where embedType_ = Embed2 m2n where m2n (Diffn f f') = Diffn f (embedType2 f') +instance Diff 2 <: Diff 1 + where embedType_ = Embed2 m2n + where m2n (Diffn f f') = Diffn f (embedType2 f') + m2n (Diff0 _) = undefined --------- instance (1 <= n) => C (Diff n) where type D (Diff n) = Diff (n-1) - derivative (Diffn f f') = f' + derivative (Diffn _ f') = f' + -- doesn't work, hence no non-ehaustive pattern ghc option + -- derivative (Diff0 _) = undefined unsafeProveC0 :: (a -> b) -> Diff 0 a b unsafeProveC0 f = Diff0 f @@ -141,8 +156,8 @@ unsafeProveC1 -> C1 (a -> b) unsafeProveC1 f f' = Diffn f $ unsafeProveC0 f' -unsafeProveC2 - :: (a -> b) -- ^ f(x) +unsafeProveC2 :: ( ((a><(a> (a -> b) -- ^ f(x) -> (a -> a> (a -> a> C2 (a -> b) @@ -167,11 +182,18 @@ mkMutable [t| forall n a b. Diff n a b |] instance Semigroup b => Semigroup (Diff 0 a b) where (Diff0 f1 )+(Diff0 f2 ) = Diff0 (f1+f2) + _ + _ = undefined instance (Semigroup b, Semigroup (a> Semigroup (Diff 1 a b) where (Diffn f1 f1')+(Diffn f2 f2') = Diffn (f1+f2) (f1'+f2') -instance (Semigroup b, Semigroup (a> Semigroup (Diff 2 a b) where +instance + ( Semigroup b + , Semigroup (a><(a> Semigroup (Diff 2 a b) + where (Diffn f1 f1')+(Diffn f2 f2') = Diffn (f1+f2) (f1'+f2') instance Monoid b => Monoid (Diff 0 a b) where @@ -180,7 +202,13 @@ instance Monoid b => Monoid (Diff 0 a b) where instance (Monoid b, Monoid (a> Monoid (Diff 1 a b) where zero = Diffn zero zero -instance (Monoid b, Monoid (a> Monoid (Diff 2 a b) where +instance + ( Monoid b + , Monoid (a><(a> Monoid (Diff 2 a b) + where zero = Diffn zero zero -------------------------------------------------------------------------------- diff --git a/src/SubHask/Category/Trans/Linear.hs b/src/SubHask/Category/Trans/Linear.hs deleted file mode 100644 index 736ea54..0000000 --- a/src/SubHask/Category/Trans/Linear.hs +++ /dev/null @@ -1,33 +0,0 @@ -module SubHask.Category.Trans.Linear --- ( LinearT --- , (+>) --- , unsafeProveLinear --- ) - where - -import GHC.Prim -import qualified Prelude as P - -import SubHask.Category -import SubHask.Algebra -import SubHask.SubType -import SubHask.Internal.Prelude - -------------------------------------------------------------------------------- - -data LinearT cat a b = LinearT { unLinearT :: cat a b } - -instance Category cat => Category (LinearT cat) where - type ValidCategory (LinearT cat) a = ( ValidCategory cat a ) - id = LinearT id - (LinearT f).(LinearT g) = LinearT $ f.g - -instance Sup (LinearT cat) cat cat -instance Sup cat (LinearT cat) cat -instance (LinearT cat <: cat) where - embedType_ = Embed2 unLinearT - -type (+>) = LinearT (->) - -unsafeProveLinear :: cat a b -> LinearT cat a b -unsafeProveLinear = LinearT diff --git a/src/SubHask/Category/Trans/Monotonic.hs b/src/SubHask/Category/Trans/Monotonic.hs index 12e2fd5..1f6b14b 100644 --- a/src/SubHask/Category/Trans/Monotonic.hs +++ b/src/SubHask/Category/Trans/Monotonic.hs @@ -1,33 +1,25 @@ module SubHask.Category.Trans.Monotonic --- ( Mon (..) --- , unsafeProveMon --- --- -- * The MonT transformer --- , MonT (..) --- , unsafeProveMonT --- --- ) - where + ( Mon + , unsafeProveMon + + -- * The MonT transformer + , MonT (..) + , unsafeProveMonT -import GHC.Prim -import Data.Proxy -import qualified Prelude as P + ) + where -import SubHask.Internal.Prelude import SubHask.Category import SubHask.Algebra import SubHask.SubType -import SubHask.Category.Trans.Constrained - -------------------------------------------------------------------------------- data IncreasingT cat (a :: *) (b :: *) where - IncreasingT :: (Ord_ a, Ord_ b) => cat a b -> IncreasingT cat a b + IncreasingT :: (Ord a, Ord b) => cat a b -> IncreasingT cat a b mkMutable [t| forall cat a b. IncreasingT cat a b |] instance Category cat => Category (IncreasingT cat) where - type ValidCategory (IncreasingT cat) a = (ValidCategory cat a, Ord_ a) + type ValidCategory (IncreasingT cat) a = (ValidCategory cat a, Ord a) id = IncreasingT id (IncreasingT f).(IncreasingT g) = IncreasingT $ f.g @@ -36,22 +28,14 @@ instance Sup b a c => Sup a (IncreasingT b) c instance (subcat <: cat) => IncreasingT subcat <: cat where embedType_ = Embed2 (\ (IncreasingT f) -> embedType2 f) -------------------- - instance Semigroup (cat a b) => Semigroup (IncreasingT cat a b) where (IncreasingT f)+(IncreasingT g) = IncreasingT $ f+g --- instance (Ord_ a, Ord_ b, Monoid (cat a b)) => Monoid (IncreasingT cat a b) where --- zero = IncreasingT zero --- instance Abelian (cat a b) => Abelian (IncreasingT cat a b) where instance Provable (IncreasingT Hask) where f $$ a = ProofOf $ (f $ unProofOf a) - -------------------- - newtype instance ProofOf (IncreasingT cat) a = ProofOf { unProofOf :: ProofOf_ cat a } mkMutable [t| forall a cat. ProofOf (IncreasingT cat) a |] @@ -59,42 +43,31 @@ mkMutable [t| forall a cat. ProofOf (IncreasingT cat) a |] instance Semigroup (ProofOf_ cat a) => Semigroup (ProofOf (IncreasingT cat) a) where (ProofOf a1)+(ProofOf a2) = ProofOf (a1+a2) --- instance Monoid (ProofOf cat a) => Monoid (ProofOf (IncreasingT cat) a) where --- zero = ProofOf zero - instance Abelian (ProofOf_ cat a) => Abelian (ProofOf (IncreasingT cat) a) -------------------- - type Increasing a = Increasing_ a type family Increasing_ a where Increasing_ ( (cat :: * -> * -> *) a b) = IncreasingT cat a b proveIncreasing :: - ( Ord_ a - , Ord_ b + ( Ord a + , Ord b ) => (ProofOf (IncreasingT Hask) a -> ProofOf (IncreasingT Hask) b) -> Increasing (a -> b) proveIncreasing f = unsafeProveIncreasing $ \a -> unProofOf $ f $ ProofOf a -instance (Ord_ a, Ord_ b) => Hask (ProofOf (IncreasingT Hask) a) (ProofOf (IncreasingT Hask) b) <: (IncreasingT Hask) a b where +instance (Ord a, Ord b) => Hask (ProofOf (IncreasingT Hask) a) (ProofOf (IncreasingT Hask) b) <: (IncreasingT Hask) a b where embedType_ = Embed0 proveIncreasing unsafeProveIncreasing :: - ( Ord_ a - , Ord_ b + ( Ord a + , Ord b ) => (a -> b) -> Increasing (a -> b) unsafeProveIncreasing = IncreasingT -------------------------------------------------------------------------------- - -- | A convenient specialization of "MonT" and "Hask" type Mon = MonT Hask --- type family ValidMon a :: Constraint where --- ValidMon a = Ord_ a --- ValidMon (MonT (->) b c) = (ValidMon b, ValidMon c) --- ValidMon a = Ord a -type ValidMon a = Ord a +type ValidMon a = (Ord a, ClassicalLogic a) data MonT cat (a :: *) (b :: *) where MonT :: (ValidMon a, ValidMon b) => cat a b -> MonT cat a b @@ -105,8 +78,6 @@ unsafeProveMonT = MonT unsafeProveMon :: (ValidMon a, ValidMon b) => cat a b -> MonT cat a b unsafeProveMon = MonT -------------------- - instance Category cat => Category (MonT cat) where type ValidCategory (MonT cat) a = (ValidCategory cat a, ValidMon a) id = MonT id @@ -117,80 +88,3 @@ instance Sup b a c => Sup a (MonT b) c instance (subcat <: cat) => MonT subcat <: cat where embedType_ = Embed2 (\ (MonT f) -> embedType2 f) --- instance (ValidMon (TUnit cat), Monoidal cat) => Monoidal (MonT cat) where --- type Tensor (MonT cat) = Tensor cat --- tensor = error "FIXME: need to add a Hask Functor instance for this to work" --- --- type TUnit (MonT cat) = TUnit cat --- tunit _ = tunit (Proxy::Proxy cat) - --- instance (ValidMon (TUnit cat), Braided cat) => Braided (MonT cat) where --- braid _ = braid (Proxy :: Proxy cat) --- unbraid _ = unbraid (Proxy :: Proxy cat) --- --- instance (ValidMon (TUnit cat), Symmetric cat) => Symmetric (MonT cat) --- --- instance (ValidMon (TUnit cat), Cartesian cat) => Cartesian (MonT cat) where --- fst = MonT fst --- snd = MonT snd --- --- terminal a = MonT $ terminal a --- initial a = MonT $ initial a - -------------------------------------------------------------------------------- - -{- -type Mon = MonT Hask - -newtype MonT cat a b = MonT (ConstrainedT '[P.Ord] cat a b) - -unsafeProveMon :: - ( Ord b - , Ord a - , ValidCategory cat a - , ValidCategory cat b - ) => cat a b -> MonT (cat) a b -unsafeProveMon f = MonT $ proveConstrained f - -------------------- - -instance Category cat => Category (MonT cat) where - type ValidCategory (MonT cat) a = ValidCategory (ConstrainedT '[P.Ord] cat) a - id = MonT id - (MonT f) . (MonT g) = MonT (f.g) - -instance SubCategory subcat cat => SubCategory (MonT subcat) cat where - embed (MonT f) = embed f - -instance (Ord (TUnit cat), Monoidal cat) => Monoidal (MonT cat) where - type Tensor (MonT cat) = Tensor cat - tensor = error "FIXME: need to add a Hask Functor instance for this to work" - - type TUnit (MonT cat) = TUnit cat - tunit _ = tunit (Proxy::Proxy cat) - -instance (Ord (TUnit cat), Braided cat) => Braided (MonT cat) where - braid _ = braid (Proxy :: Proxy cat) - unbraid _ = unbraid (Proxy :: Proxy cat) - -instance (Ord (TUnit cat), Symmetric cat) => Symmetric (MonT cat) - -instance (Ord (TUnit cat), Cartesian cat) => Cartesian (MonT cat) where - fst = MonT $ ConstrainedT fst - snd = MonT $ ConstrainedT snd - - terminal a = MonT $ ConstrainedT $ terminal a - initial a = MonT $ ConstrainedT $ initial a - - -------------------- - -mon :: Int -> [Int] -mon i = [i,i+1,i+2] - -nomon :: Int -> [Int] -nomon i = if i `mod` 2 == 0 - then mon i - else mon (i*2) - --} diff --git a/src/SubHask/Compatibility/Base.hs b/src/SubHask/Compatibility/Base.hs index 7918be7..b2e0aee 100644 --- a/src/SubHask/Compatibility/Base.hs +++ b/src/SubHask/Compatibility/Base.hs @@ -1,4 +1,8 @@ {-# LANGUAGE NoRebindableSyntax #-} +{-# OPTIONS_GHC -fno-warn-missing-methods #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} -- | This file contains a LOT of instance declarations for making Base code compatible with SubHask type classes. -- There's very little code in here though. @@ -9,37 +13,20 @@ module SubHask.Compatibility.Base import Data.Typeable import qualified Prelude as Base -import qualified Control.Applicative as Base import qualified Control.Monad as Base -import Language.Haskell.TH -import Control.Arrow import Control.Monad.Identity (Identity(..)) -import Control.Monad.Reader (Reader,ReaderT) -import Control.Monad.State.Strict (State,StateT) -import Control.Monad.Trans -import Control.Monad.ST (ST) -import GHC.Conc.Sync -import GHC.GHCi -import Text.ParserCombinators.ReadP -import Text.ParserCombinators.ReadPrec - -import Control.Monad.Random +import Control.Monad.Reader (ReaderT) +import Control.Monad.State.Strict (StateT) import SubHask.Algebra import SubHask.Category import SubHask.Monad import SubHask.Internal.Prelude import SubHask.TemplateHaskell.Base -import SubHask.TemplateHaskell.Deriving - -------------------------------------------------------------------------------- -- bug fixes - --- required for GHCI to work because NoIO does not have a Base.Functor instance -instance Functor Hask NoIO where fmap = Base.liftM - -- these definitions are required for the corresponding types to be in scope in the TH code below; -- pretty sure this is a GHC bug dummy1 = undefined :: Identity a @@ -49,13 +36,9 @@ dummy3 = undefined :: ReaderT s m a -------------------------------------------------------------------------------- -- derive instances --- forAllInScope ''Base.Eq mkPreludeEq forAllInScope ''Base.Functor mkPreludeFunctor --- forAllInScope ''Base.Applicative mkPreludeApplicative forAllInScope ''Base.Monad mkPreludeMonad --------------------------------------------------------------------------------- - -- FIXME: -- Similar instances are not valid for all monads. -- For example, [] instance for Semigroup would be incompatible with the below definitions. @@ -70,24 +53,20 @@ instance Semigroup a => Semigroup (IO a) where instance Monoid a => Monoid (IO a) where zero = return zero --------------------------------------------------------------------------------- - type instance Logic TypeRep = Bool -instance Eq_ TypeRep where +instance Eq TypeRep where (==) = (Base.==) -instance POrd_ TypeRep where +instance POrd TypeRep where inf x y = case Base.compare x y of LT -> x _ -> y -instance Lattice_ TypeRep where +instance Lattice TypeRep where sup x y = case Base.compare x y of GT -> x _ -> y -instance Ord_ TypeRep where compare = Base.compare - ---------- +instance Ord TypeRep where compare = Base.compare mkMutable [t| forall a b. Either a b |] @@ -99,8 +78,6 @@ instance (Semigroup b) => Semigroup (Either a b) where instance (Monoid b) => Monoid (Either a b) where zero = Right zero ---------- - instance Base.Functor Maybe' where fmap = fmap @@ -108,11 +85,11 @@ instance Base.Applicative Maybe' instance Base.Monad Maybe' where return = Just' - Nothing' >>= f = Nothing' + Nothing' >>= _ = Nothing' (Just' a) >>= f = f a instance Functor Hask Maybe' where - fmap f Nothing' = Nothing' + fmap _ Nothing' = Nothing' fmap f (Just' a) = Just' $ f a instance Then Maybe' where diff --git a/src/SubHask/Compatibility/BloomFilter.hs b/src/SubHask/Compatibility/BloomFilter.hs index 1a9bb9f..b837221 100644 --- a/src/SubHask/Compatibility/BloomFilter.hs +++ b/src/SubHask/Compatibility/BloomFilter.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-missing-methods #-} + module SubHask.Compatibility.BloomFilter ( BloomFilter ) @@ -9,8 +11,6 @@ import SubHask.Internal.Prelude import qualified Data.BloomFilter as BF --------------------------------------------------------------------------------- - newtype BloomFilter (n::Nat) a = BloomFilter (BF.Bloom a) mkMutable [t| forall n a. BloomFilter n a |] @@ -21,13 +21,11 @@ type instance Logic (BloomFilter n a) = Bool type instance Elem (BloomFilter n a) = a type instance SetElem (BloomFilter n a) b = BloomFilter n b -hash = undefined - instance KnownNat n => Semigroup (BloomFilter n a) -- FIXME: need access to the underlying representation of BF.Bloom to implement instance KnownNat n => Monoid (BloomFilter n a) where - zero = BloomFilter (BF.empty hash n) + zero = BloomFilter (BF.empty undefined n) where n = fromInteger $ natVal (Proxy::Proxy n) diff --git a/src/SubHask/Compatibility/ByteString.hs b/src/SubHask/Compatibility/ByteString.hs index 34310b2..0562d4d 100644 --- a/src/SubHask/Compatibility/ByteString.hs +++ b/src/SubHask/Compatibility/ByteString.hs @@ -11,8 +11,6 @@ import SubHask.TemplateHaskell.Deriving import qualified Data.ByteString.Lazy.Char8 as BS import qualified Prelude as P --------------------------------------------------------------------------------- - -- | The type of lazy byte strings. -- -- FIXME: @@ -24,9 +22,6 @@ mkMutable [t| forall a. ByteString a |] type instance Scalar (ByteString b) = Int type instance Logic (ByteString b) = Bool type instance Elem (ByteString b) = b -type instance SetElem (ByteString b) c = ByteString c - ----------------------------------------- newtype instance ByteString Char = BSLC { unBSLC :: BS.ByteString } deriving (NFData,Read,Show) @@ -34,14 +29,14 @@ newtype instance ByteString Char = BSLC { unBSLC :: BS.ByteString } instance Arbitrary (ByteString Char) where arbitrary = fmap fromList arbitrary -instance Eq_ (ByteString Char) where +instance Eq (ByteString Char) where (BSLC b1)==(BSLC b2) = b1 P.== b2 -instance POrd_ (ByteString Char) where +instance POrd (ByteString Char) where inf (BSLC b1) (BSLC b2) = fromList $ map fst $ P.takeWhile (\(a,b) -> a==b) $ BS.zip b1 b2 (BSLC b1) < (BSLC b2) = BS.isPrefixOf b1 b2 -instance MinBound_ (ByteString Char) where +instance MinBound (ByteString Char) where minBound = zero instance Semigroup (ByteString Char) where @@ -64,15 +59,12 @@ instance Normed (ByteString Char) where instance Foldable (ByteString Char) where uncons (BSLC xs) = case BS.uncons xs of Nothing -> Nothing - Just (x,xs) -> Just (x,BSLC xs) + Just (x,xs') -> Just (x,BSLC xs') toList (BSLC xs) = BS.unpack xs foldr f a (BSLC xs) = BS.foldr f a xs --- foldr' f a (BSLC xs) = BS.foldr' f a xs foldr1 f (BSLC xs) = BS.foldr1 f xs --- foldr1' f (BSLC xs) = BS.foldr1' f xs - foldl f a (BSLC xs) = BS.foldl f a xs foldl' f a (BSLC xs) = BS.foldl' f a xs foldl1 f (BSLC xs) = BS.foldl1 f xs @@ -81,18 +73,16 @@ instance Foldable (ByteString Char) where instance Partitionable (ByteString Char) where partition n (BSLC xs) = go xs where - go xs = if BS.null xs + go xs' = if BS.null xs' then [] else BSLC a:go b where - (a,b) = BS.splitAt len xs + (a,b) = BS.splitAt len xs' n' = P.fromIntegral $ toInteger n - size = BS.length xs - len = size `P.div` n' - P.+ if size `P.rem` n' P.== (P.fromInteger 0) then P.fromInteger 0 else P.fromInteger 1 - --------------------------------------------------------------------------------- + size' = BS.length xs + len = size' `P.div` n' + P.+ if size' `P.rem` n' P.== (P.fromInteger 0) then P.fromInteger 0 else P.fromInteger 1 -- | -- @@ -101,8 +91,6 @@ instance Partitionable (ByteString Char) where readFileByteString :: FilePath -> IO (ByteString Char) readFileByteString = fmap BSLC . BS.readFile --------------------------------------------------------------------------------- - -- | FIXME: -- Make this generic by moving some of the BS functions into the Foldable/Unfoldable type classes. -- Then move this into Algebra.Containers @@ -115,7 +103,7 @@ instance (a~ByteString Char, Partitionable a) => Partitionable (PartitionOnNewli where go [] = [] go [x] = [x] - go (x1:x2:xs) = (x1+BSLC a):go (BSLC b:xs) + go (x1:x2:xs') = (x1+BSLC a):go (BSLC b:xs') where (a,b) = BS.break (=='\n') $ unBSLC x2 diff --git a/src/SubHask/Compatibility/Cassava.hs b/src/SubHask/Compatibility/Cassava.hs index c6aa548..6a683b5 100644 --- a/src/SubHask/Compatibility/Cassava.hs +++ b/src/SubHask/Compatibility/Cassava.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + module SubHask.Compatibility.Cassava ( decode_ , decode @@ -46,7 +48,6 @@ decode_ h (PartitionOnNewline (BSLC bs)) = case C.decode h bs of decode :: ( NFData a , FromRecord a - , ValidEq a ) => HasHeader -> ByteString Char -> Either String (BArray a) diff --git a/src/SubHask/Compatibility/Containers.hs b/src/SubHask/Compatibility/Containers.hs index 3fdced3..1dde0ca 100644 --- a/src/SubHask/Compatibility/Containers.hs +++ b/src/SubHask/Compatibility/Containers.hs @@ -19,10 +19,9 @@ import SubHask.Algebra.Parallel import SubHask.Category import SubHask.Category.Trans.Constrained import SubHask.Category.Trans.Monotonic -import SubHask.Compatibility.Base +import SubHask.Compatibility.Base() import SubHask.Internal.Prelude import SubHask.Monad -import SubHask.TemplateHaskell.Deriving ------------------------------------------------------------------------------- -- | This is a thin wrapper around Data.Sequence @@ -35,7 +34,6 @@ mkMutable [t| forall a. Seq a |] type instance Scalar (Seq a) = Int type instance Logic (Seq a) = Bool type instance Elem (Seq a) = a -type instance SetElem (Seq a) b = Seq b instance (Eq a, Arbitrary a) => Arbitrary (Seq a) where arbitrary = P.fmap fromList arbitrary @@ -44,15 +42,15 @@ instance Normed (Seq a) where {-# INLINE size #-} size (Seq s) = Seq.length s -instance Eq a => Eq_ (Seq a) where +instance (Eq a, ClassicalLogic a) => Eq (Seq a) where {-# INLINE (==) #-} (Seq a1)==(Seq a2) = F.toList a1==F.toList a2 -instance POrd a => POrd_ (Seq a) where +instance (POrd a, ClassicalLogic a) => POrd (Seq a) where {-# INLINE inf #-} inf a1 a2 = fromList $ inf (toList a1) (toList a2) -instance POrd a => MinBound_ (Seq a) where +instance (POrd a, ClassicalLogic a) => MinBound (Seq a) where {-# INLINE minBound #-} minBound = empty @@ -64,9 +62,9 @@ instance Monoid (Seq a) where {-# INLINE zero #-} zero = Seq $ Seq.empty -instance Eq a => Container (Seq a) where +instance (Eq a, ClassicalLogic a) => Container (Seq a) where {-# INLINE elem #-} - elem e (Seq a) = elem e $ F.toList a + elem a (Seq s) = elem a $ F.toList s {-# INLINE notElem #-} notElem = not elem @@ -76,13 +74,13 @@ instance Constructible (Seq a) where {-# INLINE snoc #-} {-# INLINE singleton #-} {-# INLINE fromList1 #-} - cons e (Seq a) = Seq $ e Seq.<| a - snoc (Seq a) e = Seq $ a Seq.|> e - singleton e = Seq $ Seq.singleton e + cons a (Seq s) = Seq $ a Seq.<| s + snoc (Seq s) a = Seq $ s Seq.|> a + singleton a = Seq $ Seq.singleton a fromList1 x xs = Seq $ Seq.fromList (x:xs) -instance ValidEq a => Foldable (Seq a) where +instance (Eq a, ClassicalLogic a) => Foldable (Seq a) where {-# INLINE toList #-} toList (Seq a) = F.toList a @@ -93,341 +91,338 @@ instance ValidEq a => Foldable (Seq a) where else Just (Seq.index a 0, Seq $ Seq.drop 1 a) {-# INLINE unsnoc #-} - unsnoc (Seq e) = if Seq.null e + unsnoc (Seq a) = if Seq.null a then Nothing - else Just (Seq $ Seq.take (Seq.length e-1) e, Seq.index e 0) - --- foldMap f (Seq a) = F.foldMap f a + else Just (Seq $ Seq.take (Seq.length a-1) a, Seq.index a 0) {-# INLINE foldr #-} {-# INLINE foldr' #-} {-# INLINE foldr1 #-} - foldr f e (Seq a) = F.foldr f e a - foldr' f e (Seq a) = F.foldr' f e a - foldr1 f (Seq a) = F.foldr1 f a --- foldr1' f (Seq a) = F.foldr1' f a + foldr f a (Seq s) = F.foldr f a s + foldr' f a (Seq s) = F.foldr' f a s + foldr1 f (Seq s) = F.foldr1 f s {-# INLINE foldl #-} {-# INLINE foldl' #-} {-# INLINE foldl1 #-} - foldl f e (Seq a) = F.foldl f e a - foldl' f e (Seq a) = F.foldl' f e a - foldl1 f (Seq a) = F.foldl1 f a --- foldl1' f (Seq a) = F.foldl1' f a + foldl f a (Seq s) = F.foldl f a s + foldl' f a (Seq s) = F.foldl' f a s + foldl1 f (Seq s) = F.foldl1 f s -instance (ValidEq a) => Partitionable (Seq a) where +instance (Eq a, ClassicalLogic a) => Partitionable (Seq a) where {-# INLINABLE partition #-} partition n (Seq xs) = go xs where go :: Seq.Seq a -> [Seq a] - go xs = if Seq.null xs + go xs' = if Seq.null xs' then [] else Seq a:go b where - (a,b) = Seq.splitAt len xs + (a,b) = Seq.splitAt len xs' - size = Seq.length xs - len = size `div` n - + if size `rem` n == 0 then 0 else 1 + size' = Seq.length xs + len = size' `div` n + + if size' `rem` n == 0 then 0 else 1 {-# INLINABLE partitionInterleaved #-} partitionInterleaved n xs = foldl' go (P.replicate n empty) xs where go (r:rs) x = rs+[r`snoc`x] + go [] _ = undefined ------------------------------------------------------------------------------- -- | This is a thin wrapper around Data.Map -newtype Map i e = Map (M.Map (WithPreludeOrd i) (WithPreludeOrd e)) +newtype Map b a = Map (M.Map (WithPreludeOrd b) (WithPreludeOrd a)) deriving (Show,NFData) -mkMutable [t| forall i e. Map i e |] +mkMutable [t| forall b a. Map b a |] -type instance Scalar (Map i e) = Int -type instance Logic (Map i e) = Bool -type instance Index (Map i e) = i -type instance SetIndex (Map i e) i' = Map i' e -type instance Elem (Map i e) = e -type instance SetElem (Map i e) e' = Map i e' +type instance Scalar (Map b a) = Int +type instance Logic (Map b a) = Bool +type instance Index (Map b a) = b +type instance SetIndex (Map b a) b' = Map b' a +type instance Elem (Map b a) = a -- misc classes -instance (Eq e, Ord i, Semigroup e, Arbitrary i, Arbitrary e) => Arbitrary (Map i e) where +instance (Eq a, Ord b, Arbitrary b, Arbitrary a, ClassicalLogic a, ClassicalLogic b) => Arbitrary (Map b a) where arbitrary = P.fmap fromIxList arbitrary -- comparisons -instance (Eq i, Eq e) => Eq_ (Map i e) where +instance (Eq b, Eq a, ClassicalLogic b, ClassicalLogic a) => Eq (Map b a) where {-# INLINE (==) #-} (Map m1)==(Map m2) = m1 P.== m2 -instance (Ord i, Eq e) => POrd_ (Map i e) where +instance (Ord b, Eq a, ClassicalLogic b, ClassicalLogic a) => POrd (Map b a) where {-# INLINE inf #-} inf (Map m1) (Map m2) = Map $ M.differenceWith go (M.intersection m1 m2) m2 where - go v1 v2 = if v1==v2 then Just v1 else Nothing + go :: forall b'. (ClassicalLogic b', Eq b') => b' -> b' -> Maybe b' + go a1 a2 = if a1==a2 then Just a1 else Nothing -instance (Ord i, POrd e) => MinBound_ (Map i e) where +instance (Ord b, POrd a, ClassicalLogic b, ClassicalLogic a) => MinBound (Map b a) where {-# INLINE minBound #-} minBound = zero -- algebra -instance Ord i => Semigroup (Map i e) where +instance (Ord b, ClassicalLogic b) => Semigroup (Map b a) where {-# INLINE (+) #-} (Map m1)+(Map m2) = Map $ M.union m1 m2 -instance Ord i => Monoid (Map i e) where +instance (Ord b, ClassicalLogic b) => Monoid (Map b a) where {-# INLINE zero #-} zero = Map $ M.empty -instance Normed (Map i e) where +instance Normed (Map b a) where {-# INLINE size #-} size (Map m) = M.size m -- indexed containers -instance (Ord i, Eq e) => IxContainer (Map i e) where +instance (Ord b, Eq a, ClassicalLogic b, ClassicalLogic a) => IxContainer (Map b a) where {-# INLINE lookup #-} {-# INLINE hasIndex #-} - lookup i (Map m) = P.fmap unWithPreludeOrd $ M.lookup (WithPreludeOrd i) m - hasIndex (Map m) i = M.member (WithPreludeOrd i) m + lookup b (Map m) = P.fmap unWithPreludeOrd $ M.lookup (WithPreludeOrd b) m + hasIndex (Map m) b = M.member (WithPreludeOrd b) m {-# INLINE toIxList #-} {-# INLINE indices #-} {-# INLINE values #-} {-# INLINE imap #-} - toIxList (Map m) = map (\(WithPreludeOrd i,WithPreludeOrd e)->(i,e)) $ M.assocs m + toIxList (Map m) = map (\(WithPreludeOrd b,WithPreludeOrd a)->(b,a)) $ M.assocs m indices (Map m) = map unWithPreludeOrd $ M.keys m values (Map m) = map unWithPreludeOrd $ M.elems m - imap f (Map m) = Map $ M.mapWithKey (\(WithPreludeOrd i) (WithPreludeOrd e) -> WithPreludeOrd $ f i e) m + imap f (Map m) = Map $ M.mapWithKey (\(WithPreludeOrd b) (WithPreludeOrd a) -> WithPreludeOrd $ f b a) m -instance (Ord i, Eq e) => IxConstructible (Map i e) where +instance (Ord b, Eq a, ClassicalLogic b, ClassicalLogic a) => IxConstructible (Map b a) where {-# INLINE singletonAt #-} - singletonAt i e = Map $ M.singleton (WithPreludeOrd i) (WithPreludeOrd e) + singletonAt b a = Map $ M.singleton (WithPreludeOrd b) (WithPreludeOrd a) {-# INLINE consAt #-} - consAt i e (Map m) = Map $ M.insert (WithPreludeOrd i) (WithPreludeOrd e) m + consAt b a (Map m) = Map $ M.insert (WithPreludeOrd b) (WithPreludeOrd a) m ---------------------------------------- -- | This is a thin wrapper around Data.Map.Strict -newtype Map' i e = Map' (MS.Map (WithPreludeOrd i) (WithPreludeOrd e)) +newtype Map' b a = Map' (MS.Map (WithPreludeOrd b) (WithPreludeOrd a)) deriving (Show,NFData) -mkMutable [t| forall i e. Map' i e |] +mkMutable [t| forall b a. Map' b a |] -type instance Scalar (Map' i e) = Int -type instance Logic (Map' i e) = Bool -type instance Index (Map' i e) = i -type instance SetIndex (Map' i e) i' = Map' i' e -type instance Elem (Map' i e) = e -type instance SetElem (Map' i e) e' = Map' i e' +type instance Scalar (Map' b a) = Int +type instance Logic (Map' b a) = Bool +type instance Index (Map' b a) = b +type instance SetIndex (Map' b a) b' = Map' b' a +type instance Elem (Map' b a) = a -- misc classes -instance (Eq e, Ord i, Semigroup e, Arbitrary i, Arbitrary e) => Arbitrary (Map' i e) where +instance (Eq a, Ord b, Arbitrary b, Arbitrary a, ClassicalLogic a, ClassicalLogic b) => Arbitrary (Map' b a) where arbitrary = P.fmap fromIxList arbitrary -- comparisons -instance (Eq i, Eq e) => Eq_ (Map' i e) where +instance (Eq b, Eq a, ClassicalLogic a, ClassicalLogic b) => Eq (Map' b a) where {-# INLINE (==) #-} (Map' m1)==(Map' m2) = m1 P.== m2 -instance (Ord i, Eq e) => POrd_ (Map' i e) where +instance (Ord b, Eq a, ClassicalLogic a, ClassicalLogic b) => POrd (Map' b a) where {-# INLINE inf #-} inf (Map' m1) (Map' m2) = Map' $ MS.differenceWith go (MS.intersection m1 m2) m2 where - go v1 v2 = if v1==v2 then Just v1 else Nothing + go :: forall b'. (ClassicalLogic b', Eq b') => b' -> b' -> Maybe b' + go a1 a2 = if a1==a2 then Just a1 else Nothing -instance (Ord i, POrd e) => MinBound_ (Map' i e) where +instance (Ord b, POrd a, ClassicalLogic a, ClassicalLogic b) => MinBound (Map' b a) where {-# INLINE minBound #-} minBound = zero -- algebra -instance Ord i => Semigroup (Map' i e) where +instance (Ord b, ClassicalLogic b) => Semigroup (Map' b a) where {-# INLINE (+) #-} (Map' m1)+(Map' m2) = Map' $ MS.union m1 m2 -instance Ord i => Monoid (Map' i e) where +instance (Ord b, ClassicalLogic b) => Monoid (Map' b a) where {-# INLINE zero #-} zero = Map' $ MS.empty -instance Normed (Map' i e) where +instance Normed (Map' b a) where {-# INLINE size #-} size (Map' m) = MS.size m -- indexed containers -instance (Ord i, Eq e) => IxContainer (Map' i e) where +instance (Ord b, Eq a, ClassicalLogic a, ClassicalLogic b) => IxContainer (Map' b a) where {-# INLINE lookup #-} {-# INLINE hasIndex #-} - lookup i (Map' m) = P.fmap unWithPreludeOrd $ MS.lookup (WithPreludeOrd i) m - hasIndex (Map' m) i = MS.member (WithPreludeOrd i) m + lookup b (Map' m) = P.fmap unWithPreludeOrd $ MS.lookup (WithPreludeOrd b) m + hasIndex (Map' m) b = MS.member (WithPreludeOrd b) m {-# INLINE toIxList #-} {-# INLINE indices #-} {-# INLINE values #-} {-# INLINE imap #-} - toIxList (Map' m) = map (\(WithPreludeOrd i,WithPreludeOrd e)->(i,e)) $ MS.assocs m + toIxList (Map' m) = map (\(WithPreludeOrd b,WithPreludeOrd a)->(b,a)) $ MS.assocs m indices (Map' m) = map unWithPreludeOrd $ MS.keys m values (Map' m) = map unWithPreludeOrd $ MS.elems m - imap f (Map' m) = Map' $ MS.mapWithKey (\(WithPreludeOrd i) (WithPreludeOrd e) -> WithPreludeOrd $ f i e) m + imap f (Map' m) = Map' $ MS.mapWithKey (\(WithPreludeOrd b) (WithPreludeOrd a) -> WithPreludeOrd $ f b a) m -instance (Ord i, Eq e) => IxConstructible (Map' i e) where +instance (Ord b, Eq a, ClassicalLogic a, ClassicalLogic b) => IxConstructible (Map' b a) where {-# INLINE singletonAt #-} - singletonAt i e = Map' $ MS.singleton (WithPreludeOrd i) (WithPreludeOrd e) + singletonAt b a = Map' $ MS.singleton (WithPreludeOrd b) (WithPreludeOrd a) {-# INLINE consAt #-} - consAt i e (Map' m) = Map' $ MS.insert (WithPreludeOrd i) (WithPreludeOrd e) m + consAt b a (Map' m) = Map' $ MS.insert (WithPreludeOrd b) (WithPreludeOrd a) m ------------------------------------------------------------------------------- -- | This is a thin wrapper around Data.IntMap -newtype IntMap e = IntMap (IM.IntMap (WithPreludeOrd e)) +newtype IntMap a = IntMap (IM.IntMap (WithPreludeOrd a)) deriving (Read,Show,NFData) mkMutable [t| forall a. IntMap a |] -type instance Scalar (IntMap e) = Int -type instance Logic (IntMap e) = Bool -type instance Index (IntMap e) = IM.Key -type instance Elem (IntMap e) = e -type instance SetElem (IntMap e) e' = IntMap e' +type instance Scalar (IntMap a) = Int +type instance Logic (IntMap a) = Bool +type instance Index (IntMap a) = IM.Key +type instance Elem (IntMap a) = a -- misc classes -instance (Eq e, Semigroup e, Arbitrary e) => Arbitrary (IntMap e) where +instance (Eq a, Arbitrary a, ClassicalLogic a) => Arbitrary (IntMap a) where {-# INLINABLE arbitrary #-} arbitrary = P.fmap fromIxList arbitrary -- comparisons -instance (Eq e) => Eq_ (IntMap e) where +instance (Eq a, ClassicalLogic a) => Eq (IntMap a) where {-# INLINE (==) #-} (IntMap m1)==(IntMap m2) = m1 P.== m2 -instance (Eq e) => POrd_ (IntMap e) where +instance (Eq a, ClassicalLogic a) => POrd (IntMap a) where {-# INLINE inf #-} inf (IntMap m1) (IntMap m2) = IntMap $ IM.differenceWith go (IM.intersection m1 m2) m2 where - go v1 v2 = if v1==v2 then Just v1 else Nothing + go :: forall b. (ClassicalLogic b, Eq b) => b -> b -> Maybe b + go a1 a2 = if a1==a2 then Just a1 else Nothing -instance (POrd e) => MinBound_ (IntMap e) where +instance (POrd a, ClassicalLogic a) => MinBound (IntMap a) where {-# INLINE minBound #-} minBound = zero -- algebra -instance Semigroup (IntMap e) where +instance Semigroup (IntMap a) where {-# INLINE (+) #-} (IntMap m1)+(IntMap m2) = IntMap $ IM.union m1 m2 -instance Monoid (IntMap e) where +instance Monoid (IntMap a) where {-# INLINE zero #-} zero = IntMap $ IM.empty -instance Normed (IntMap e) where +instance Normed (IntMap a) where {-# INLINE size #-} size (IntMap m) = IM.size m -- indexed container -instance (Eq e) => IxConstructible (IntMap e) where +instance (Eq a, ClassicalLogic a) => IxConstructible (IntMap a) where {-# INLINE singletonAt #-} {-# INLINE consAt #-} - singletonAt i e = IntMap $ IM.singleton i (WithPreludeOrd e) - consAt i e (IntMap m) = IntMap $ IM.insert i (WithPreludeOrd e) m + singletonAt b a = IntMap $ IM.singleton b (WithPreludeOrd a) + consAt b a (IntMap m) = IntMap $ IM.insert b (WithPreludeOrd a) m -instance (Eq e) => IxContainer (IntMap e) where +instance (Eq a, ClassicalLogic a) => IxContainer (IntMap a) where {-# INLINE lookup #-} {-# INLINE hasIndex #-} - lookup i (IntMap m) = P.fmap unWithPreludeOrd $ IM.lookup i m - hasIndex (IntMap m) i = IM.member i m + lookup b (IntMap m) = P.fmap unWithPreludeOrd $ IM.lookup b m + hasIndex (IntMap m) b = IM.member b m {-# INLINE toIxList #-} {-# INLINE indices #-} {-# INLINE values #-} {-# INLINE imap #-} - toIxList (IntMap m) = map (\(i,WithPreludeOrd e)->(i,e)) $ IM.assocs m + toIxList (IntMap m) = map (\(b,WithPreludeOrd a)->(b,a)) $ IM.assocs m indices (IntMap m) = IM.keys m values (IntMap m) = map unWithPreludeOrd $ IM.elems m - imap f (IntMap m) = IntMap $ IM.mapWithKey (\i (WithPreludeOrd e) -> WithPreludeOrd $ f i e) m + imap f (IntMap m) = IntMap $ IM.mapWithKey (\b (WithPreludeOrd a) -> WithPreludeOrd $ f b a) m ---------------------------------------- -- | This is a thin wrapper around Data.IntMap.Strict -newtype IntMap' e = IntMap' (IMS.IntMap (WithPreludeOrd e)) +newtype IntMap' a = IntMap' (IMS.IntMap (WithPreludeOrd a)) deriving (Read,Show,NFData) mkMutable [t| forall a. IntMap' a |] -type instance Scalar (IntMap' e) = Int -type instance Logic (IntMap' e) = Bool -type instance Index (IntMap' e) = IMS.Key -type instance Elem (IntMap' e) = e -type instance SetElem (IntMap' e) e' = IntMap' e' +type instance Scalar (IntMap' a) = Int +type instance Logic (IntMap' a) = Bool +type instance Index (IntMap' a) = IMS.Key +type instance Elem (IntMap' a) = a -- misc classes -instance (Eq e, Semigroup e, Arbitrary e) => Arbitrary (IntMap' e) where +instance (Eq a, Arbitrary a, ClassicalLogic a) => Arbitrary (IntMap' a) where {-# INLINABLE arbitrary #-} arbitrary = P.fmap fromIxList arbitrary -- comparisons -instance (Eq e) => Eq_ (IntMap' e) where +instance (Eq a, ClassicalLogic a) => Eq (IntMap' a) where {-# INLINE (==) #-} (IntMap' m1)==(IntMap' m2) = m1 P.== m2 -instance (Eq e) => POrd_ (IntMap' e) where +instance (Eq a, ClassicalLogic a) => POrd (IntMap' a) where {-# INLINE inf #-} inf (IntMap' m1) (IntMap' m2) = IntMap' $ IMS.differenceWith go (IMS.intersection m1 m2) m2 where - go v1 v2 = if v1==v2 then Just v1 else Nothing + go :: forall b. (ClassicalLogic b, Eq b) => b -> b -> Maybe b + go a1 a2 = if a1==a2 then Just a1 else Nothing -instance (POrd e) => MinBound_ (IntMap' e) where +instance (POrd a, ClassicalLogic a) => MinBound (IntMap' a) where {-# INLINE minBound #-} minBound = zero -- algebra -instance Semigroup (IntMap' e) where +instance Semigroup (IntMap' a) where {-# INLINE (+) #-} (IntMap' m1)+(IntMap' m2) = IntMap' $ IMS.union m1 m2 -instance Monoid (IntMap' e) where +instance Monoid (IntMap' a) where {-# INLINE zero #-} zero = IntMap' $ IMS.empty -instance Normed (IntMap' e) where +instance Normed (IntMap' a) where {-# INLINE size #-} size (IntMap' m) = IMS.size m -- container -instance (Eq e) => IxConstructible (IntMap' e) where +instance (Eq a, ClassicalLogic a) => IxConstructible (IntMap' a) where {-# INLINABLE singletonAt #-} {-# INLINABLE consAt #-} - singletonAt i e = IntMap' $ IMS.singleton i (WithPreludeOrd e) - consAt i e (IntMap' m) = IntMap' $ IMS.insert i (WithPreludeOrd e) m + singletonAt b a = IntMap' $ IMS.singleton b (WithPreludeOrd a) + consAt b a (IntMap' m) = IntMap' $ IMS.insert b (WithPreludeOrd a) m -instance (Eq e) => IxContainer (IntMap' e) where +instance (Eq a, ClassicalLogic a) => IxContainer (IntMap' a) where {-# INLINE lookup #-} {-# INLINE hasIndex #-} - lookup i (IntMap' m) = P.fmap unWithPreludeOrd $ IMS.lookup i m - hasIndex (IntMap' m) i = IMS.member i m + lookup b (IntMap' m) = P.fmap unWithPreludeOrd $ IMS.lookup b m + hasIndex (IntMap' m) b = IMS.member b m {-# INLINE toIxList #-} {-# INLINE indices #-} {-# INLINE values #-} {-# INLINE imap #-} - toIxList (IntMap' m) = map (\(i,WithPreludeOrd e)->(i,e)) $ IMS.assocs m + toIxList (IntMap' m) = map (\(b,WithPreludeOrd a)->(b,a)) $ IMS.assocs m indices (IntMap' m) = IMS.keys m values (IntMap' m) = map unWithPreludeOrd $ IMS.elems m - imap f (IntMap' m) = IntMap' $ IMS.mapWithKey (\i (WithPreludeOrd e) -> WithPreludeOrd $ f i e) m + imap f (IntMap' m) = IntMap' $ IMS.mapWithKey (\b (WithPreludeOrd a) -> WithPreludeOrd $ f b a) m ------------------------------------------------------------------------------- -- | This is a thin wrapper around the container's set type @@ -437,20 +432,19 @@ newtype Set a = Set (Set.Set (WithPreludeOrd a)) mkMutable [t| forall a. Set a |] -instance (Ord a, Arbitrary a) => Arbitrary (Set a) where +instance (Ord a, Arbitrary a, ClassicalLogic a) => Arbitrary (Set a) where {-# INLINABLE arbitrary #-} arbitrary = P.fmap fromList arbitrary type instance Scalar (Set a) = Int type instance Logic (Set a) = Logic a type instance Elem (Set a) = a -type instance SetElem (Set a) b = Set b instance Normed (Set a) where {-# INLINE size #-} size (Set s) = Set.size s -instance Eq a => Eq_ (Set a) where +instance (Eq a, ClassicalLogic a) => Eq (Set a) where {-# INLINE (==) #-} (Set s1)==(Set s2) = s1'==s2' where @@ -459,52 +453,50 @@ instance Eq a => Eq_ (Set a) where removeWithPreludeOrd [] = [] removeWithPreludeOrd (WithPreludeOrd x:xs) = x:removeWithPreludeOrd xs -instance Ord a => POrd_ (Set a) where +instance (Ord a, ClassicalLogic a) => POrd (Set a) where {-# INLINE inf #-} inf (Set s1) (Set s2) = Set $ Set.intersection s1 s2 -instance Ord a => MinBound_ (Set a) where +instance (Ord a, ClassicalLogic a) => MinBound (Set a) where {-# INLINE minBound #-} minBound = Set $ Set.empty -instance Ord a => Lattice_ (Set a) where +instance (Ord a, ClassicalLogic a) => Lattice (Set a) where {-# INLINE sup #-} sup (Set s1) (Set s2) = Set $ Set.union s1 s2 -instance Ord a => Semigroup (Set a) where +instance (Ord a, ClassicalLogic a) => Semigroup (Set a) where {-# INLINE (+) #-} (Set s1)+(Set s2) = Set $ Set.union s1 s2 -instance Ord a => Monoid (Set a) where +instance (Ord a, ClassicalLogic a) => Monoid (Set a) where {-# INLINE zero #-} zero = Set $ Set.empty -instance Ord a => Abelian (Set a) +instance (Ord a, ClassicalLogic a) => Abelian (Set a) -instance Ord a => Container (Set a) where +instance (Ord a, ClassicalLogic a) => Container (Set a) where {-# INLINE elem #-} {-# INLINE notElem #-} elem a (Set s) = Set.member (WithPreludeOrd a) s notElem a (Set s) = not $ Set.member (WithPreludeOrd a) s -instance Ord a => Constructible (Set a) where +instance (Ord a, ClassicalLogic a) => Constructible (Set a) where {-# INLINE singleton #-} singleton a = Set $ Set.singleton (WithPreludeOrd a) {-# INLINE fromList1 #-} fromList1 a as = Set $ Set.fromList $ map WithPreludeOrd (a:as) -instance Ord a => Foldable (Set a) where +instance (Ord a, ClassicalLogic a) => Foldable (Set a) where {-# INLINE foldl #-} {-# INLINE foldl' #-} {-# INLINE foldr #-} {-# INLINE foldr' #-} - foldl f a (Set s) = Set.foldl (\a (WithPreludeOrd e) -> f a e) a s - foldl' f a (Set s) = Set.foldl' (\a (WithPreludeOrd e) -> f a e) a s - foldr f a (Set s) = Set.foldr (\(WithPreludeOrd e) a -> f e a) a s - foldr' f a (Set s) = Set.foldr' (\(WithPreludeOrd e) a -> f e a) a s - -------------------- + foldl f a (Set s) = Set.foldl (\a1 (WithPreludeOrd a2) -> f a1 a2) a s + foldl' f a (Set s) = Set.foldl' (\a1 (WithPreludeOrd a2) -> f a1 a2) a s + foldr f a (Set s) = Set.foldr (\(WithPreludeOrd a1) a2 -> f a1 a2) a s + foldr' f a (Set s) = Set.foldr' (\(WithPreludeOrd a1) a2 -> f a1 a2) a s -- | -- @@ -512,52 +504,51 @@ instance Ord a => Foldable (Set a) where -- -- FIXME: add the @Constrained@ Monad data LexSet a where - LexSet :: Ord a => Set a -> LexSet a + LexSet :: (Ord a, ClassicalLogic a) => Set a -> LexSet a mkMutable [t| forall a. LexSet a |] type instance Scalar (LexSet a) = Int type instance Logic (LexSet a) = Bool type instance Elem (LexSet a) = a -type instance SetElem (LexSet a) b = LexSet b instance Show a => Show (LexSet a) where show (LexSet s) = "LexSet "++show (toList s) -instance Eq_ (LexSet a) where +instance Eq (LexSet a) where (LexSet a1)==(LexSet a2) = Lexical a1==Lexical a2 -instance POrd_ (LexSet a) where +instance POrd (LexSet a) where inf (LexSet a1) (LexSet a2) = LexSet $ unLexical $ inf (Lexical a1) (Lexical a2) (LexSet a1) < (LexSet a2) = Lexical a1 < Lexical a2 (LexSet a1) <= (LexSet a2) = Lexical a1 <= Lexical a2 -instance Lattice_ (LexSet a) where +instance Lattice (LexSet a) where sup (LexSet a1) (LexSet a2) = LexSet $ unLexical $ sup (Lexical a1) (Lexical a2) (LexSet a1) > (LexSet a2) = Lexical a1 > Lexical a2 (LexSet a1) >= (LexSet a2) = Lexical a1 >= Lexical a2 -instance Ord_ (LexSet a) +instance Ord (LexSet a) instance Semigroup (LexSet a) where (LexSet a1)+(LexSet a2) = LexSet $ a1+a2 -instance Ord a => Monoid (LexSet a) where +instance (Ord a, ClassicalLogic a) => Monoid (LexSet a) where zero = LexSet zero -instance (Ord a ) => Container (LexSet a) where +instance (Ord a, ClassicalLogic a) => Container (LexSet a) where elem x (LexSet s) = elem x s -instance (Ord a ) => Constructible (LexSet a) where +instance (Ord a, ClassicalLogic a) => Constructible (LexSet a) where fromList1 a as = LexSet $ fromList1 a as -instance (Ord a ) => Normed (LexSet a) where +instance (Ord a, ClassicalLogic a) => Normed (LexSet a) where size (LexSet s) = size s -instance (Ord a ) => MinBound_ (LexSet a) where +instance (Ord a, ClassicalLogic a) => MinBound (LexSet a) where minBound = zero -instance (Ord a ) => Foldable (LexSet a) where +instance (Ord a, ClassicalLogic a) => Foldable (LexSet a) where foldl f a (LexSet s) = foldl f a s foldl' f a (LexSet s) = foldl' f a s foldl1 f (LexSet s) = foldl1 f s @@ -590,6 +581,4 @@ instance Monad Mon LexSet where join = unsafeProveMon $ \(LexSet s) -> foldl1' (+) s instance Then LexSet where - (LexSet a)>>(LexSet b) = LexSet b - - + (LexSet _)>>(LexSet b) = LexSet b diff --git a/src/SubHask/Compatibility/HyperLogLog.hs b/src/SubHask/Compatibility/HyperLogLog.hs index 8e4de58..876dd08 100644 --- a/src/SubHask/Compatibility/HyperLogLog.hs +++ b/src/SubHask/Compatibility/HyperLogLog.hs @@ -17,8 +17,6 @@ import qualified Control.Lens as L type instance Scalar Int64 = Int64 --------------------------------------------------------------------------------- - newtype HyperLogLog p a = H (H.HyperLogLog p) mkMutable [t| forall p a. HyperLogLog p a |] diff --git a/src/SubHask/Internal/Box.hs b/src/SubHask/Internal/Box.hs deleted file mode 100644 index a3cdba2..0000000 --- a/src/SubHask/Internal/Box.hs +++ /dev/null @@ -1,4 +0,0 @@ -module SubHask.Internal.Box - where - -data Box a = Box a diff --git a/src/SubHask/Internal/Prelude.hs b/src/SubHask/Internal/Prelude.hs index 60a7d86..b68773f 100644 --- a/src/SubHask/Internal/Prelude.hs +++ b/src/SubHask/Internal/Prelude.hs @@ -4,7 +4,6 @@ module SubHask.Internal.Prelude Show (..) , Read (..) , read - , Storable (..) -- * data types @@ -30,10 +29,8 @@ module SubHask.Internal.Prelude -- * Prelude functions , build , (++) - , Prelude.all , map - , asTypeOf , undefined , otherwise @@ -42,7 +39,6 @@ module SubHask.Internal.Prelude -- * subhask functions , assert - , ifThenElse -- * Modules , module Control.DeepSeq @@ -50,8 +46,6 @@ module SubHask.Internal.Prelude , module Data.Typeable , module GHC.TypeLits - -- * Non-Prelude types - -- ** QuickCheck , Arbitrary (..) , CoArbitrary (..) @@ -64,12 +58,9 @@ module SubHask.Internal.Prelude import Control.DeepSeq import Control.Monad.ST -import Data.Foldable -import Data.List (foldl, foldl', foldr, foldl1, foldl1', foldr1, map, (++), intersectBy, unionBy ) import Data.Maybe import Data.Typeable import Data.Proxy -import Data.Traversable import GHC.TypeLits import GHC.Exts import GHC.Int @@ -77,19 +68,12 @@ import Prelude import Test.QuickCheck.Arbitrary import Foreign.Storable -{-# INLINE ifThenElse #-} --- ifThenElse a b c = if a then b else c -ifThenElse a b c = case a of - True -> b - False -> c - -- | -- -- FIXME: -- Move to a better spot -- Add rewrite rules to remove with optimization -O assert :: String -> Bool -> a -> a -assert str b = if b - then id - else error $ "ASSERT FAILED: "++str +assert _ True = id +assert str False = error $ "ASSERT FAILED: "++str diff --git a/src/SubHask/Monad.hs b/src/SubHask/Monad.hs index bac5f3f..e8c4e8c 100644 --- a/src/SubHask/Monad.hs +++ b/src/SubHask/Monad.hs @@ -2,7 +2,6 @@ module SubHask.Monad where -import qualified Prelude as P import Prelude (replicate, zipWith, unzip) import SubHask.Algebra @@ -90,6 +89,7 @@ class (Then m, Functor cat m) => Monad cat m where (>=>) :: cat a (m b) -> cat b (m c) -> cat a (m c) (>=>) = flip (<=<) +fail :: String -> a fail = error -------------------------------------------------------------------------------- diff --git a/src/SubHask/Mutable.hs b/src/SubHask/Mutable.hs index 9ec6df7..5f0618f 100644 --- a/src/SubHask/Mutable.hs +++ b/src/SubHask/Mutable.hs @@ -35,7 +35,6 @@ import Prelude (($),(.)) import Control.Monad import Control.Monad.Primitive import Control.Monad.ST -import Data.Primitive import Data.PrimRef import System.IO.Unsafe diff --git a/src/SubHask/SubType.hs b/src/SubHask/SubType.hs index bd32f02..df9cebd 100644 --- a/src/SubHask/SubType.hs +++ b/src/SubHask/SubType.hs @@ -1,43 +1,35 @@ {-# LANGUAGE NoAutoDeriveTypeable #-} -- can't derive typeable of data families +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -- | This module defines the subtyping mechanisms used in subhask. module SubHask.SubType - ( (<:) (..) + ( type (<:) (..) , Sup --- , toRational - -- ** , Embed (..) , embedType , embedType1 , embedType2 --- , Embed0 (..) --- , Embed1 (..) --- , Embed2 (..) + , apEmbedType1 + , apEmbedType2 -- * Template Haskell , mkSubtype , mkSubtypeInstance + + , law_Subtype_f1 + , law_Subtype_f2 ) where import Control.Monad import Language.Haskell.TH -import Language.Haskell.TH.Quote --- import Language.Haskell.Meta import SubHask.Internal.Prelude import Prelude ------------------------------------------------------------------------------- --- common helper functions - -toRational :: (a <: Rational) => a -> Rational -toRational = embedType - -------------------------------------------------------------------------------- - -- | Subtypes are partially ordered. -- Unfortunately, there's no way to use the machinery of the "POrd"/"Lattice" classes. -- The "Sup" type family is a promotion of the "sup" function to the type level. @@ -123,16 +115,16 @@ law_Subtype_f2 _ b f a1 a2 = embedType (f a1 a2) == f (embedType a1) (embedType ------------------- type family a == b :: Bool where - a == a = True - a == b = False + a == a = 'True + a == b = 'False type family If (a::Bool) (b::k) (c::k) :: k where - If True b c = b - If False b c = c + If 'True b c = b + If 'False b c = c type family When (a::Bool) (b::Constraint) :: Constraint where - When True b = b - When False b = () + When 'True b = b + When 'False b = () ------------------- @@ -182,6 +174,7 @@ stripForall (AppT t1 t2) = AppT (stripForall t1) (stripForall t2) -- FIXME: What if the type doesn't have kind *? mkSubtypeInstance :: Type -> Type -> Name -> Dec mkSubtypeInstance t1 t2 f = InstanceD + Nothing [] ( AppT ( AppT @@ -213,6 +206,6 @@ mkSubtypeInstance t1 t2 f = InstanceD -- mkSup :: Type -> Type -> Type -> [Dec] mkSup t1 t2 t3 = - [ InstanceD [] (AppT (AppT (AppT (ConT $ mkName "Sup") t1) t2) t3) [] - , InstanceD [] (AppT (AppT (AppT (ConT $ mkName "Sup") t2) t1) t3) [] + [ InstanceD Nothing [] (AppT (AppT (AppT (ConT $ mkName "Sup") t1) t2) t3) [] + , InstanceD Nothing [] (AppT (AppT (AppT (ConT $ mkName "Sup") t2) t1) t3) [] ] diff --git a/src/SubHask/TemplateHaskell/Base.hs b/src/SubHask/TemplateHaskell/Base.hs index 1d1df43..3e34bd1 100644 --- a/src/SubHask/TemplateHaskell/Base.hs +++ b/src/SubHask/TemplateHaskell/Base.hs @@ -1,4 +1,6 @@ {-# LANGUAGE NoRebindableSyntax #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- | This file contains the template haskell code for deriving SubHask class instances from Base instances. -- All of the standard instances are created in "SubHask.Compatibility.Base". @@ -17,29 +19,25 @@ module SubHask.TemplateHaskell.Base where import qualified Prelude as Base -import qualified Control.Applicative as Base import qualified Control.Monad as Base import Language.Haskell.TH -import System.IO import SubHask.Category import SubHask.Algebra import SubHask.Monad import SubHask.Internal.Prelude -import Debug.Trace - -------------------------------------------------------------------------------- -- We need these instances to get anything done type instance Logic Name = Bool -instance Eq_ Name where (==) = (Base.==) +instance Eq Name where (==) = (Base.==) type instance Logic Dec = Bool -instance Eq_ Dec where (==) = (Base.==) +instance Eq Dec where (==) = (Base.==) type instance Logic Type = Bool -instance Eq_ Type where (==) = (Base.==) +instance Eq Type where (==) = (Base.==) -------------------------------------------------------------------------------- -- generic helper functions @@ -64,9 +62,9 @@ forAllInScope preludename f = do case info of ClassI _ xs -> Base.liftM concat $ Base.sequence $ map mgo $ Base.filter fgo xs where - mgo (InstanceD ctx (AppT _ t) _) = f ctx (Base.return t) + mgo (InstanceD _ ctx (AppT _ t) _) = f ctx (Base.return t) - fgo (InstanceD _ (AppT _ t) _ ) = not elem '>' $ show t + fgo (InstanceD _ _ (AppT _ t) _ ) = not elem '>' $ show t -- | This is an internal helper function. -- It prevents us from defining two instances for the same class/type pair. @@ -74,12 +72,12 @@ runIfNotInstance :: Name -> Type -> Q [Dec] -> Q [Dec] runIfNotInstance n t q = do inst <- alreadyInstance n t if inst - then trace ("skipping instance: "++show n++" / "++show t) $ Base.return [] - else trace ("deriving instance: "++show n++" / "++show t) $ q + then {-trace ("skipping instance: "++show n++" / "++show t) $-} Base.return [] + else {-trace ("deriving instance: "++show n++" / "++show t) $-} q where alreadyInstance :: Name -> Type -> Q Bool - alreadyInstance n t = do - info <- reify n + alreadyInstance n' _ = do + info <- reify n' Base.return $ case info of ClassI _ xs -> or $ map (genericTypeEq t.rmInstanceD) xs @@ -96,7 +94,7 @@ runIfNotInstance n t q = do genericTypeEq _ _ = false - rmInstanceD (InstanceD _ (AppT _ t) _) = t + rmInstanceD (InstanceD _ _ (AppT _ t') _) = t' -------------------------------------------------------------------------------- -- comparison hierarchy @@ -105,7 +103,7 @@ runIfNotInstance n t q = do mkPreludeEq :: Cxt -> Q Type -> Q [Dec] mkPreludeEq ctx qt = do t <- qt - runIfNotInstance ''Eq_ t $ Base.return + runIfNotInstance ''Eq t $ Base.return [ TySynInstD ( mkName "Logic" ) ( TySynEqn @@ -113,8 +111,9 @@ mkPreludeEq ctx qt = do ( ConT $ mkName "Bool" ) ) , InstanceD + Nothing ctx - ( AppT ( ConT $ mkName "Eq_" ) t ) + ( AppT ( ConT $ mkName "Eq" ) t ) [ FunD ( mkName "==" ) [ Clause [] (NormalB $ VarE $ mkName "Base.==") [] ] ] ] @@ -122,13 +121,13 @@ mkPreludeEq ctx qt = do -------------------------------------------------------------------------------- -- monad hierarchy - -- | Create a "Functor" instance from a "Prelude.Functor" instance. mkPreludeFunctor :: Cxt -> Q Type -> Q [Dec] mkPreludeFunctor ctx qt = do t <- qt runIfNotInstance ''Functor t $ Base.return [ InstanceD + Nothing ctx ( AppT ( AppT @@ -143,11 +142,12 @@ mkPreludeFunctor ctx qt = do -- | Create an "Applicative" instance from a "Prelude.Applicative" instance. mkPreludeApplicative :: Cxt -> Q Type -> Q [Dec] -mkPreludeApplicative cxt qt = do +mkPreludeApplicative cxt' qt = do t <- qt runIfNotInstance ''Applicative t $ Base.return [ InstanceD - cxt + Nothing + cxt' ( AppT ( AppT ( ConT $ mkName "Applicative" ) @@ -165,16 +165,17 @@ mkPreludeApplicative cxt qt = do -- FIXME: -- Monad transformers still require their parameter monad to be an instance of "Prelude.Monad". mkPreludeMonad :: Cxt -> Q Type -> Q [Dec] -mkPreludeMonad cxt qt = do +mkPreludeMonad cxt' qt = do t <- qt -- can't call -- > runIfNotInstance ''Monad t $ -- due to lack of TH support for type families - trace ("deriving instance: Monad / "++show t) $ if cannotDeriveMonad t + if cannotDeriveMonad t then Base.return [] else Base.return [ InstanceD - cxt + Nothing + cxt' ( AppT ( ConT $ mkName "Then" ) t @@ -182,8 +183,8 @@ mkPreludeMonad cxt qt = do [ FunD ( mkName ">>" ) [ Clause [] (NormalB $ VarE $ mkName "Base.>>") [] ] ] , InstanceD --- ( ClassP ''Functor [ ConT ''Hask , t ] : cxt ) - ( AppT (AppT (ConT ''Functor) (ConT ''Hask)) t : cxt ) + Nothing + ( AppT (AppT (ConT ''Functor) (ConT ''Hask)) t : cxt' ) ( AppT ( AppT ( ConT $ mkName "Monad" ) @@ -202,10 +203,10 @@ mkPreludeMonad cxt qt = do where -- | This helper function "filters out" monads for which we can't automatically derive an implementation. -- This failure can be due to missing Functor instances or weird type errors. - cannotDeriveMonad t = elem (show $ getName t) badmonad + cannotDeriveMonad t' = elem (show $ getName t') badmonad where getName :: Type -> Name - getName t = case t of + getName t'' = case t'' of (ConT t) -> t ListT -> mkName "[]" (SigT t _) -> getName t @@ -215,10 +216,12 @@ mkPreludeMonad cxt qt = do (AppT (AppT (AppT (AppT (ConT t) _) _) _) _) -> t (AppT (AppT (AppT (AppT (AppT (ConT t) _) _) _) _) _) -> t (AppT (AppT (AppT (AppT (AppT (AppT (ConT t) _) _) _) _) _) _) -> t - t -> error ("cannotDeriveMonad error="++show t) + _ -> mkName "bad" +-- t -> error ("cannotDeriveMonad error="++show t) badmonad = [ "Text.ParserCombinators.ReadBase.P" , "Control.Monad.ST.Lazy.Imp.ST" , "Data.Proxy.Proxy" + , "bad" ] diff --git a/src/SubHask/TemplateHaskell/CategoryTrans.hs b/src/SubHask/TemplateHaskell/CategoryTrans.hs deleted file mode 100644 index 6ff6c04..0000000 --- a/src/SubHask/TemplateHaskell/CategoryTrans.hs +++ /dev/null @@ -1,137 +0,0 @@ -module SubHask.TemplateHaskell.CategoryTrans - where - -import Prelude -import Language.Haskell.TH.Syntax -import GHC.Exts - --- import SubHask.Internal.Prelude --- import SubHask.Category - -mkCatTrans :: Name -> Name -> Q [Dec] -mkCatTrans cat constraint = do - catinst <- deriveCategory cat constraint - subcatinst <- deriveSubCategory cat - return $ catinst ++ subcatinst - --- | Given a transformer name, construct a "SubCategory" insance of the form: --- --- > instance SubCategory cat supercat => SubCategory (MonT cat) supercat where --- > embed (MonT f) = embed f -deriveSubCategory :: Name -> Q [Dec] -deriveSubCategory cat = return - [ InstanceD - [ ClassP - (mkName "SubCategory") - [ VarT $ mkName "cat" - , VarT $ mkName "supercat" - ] - ] - ( AppT - ( AppT - ( ConT $ mkName "SubCategory" ) - ( AppT - ( ConT cat ) - ( VarT $ mkName "cat" ) - ) - ) - ( VarT $ mkName "supercat" ) - ) - [ FunD - ( mkName "embed" ) - [ Clause - [ ConP constructor [ VarP $ mkName "f" ] ] - ( NormalB - ( AppE - ( VarE $ mkName "embed" ) - ( VarE $ mkName "f" ) - ) - ) - [ ] - ] - ] - ] - where - constructor = mkName $ nameBase cat - --- | Given a transformer name (e.g. @MonT@), construct a "Category" instance of the --- following generic form: --- --- > instance Category cat => Category (MonT cat) where --- > type ValidCategory (MonT cat) a b = (Monoid a, Monoid b, ValidCategory cat a b) --- > id = MonT id --- > (MonT f).(MonT g) = MonT (f.g) --- --- Note: assumes the value and type constructors of the cat have the same name. -deriveCategory :: Name -> Name -> Q [Dec] -deriveCategory cat constraint = return - [ InstanceD - [ ClassP (mkName "Category") [VarT $ mkName "cat"] ] - ( AppT - ( ConT $ mkName "Category" ) - ( AppT ( ConT cat ) ( VarT $ mkName "cat" ) ) - ) - [ TySynInstD - ( mkName "ValidCategory" ) - ( TySynEqn - [ AppT ( ConT cat ) ( VarT $ mkName "cat" ) - , VarT $ mkName "a" - , VarT $ mkName "b" - ] - ( AppT - ( AppT - ( AppT - ( TupleT 3 ) - ( AppT ( ConT constraint ) ( VarT $ mkName "a" ) ) - ) - ( AppT ( ConT constraint ) ( VarT $ mkName "b" ) ) - ) - ( AppT - ( AppT - ( AppT - ( ConT $ mkName $ "ValidCategory" ) - ( VarT $ mkName "cat" ) - ) - ( VarT $ mkName "a" ) - ) - ( VarT $ mkName "b" ) - ) - ) - ) - , FunD - ( mkName "id" ) - [ Clause - [ ] - ( NormalB - ( AppE - ( ConE constructor ) - ( VarE $ mkName "id" ) - ) - ) - [ ] - ] - , FunD - ( mkName "." ) - [ Clause - [ ConP constructor [ VarP $ mkName "f" ] - , ConP constructor [ VarP $ mkName "g" ] - ] - ( NormalB - ( AppE - ( ConE constructor ) - ( AppE - ( AppE - ( VarE $ mkName "." ) - ( VarE $ mkName "f" ) - ) - ( VarE $ mkName "g" ) - ) - ) - ) - [ ] - ] - ] - ] - where - constructor = mkName $ nameBase cat - diff --git a/src/SubHask/TemplateHaskell/Common.hs b/src/SubHask/TemplateHaskell/Common.hs index 096cdac..7eb2d95 100644 --- a/src/SubHask/TemplateHaskell/Common.hs +++ b/src/SubHask/TemplateHaskell/Common.hs @@ -2,9 +2,7 @@ module SubHask.TemplateHaskell.Common where import Prelude -import Data.List (init,last,nub,intersperse) import Language.Haskell.TH.Syntax -import Control.Monad bndr2type :: TyVarBndr -> Type bndr2type (PlainTV n) = VarT n @@ -19,7 +17,8 @@ apply2varlist :: Type -> [TyVarBndr] -> Type apply2varlist contype xs = go $ reverse xs where go (x:[]) = AppT contype (mkVar x) - go (x:xs) = AppT (go xs) (mkVar x) + go (x:xs') = AppT (go xs') (mkVar x) + go [] = undefined mkVar (PlainTV n) = VarT n mkVar (KindedTV n _) = VarT n diff --git a/src/SubHask/TemplateHaskell/Deriving.hs b/src/SubHask/TemplateHaskell/Deriving.hs index 885539d..d946037 100644 --- a/src/SubHask/TemplateHaskell/Deriving.hs +++ b/src/SubHask/TemplateHaskell/Deriving.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} + -- | -- -- FIXME: doesn't handle multiparameter classes like Integral and Vector @@ -20,6 +22,9 @@ module SubHask.TemplateHaskell.Deriving , BasicType , helper_liftM , helper_id + + -- ** misc + , substituteNewtype ) where @@ -27,12 +32,15 @@ import SubHask.Internal.Prelude import SubHask.TemplateHaskell.Common import SubHask.TemplateHaskell.Mutable import Prelude -import Data.List (init,last,nub,intersperse) +import Data.List (nub) import Language.Haskell.TH.Syntax import Control.Monad -import Debug.Trace +ifThenElse :: Bool -> a -> a -> a +ifThenElse a b c = case a of + True -> b + False -> c -- | This class provides an artificial hierarchy that defines all the classes that a "well behaved" data type should implement. -- All newtypes will derive them automatically. @@ -62,7 +70,7 @@ listSuperClasses className = do TyConI (TySynD _ bndrs t) -> liftM concat $ mapM (go $ bndrs2var bndrs) $ tuple2list t - info -> error $ "type "++nameBase className++" not a unary class\n\ninfo="++show info + info' -> error $ "type "++nameBase className++" not a unary class\n\ninfo="++show info' where bndrs2var bndrs = case bndrs of @@ -72,7 +80,7 @@ listSuperClasses className = do go var (AppT (ConT name) (VarT var')) = if var==var' then listSuperClasses name else return [] -- class depends on another type tested elsewhere - go var _ = return [] + go _ _ = return [] tuple2list :: Type -> [Type] tuple2list (AppT (AppT (TupleT 2) t1) t2) = [t1,t2] @@ -89,8 +97,8 @@ deriveTypefamilies :: [Name] -> Name -> Q [Dec] deriveTypefamilies familynameL typename = do info <- reify typename let (tyvarbndr,tyvar) = case info of - TyConI (NewtypeD _ _ xs (NormalC _ [( _,t)]) _) -> (xs,t) - TyConI (NewtypeD _ _ xs (RecC _ [(_,_,t)]) _) -> (xs,t) + TyConI (NewtypeD _ _ xs _ (NormalC _ [( _,t)]) _) -> (xs,t) + TyConI (NewtypeD _ _ xs _ (RecC _ [(_,_,t)]) _) -> (xs,t) return $ map (go tyvarbndr tyvar) familynameL where go tyvarbndr tyvar familyname = TySynInstD familyname $ TySynEqn @@ -118,10 +126,10 @@ deriveSingleInstance typename classname = if show classname == "SubHask.Mutable. else do typeinfo <- reify typename (conname,typekind,typeapp) <- case typeinfo of - TyConI (NewtypeD [] _ typekind (NormalC conname [( _,typeapp)]) _) + TyConI (NewtypeD [] _ typekind _ (NormalC conname [( _,typeapp)]) _) -> return (conname,typekind,typeapp) - TyConI (NewtypeD [] _ typekind (RecC conname [(_,_,typeapp)]) _) + TyConI (NewtypeD [] _ typekind _ (RecC conname [(_,_,typeapp)]) _) -> return (conname,typekind,typeapp) _ -> error $ "\nderiveSingleInstance; typeinfo="++show typeinfo @@ -141,11 +149,11 @@ deriveSingleInstance typename classname = if show classname == "SubHask.Mutable. -- then don't create an overlapping instance -- These classes only exist because TH has problems with type families -- FIXME: this is probably not a robust solution - ClassI (ClassD _ _ _ _ _) [InstanceD _ (VarT _) _] -> return [] - ClassI (ClassD _ _ _ _ _) [InstanceD _ (AppT (ConT _) (VarT _)) _] -> return [] + ClassI (ClassD _ _ _ _ _) [InstanceD _ _ (VarT _) _] -> return [] + ClassI (ClassD _ _ _ _ _) [InstanceD _ _ (AppT (ConT _) (VarT _)) _] -> return [] -- otherwise, create the instance - ClassI classd@(ClassD ctx classname [bndr] [] decs) _ -> do + ClassI (ClassD ctx _ [bndr] [] decs) _ -> do let varname = case bndr of PlainTV v -> v KindedTV v StarT -> v @@ -175,13 +183,10 @@ deriveSingleInstance typename classname = if show classname == "SubHask.Mutable. , PragmaD $ InlineP f Inline FunLike AllPhases ] - -- trace ("classname="++show classname++"; typename="++show typename) - -- $ trace (" funcL="++show funcL) - -- $ trace (" decs="++show decs) - -- $ return () - return [ InstanceD - -- ( ClassP classname [typeapp] : map (substitutePat varname typeapp) ctx ) - ( AppT (ConT classname) typeapp : map (substitutePat varname typeapp) ctx ) + return + [ InstanceD + Nothing + ( AppT (ConT classname) typeapp : map (subVarT varname typeapp) ctx ) ( AppT (ConT classname) $ apply2varlist (ConT typename) typekind ) ( concat funcL ) ] @@ -191,24 +196,15 @@ expandTySyn (AppT (ConT tysyn) vartype) = do info <- reify tysyn case info of TyConI (TySynD _ [PlainTV var] syntype) -> - return $ substituteVarE var vartype syntype + return $ subVarT var vartype syntype TyConI (TySynD _ [KindedTV var StarT] syntype) -> - return $ substituteVarE var vartype syntype + return $ subVarT var vartype syntype qqq -> error $ "expandTySyn: qqq="++show qqq -substitutePat :: Name -> Type -> Pred -> Pred -substitutePat n t (AppT (AppT EqualityT t1) t2) - = AppT (AppT EqualityT (substituteVarE n t t1)) (substituteVarE n t t2) -substitutePat n t (AppT classname x) = AppT classname $ substituteVarE n t x --- substitutePat n t (AppT classname xs) = go $ classname : map (substituteVarE n t) xs --- where --- go (x:y:[]) = AppT x y --- go (x:y:zs) = go $ AppT x y : zs - -substituteVarE :: Name -> Type -> Type -> Type -substituteVarE varname vartype = go +subVarT :: Name -> Type -> Type -> Type +subVarT varname vartype t = go t where go (VarT e) = if e==varname then vartype @@ -218,31 +214,31 @@ substituteVarE varname vartype = go go ArrowT = ArrowT go ListT = ListT go (TupleT n) = TupleT n - go zzz = error $ "substituteVarE: zzz="++show zzz + go zzz = error $ "subVarT: zzz="++show zzz returnType2newtypeApplicator :: Name -> Name -> Type -> Exp -> Q Exp -returnType2newtypeApplicator conname varname t exp = do +returnType2newtypeApplicator conname varname t exp' = do ret <- go t - return $ AppE ret exp + return $ AppE ret exp' where - id = return $ VarE $ mkName "helper_id" + id' = return $ VarE $ mkName "helper_id" go (VarT v) = if v==varname then return $ ConE conname - else id - go (ConT c) = id + else id' + go (ConT _) = id' -- | FIXME: The cases below do not cover all the possible functions we might want to derive - go (TupleT 0) = id - go t@(AppT (ConT c) t2) = do + go (TupleT 0) = id' + go (AppT (ConT c) t2) = do info <- reify c case info of TyConI (TySynD _ _ _) -> expandTySyn t >>= go - FamilyI (FamilyD TypeFam _ _ _) _ -> id - TyConI (NewtypeD _ _ _ _ _) -> liftM (AppE (VarE $ mkName "helper_liftM")) $ go t2 - TyConI (DataD _ _ _ _ _) -> liftM (AppE (VarE $ mkName "helper_liftM")) $ go t2 + FamilyI (OpenTypeFamilyD _) _ -> id' + TyConI (NewtypeD _ _ _ _ _ _) -> liftM (AppE (VarE $ mkName "helper_liftM")) $ go t2 + TyConI (DataD _ _ _ _ _ _) -> liftM (AppE (VarE $ mkName "helper_liftM")) $ go t2 qqq -> error $ "returnType2newtypeApplicator: qqq="++show qqq go (AppT ListT t2) = liftM (AppE (VarE $ mkName "helper_liftM")) $ go t2 @@ -259,9 +255,9 @@ returnType2newtypeApplicator conname varname t exp = do ) -- FIXME: this is a particularly fragile deriving clause only designed for the mutable operators - go (AppT (VarT m) (TupleT 0)) = id + go (AppT (VarT _) (TupleT 0)) = id' - go xxx = error $ "returnType2newtypeApplicator:\n xxx="++show xxx++"\n t="++show t++"\n exp="++show exp + go xxx = error $ "returnType2newtypeApplicator:\n xxx="++show xxx++"\n t="++show t++"\n exp="++ show exp' isNewtypeInstance :: Name -> Name -> Q Bool isNewtypeInstance typename classname = do @@ -269,12 +265,12 @@ isNewtypeInstance typename classname = do case info of ClassI _ inst -> return $ or $ map go inst where - go (InstanceD _ (AppT _ (AppT (ConT n) _)) _) = n==typename + go (InstanceD _ _ (AppT _ (AppT (ConT n) _)) _) = n==typename go _ = False substituteNewtype :: Name -> Name -> Name -> Type -> Type -substituteNewtype conname varname newvar = go +substituteNewtype conname varname _ = go where go (VarT v) = if varname==v then AppT (ConT conname) (VarT varname) @@ -289,13 +285,13 @@ typeL2patL conname varname xs = map go $ zip (map (\a -> mkName [a]) ['a'..]) xs go (newvar,VarT v) = if v==varname then ConP conname [VarP newvar] else VarP newvar - go (newvar,AppT (AppT (ConT c) _) v) = if nameBase c=="Mutable" + go (newvar,AppT (AppT (ConT c) _) _) = if nameBase c=="Mutable" then ConP (mkName $ "Mutable_"++nameBase conname) [VarP newvar] else VarP newvar - go (newvar,AppT (ConT _) (VarT v)) = VarP newvar - go (newvar,AppT ListT (VarT v)) = VarP newvar - go (newvar,AppT ListT (AppT (ConT _) (VarT v))) = VarP newvar - go (newvar,ConT c) = VarP newvar + go (newvar,AppT (ConT _) (VarT _)) = VarP newvar + go (newvar,AppT ListT (VarT _)) = VarP newvar + go (newvar,AppT ListT (AppT (ConT _) (VarT _))) = VarP newvar + go (newvar,ConT _) = VarP newvar go (newvar,_) = VarP newvar typeL2expL :: [Type] -> [Exp] @@ -310,7 +306,7 @@ list2exp :: [Exp] -> Exp list2exp xs = go $ reverse xs where go (x:[]) = x - go (x:xs) = AppE (go xs) x + go (x:xs') = AppE (go xs') x -- | Generate an Eq_ instance from the Prelude's Eq instance. -- This requires that Logic t = Bool, so we also generate this type instance. @@ -322,6 +318,7 @@ fromPreludeEq qt = do ( mkName "Logic" ) ( TySynEqn [t] (ConT $ mkName "Bool" )) , InstanceD + Nothing [] ( AppT ( ConT $ mkName "Eq_" ) t ) [ FunD diff --git a/src/SubHask/TemplateHaskell/Mutable.hs b/src/SubHask/TemplateHaskell/Mutable.hs index 807854f..c5d94c6 100644 --- a/src/SubHask/TemplateHaskell/Mutable.hs +++ b/src/SubHask/TemplateHaskell/Mutable.hs @@ -9,7 +9,6 @@ module SubHask.TemplateHaskell.Mutable import SubHask.TemplateHaskell.Common import Prelude -import Control.Monad import Language.Haskell.TH showtype :: Type -> String @@ -50,9 +49,9 @@ mkMutableNewtype :: Name -> Q [Dec] mkMutableNewtype typename = do typeinfo <- reify typename (conname,typekind,typeapp) <- case typeinfo of - TyConI (NewtypeD [] _ typekind (NormalC conname [( _,typeapp)]) _) + TyConI (NewtypeD [] _ typekind _ (NormalC conname [( _,typeapp)]) _) -> return (conname,typekind,typeapp) - TyConI (NewtypeD [] _ typekind (RecC conname [(_,_,typeapp)]) _) + TyConI (NewtypeD [] _ typekind _ (RecC conname [(_,_,typeapp)]) _) -> return (conname,typekind,typeapp) _ -> error $ "\nderiveSingleInstance; typeinfo="++show typeinfo @@ -60,15 +59,16 @@ mkMutableNewtype typename = do nameexists <- lookupValueName (show mutname) return $ case nameexists of - Just x -> [] + Just _ -> [] Nothing -> [ NewtypeInstD [ ] ( mkName $ "Mutable" ) [ VarT (mkName "m"), apply2varlist (ConT typename) typekind ] + Nothing ( NormalC mutname - [( NotStrict + [( Bang NoSourceUnpackedness NoSourceStrictness , AppT ( AppT ( ConT $ mkName "Mutable" ) @@ -79,6 +79,7 @@ mkMutableNewtype typename = do ) [ ] , InstanceD + Nothing ( map (\x -> AppT (ConT $ mkName "IsMutable") (bndr2type x)) $ filter isStar $ typekind ) ( AppT ( ConT $ mkName "IsMutable" ) @@ -121,24 +122,26 @@ mkMutableNewtype typename = do mkMutablePrimRef :: Q Type -> Q [Dec] mkMutablePrimRef qt = do _t <- qt - let (cxt,t) = case _t of - (ForallT _ cxt t) -> (cxt,t) + let (cxt',t) = case _t of + (ForallT _ cxt'' t') -> (cxt'',t') _ -> ([],_t) return $ [ NewtypeInstD - cxt + cxt' ( mkName $ "Mutable" ) [ VarT (mkName "m"), t ] + Nothing ( NormalC ( type2name t ) - [( NotStrict + [( Bang NoSourceUnpackedness NoSourceStrictness , AppT (AppT (ConT $ mkName "PrimRef") (VarT $ mkName "m")) t )] ) [ ] , InstanceD - cxt + Nothing + cxt' ( AppT ( ConT $ mkName "IsMutable" ) t ) [ FunD (mkName "freeze") [ Clause diff --git a/src/SubHask/TemplateHaskell/Test.hs b/src/SubHask/TemplateHaskell/Test.hs index f65fb43..c102bff 100644 --- a/src/SubHask/TemplateHaskell/Test.hs +++ b/src/SubHask/TemplateHaskell/Test.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} + module SubHask.TemplateHaskell.Test where @@ -5,15 +7,9 @@ import Prelude import Control.Monad import qualified Data.Map as Map -import Debug.Trace import Language.Haskell.TH -import GHC.Exts - -import SubHask.Internal.Prelude import SubHask.TemplateHaskell.Deriving --- import SubHask.Category --- import SubHask.Algebra -- | Ideally, this map would be generated automatically via template haskell. -- Due to bug , however, we must enter these manually. @@ -184,16 +180,11 @@ testMap = Map.fromList , "theorem_Constructible_cons" ] ) , ( "Foldable", --- [ "law_Foldable_sum" [ "theorem_Foldable_tofrom" , "defn_Foldable_foldr" , "defn_Foldable_foldr'" , "defn_Foldable_foldl" , "defn_Foldable_foldl'" --- , "defn_Foldable_foldr1" --- , "defn_Foldable_foldr1'" --- , "defn_Foldable_foldl1" --- , "defn_Foldable_foldl1'" ] ) , ( "Partitionable", [ "law_Partitionable_length" @@ -227,7 +218,7 @@ mkClassTests className = do info <- reify className typeTests <- case info of ClassI _ xs -> go xs - otherwise -> error "mkClassTests called on something not a class" + _ -> error "mkClassTests called on something not a class" return $ AppE ( AppE ( VarE $ mkName "testGroup" ) @@ -235,8 +226,9 @@ mkClassTests className = do ) ( typeTests ) where + go :: [Dec] -> Q Exp go [] = return $ ConE $ mkName "[]" - go ((InstanceD ctx (AppT _ t) _):xs) = case t of + go ((InstanceD _ _ (AppT _ t) _):xs) = case t of (ConT a) -> do tests <- mkSpecializedClassTest (ConT a) className next <- go xs @@ -246,18 +238,7 @@ mkClassTests className = do ( tests ) ) ( next ) --- (AppT _ _) -> do --- let specializedType = specializeType t (ConT ''Int) --- tests <- mkSpecializedClassTest specializedType className --- next <- go xs --- return $ AppE --- ( AppE --- ( ConE $ mkName ":" ) --- ( tests ) --- ) --- ( next ) --- otherwise -> trace ("mkClassTests: skipping "++show ctx++" => "++show t) $ go xs - otherwise -> go xs + _ -> go xs -- | Given a type and a class, searches "testMap" for all tests for the class; @@ -299,7 +280,7 @@ specializeType specializeType t n = case t of VarT _ -> n AppT t1 t2 -> AppT (specializeType t1 n) (specializeType t2 n) - ForallT xs ctx t -> {-ForallT xs ctx $-} specializeType t n + ForallT _ _ t' -> {-ForallT xs ctx $-} specializeType t' n -- ForallT xs ctx t -> ForallT xs (specializeType ctx n) $ specializeType t n x -> x @@ -310,8 +291,8 @@ specializeLaw specializeLaw typeName lawName = do lawInfo <- reify lawName let newType = case lawInfo of - VarI _ t _ _ -> specializeType t typeName - otherwise -> error "mkTest lawName not a function" + VarI _ t _ -> specializeType t typeName + _ -> error "mkTest lawName not a function" return $ SigE (VarE lawName) newType -- | creates an expression of the form: @@ -353,5 +334,4 @@ listExp2Exp (x:xs) = AppE -- > test extractTestStr :: Name -> String extractTestStr name = nameBase name --- extractTestStr name = last $ words $ map (\x -> if x=='_' then ' ' else x) $ nameBase name diff --git a/stack.yaml b/stack.yaml index ffe78a7..d012111 100644 --- a/stack.yaml +++ b/stack.yaml @@ -52,6 +52,7 @@ extra-deps: - converge-0.1.0.1 - exception-mtl-0.4.0.1 - symbol-0.2.4 +- homoiconic-0.1.2.0 # Override default flag values for local packages and extra-deps @@ -72,3 +73,5 @@ flags: # llvm-general: # shared-llvm: true resolver: lts-5.9 +resolver: nightly-2016-06-15 +compiler: ghc-8.0.1 diff --git a/subhask.cabal b/subhask.cabal index 2332954..e6a8382 100644 --- a/subhask.cabal +++ b/subhask.cabal @@ -1,5 +1,5 @@ name: subhask -version: 0.1.1.0 +version: 0.2.0.0 synopsis: Type safe interface for programming in subcategories of Hask homepage: http://github.com/mikeizbicki/subhask license: BSD3 @@ -18,7 +18,7 @@ description: For example, the category of linear functions is a subcategory of Hask, and SubHask exploits this fact to give a nice interface for linear algebra. To achieve this goal, almost every class hierarchy is redefined to be more general. - I recommend reading the file and the before looking at the documetation here. + I recommend reading the file and the before looking at the documentation here. source-repository head type: git @@ -26,6 +26,18 @@ source-repository head -------------------------------------------------------------------------------- +Flag LlvmSupport + Description: whether to -fllvm + Default: True + -- needed to be turned off in travis. + -- see https://github.com/travis-ci/travis-ci/issues/6120 + +Flag DoTestOptimise + Description: whether to -O2 test + Default: False + -- full optimised compilation takes a bit, and is turned off by default for the test suite. + -- Note: still on for the bench suite, where it doesn't take long. + library exposed-modules: SubHask @@ -59,11 +71,11 @@ library SubHask.Category.Trans.Monotonic SubHask.Compatibility.Base - SubHask.Compatibility.BloomFilter +-- SubHask.Compatibility.BloomFilter SubHask.Compatibility.ByteString SubHask.Compatibility.Cassava SubHask.Compatibility.Containers - SubHask.Compatibility.HyperLogLog +-- SubHask.Compatibility.HyperLogLog SubHask.Monad SubHask.Mutable @@ -99,11 +111,12 @@ library FunctionalDependencies, TupleSections, MultiWayIf, - AutoDeriveTypeable, DeriveGeneric, - RebindableSyntax --- OverloadedLists + RebindableSyntax, + DefaultSignatures, + + UndecidableSuperClasses hs-source-dirs: src @@ -112,34 +125,38 @@ library cbits/Lebesgue.c cc-options: --- -O3 -ffast-math -msse3 ghc-options: --- -O2 --- -O -funbox-strict-fields + -Wall + -Wno-simplifiable-class-constraints - build-depends: - -- NOTE: - -- We specify the *exact* versions of all non-base libraries to ensure that we get reproducible builds. - -- This helps prevent performance regressions. - -- The downside of exact version dependencies is that the user probably doesn't have these versions installed. - -- This can result in significantly longer build times and build conflicts. - -- But since subhask is designed as an alternative to base, this is an acceptable tradeoff. + -- FIXME: + -- SubHask often uses redundant constraints to maintain invariants. + -- GHC 8.0 does not yet let us specify at fine granularity which constraints are intentionally meant to be redundant. + -- So this warning must be temporarily disabled. + -- See: https://ghc.haskell.org/trac/ghc/ticket/10635 + -Wno-redundant-constraints + + -- FIXME: + -- The template haskell code in the homoiconic library generates lots of spurious warnings. + -Wno-unused-matches + build-depends: -- haskell language - base >= 4.8 && <4.9, - ghc-prim , - template-haskell , + base >= 4.9 && <4.10, + ghc-prim, + template-haskell, -- special functionality - parallel , - deepseq , - primitive , - monad-primitive , - QuickCheck , + homoiconic, + parallel, + deepseq, + primitive, + monad-primitive, + QuickCheck, -- math erf , @@ -151,8 +168,8 @@ library -- accelerate-llvm , -- compatibility control flow - mtl , - MonadRandom , + mtl, + MonadRandom, -- compatibility data structures bytestring , @@ -165,50 +182,30 @@ library reflection , -- required for hyperloglog compatibility - semigroups , - bytes , - approximate , - lens +-- hyperloglog, +-- semigroups, +-- bytes, +-- approximate, +-- lens default-language: Haskell2010 -------------------------------------------------------------------------------- -Test-Suite TestSuite-Unoptimized +Test-Suite test default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: test main-is: TestSuite.hs - - ghc-options: - -O0 - build-depends: subhask, test-framework-quickcheck2, test-framework - --- FIXME: --- The test below takes a long time to compile. --- The slow builds are causing travis tests to fail. --- --- Test-Suite TestSuite-Optimized --- default-language: Haskell2010 --- type: exitcode-stdio-1.0 --- hs-source-dirs: test --- main-is: TestSuite.hs --- --- build-depends: --- subhask, --- test-framework-quickcheck2 >= 0.3.0, --- test-framework >= 0.8.0 --- --- ghc-options: --- -O2 --- -fllvm - --------------------- + if flag(dotestoptimise) + ghc-options: -O2 + if flag(llvmsupport) + ghc-options: -fllvm Test-Suite Example0001 default-language: Haskell2010 @@ -233,7 +230,7 @@ Test-Suite Example0003 -------------------------------------------------------------------------------- -benchmark Vector +benchmark bench default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: bench @@ -248,31 +245,12 @@ benchmark Vector -O2 -funbox-strict-fields -fexcess-precision - --- -fliberate-case-threshold=100000 --- -fexpose-all-unfoldings --- -fmax-simplifier-iterations=10 --- -fmax-worker-args=100 --- -fsimplifier-phases=5 --- -fspec-constr-count=50 - - -fllvm -optlo-O3 -optlo-enable-fp-mad -optlo-enable-no-infs-fp-math -optlo-enable-no-nans-fp-math -optlo-enable-unsafe-fp-math --- -ddump-to-file --- -ddump-rule-firings --- -ddump-rule-rewrites --- -ddump-rules --- -ddump-cmm --- -ddump-simpl --- -ddump-simpl-stats --- -dppr-debug --- -dsuppress-module-prefixes --- -dsuppress-uniques --- -dsuppress-idinfo --- -dsuppress-coercions --- -dsuppress-type-applications + if flag(llvmsupport) + ghc-options: -fllvm + diff --git a/test/TestSuite.hs b/test/TestSuite.hs index 4996f9b..3b61032 100644 --- a/test/TestSuite.hs +++ b/test/TestSuite.hs @@ -82,7 +82,7 @@ main = defaultMainWithOpts [ $( mkSpecializedClassTests [t| Lexical [Char] |] [''Ord,''MinBound] ) , $( mkSpecializedClassTests [t| ComponentWise [Char] |] [''Lattice,''MinBound] ) , $( mkSpecializedClassTests [t| Hamming [Char] |] [''Metric] ) - , $( mkSpecializedClassTests [t| Levenshtein [Char] |] [''Metric] ) +-- , $( mkSpecializedClassTests [t| Levenshtein [Char] |] [''Metric] ) ] , testGroup "metric" -- [ $( mkSpecializedClassTests [t| Ball Int |] [''Eq,''Container] ) From b8f969e74d810d7d0d80524460ed2678d142d65a Mon Sep 17 00:00:00 2001 From: tpierson Date: Wed, 20 Jul 2016 00:12:09 -0400 Subject: [PATCH 11/20] rewritten around ghc 8.0 and Acclerate.Acc --- src/SubHask/Algebra.hs | 1 - src/SubHask/Algebra/Accelerate/Accelerate.hs | 53 ++-- .../Algebra/Accelerate/AccelerateBackend.hs | 2 +- src/SubHask/Algebra/Accelerate/Matrix.hs | 264 ------------------ src/SubHask/Algebra/Accelerate/Vector.hs | 201 ++++++------- stack.yaml | 82 ++---- subhask.cabal | 6 +- test/TestSuite.hs | 44 +-- 8 files changed, 154 insertions(+), 499 deletions(-) delete mode 100644 src/SubHask/Algebra/Accelerate/Matrix.hs diff --git a/src/SubHask/Algebra.hs b/src/SubHask/Algebra.hs index 7c24211..9bdf4ba 100644 --- a/src/SubHask/Algebra.hs +++ b/src/SubHask/Algebra.hs @@ -3085,4 +3085,3 @@ type instance FreeConstraints t a -------------------------------------------------------------------------------- class FAlgebra alg => Variety alg where - diff --git a/src/SubHask/Algebra/Accelerate/Accelerate.hs b/src/SubHask/Algebra/Accelerate/Accelerate.hs index 32f985b..4baffaa 100644 --- a/src/SubHask/Algebra/Accelerate/Accelerate.hs +++ b/src/SubHask/Algebra/Accelerate/Accelerate.hs @@ -1,39 +1,22 @@ module SubHask.Algebra.Accelerate.Accelerate ( ValidBackend(..) - , mkAccVector + -- , runAccVector , mkAccVectorFromList - , mkAccMatrixFromList - , mkAccMatrixFromMatrix + -- , mkAccMatrixFromList + -- , mkAccMatrixFromMatrix --, acc2SVector ) where - -import Control.Monad.Primitive -import Control.Monad -import SubHask.Algebra.Accelerate.AccelerateBackend (Backend, inAccLand) +import SubHask.Algebra.Accelerate.AccelerateBackend (Backend(..)) import SubHask.Algebra.Accelerate.Vector -import SubHask.Algebra.Accelerate.Matrix +-- import SubHask.Algebra.Accelerate.Matrix import qualified Data.Array.Accelerate as A -- import qualified Data.Array.Accelerate.LLVM.Array.Data as LLVM import qualified Data.Array.Accelerate.CUDA as CUDA import qualified Data.Array.Accelerate.Interpreter as I -import SubHask.Category -import SubHask.Compatibility.Base import SubHask.Internal.Prelude -import SubHask.SubType - -import Foreign.Ptr -import Foreign.ForeignPtr -import Foreign.Marshal.Utils - -import System.IO.Unsafe -import Unsafe.Coerce - -import SubHask.Algebra -import SubHask.Algebra.Vector -import SubHask.Algebra.Matrix import qualified Prelude as P --FIXME: Replace all intermediary lists with correct use of acclerate-io @@ -42,14 +25,14 @@ mkAccVectorFromList l = let len = P.length l in ACCVector (A.use (A.fromList (A.Z A.:.len) l)) -mkAccVector :: (A.Elt a, ValidSVector (n::Symbol) a) => SVector (n::Symbol) a -> ACCVector (bknd::Backend) (n::Symbol) a -mkAccVector v @(SVector_Dynamic fp off n) = let - arr = A.fromList (A.Z A.:. n) $ unsafeInlineIO $ go (n-1) [] - go (-1) xs = return $ xs - go i xs = withForeignPtr fp $ \p -> do - x <- peekElemOff p (off+i) - go (i-1) (x:xs) - in ACCVector (A.use arr) +-- mkAccVector :: (A.Elt a, ValidSVector (n::Symbol) a) => SVector (n::Symbol) a -> ACCVector (bknd::Backend) (n::Symbol) a +-- mkAccVector v @(SVector_Dynamic fp off n) = let +-- arr = A.fromList (A.Z A.:. n) $ unsafeInlineIO $ go (n-1) [] +-- go (-1) xs = return $ xs +-- go i xs = withForeignPtr fp $ \p -> do +-- x <- peekElemOff p (off+i) +-- go (i-1) (x:xs) +-- in ACCVector (A.use arr) -- acc2SVector :: ValidACCVector (b::Backend) n a => ACCVector (b::Backend) n a -> SVector n a -- acc2SVector (ACCVector v) = unsafeToModule $ (runAccVector v) :: SVector n a @@ -57,15 +40,15 @@ mkAccVector v @(SVector_Dynamic fp off n) = let class ValidBackend (b::Backend) where runAccVector :: (ValidACCVector (b::Backend) n a, A.IsScalar a) => ACCVector (b::Backend) n a -> [a] - runAccMatrix :: (ValidACCMatrix (b::Backend) v r, A.IsScalar a, A.Elt a) => ACCMatrix (b::Backend) v n m a -> [a] + -- runAccMatrix :: (ValidACCMatrix (b::Backend) v r, A.IsScalar a, A.Elt a) => ACCMatrix (b::Backend) v n m a -> [a] -instance ValidBackend Interpreter where +instance ValidBackend 'Interpreter where runAccVector (ACCVector a) = A.toList (I.run a) - runAccMatrix (ACCMatrix a) = A.toList (I.run a) + -- runAccMatrix (ACCMatrix a) = A.toList (I.run a) -instance ValidBackend CUDA where +instance ValidBackend 'CUDA where runAccVector (ACCVector a) = A.toList (CUDA.run a) - runAccMatrix (ACCMatrix a) = A.toList (CUDA.run a) + -- runAccMatrix (ACCMatrix a) = A.toList (CUDA.run a) -- instance ValidBackend LLVM where -- runAccVector (ACCVector a) = A.toList (LLVM.runArray a) diff --git a/src/SubHask/Algebra/Accelerate/AccelerateBackend.hs b/src/SubHask/Algebra/Accelerate/AccelerateBackend.hs index 2ace52a..a1b9c8a 100644 --- a/src/SubHask/Algebra/Accelerate/AccelerateBackend.hs +++ b/src/SubHask/Algebra/Accelerate/AccelerateBackend.hs @@ -8,5 +8,5 @@ where data Backend = Interpreter | CUDA - | LLVM + -- | LLVM -- LLVM has an SoC project slated, so check back in 60 days for non-parial functionality diff --git a/src/SubHask/Algebra/Accelerate/Matrix.hs b/src/SubHask/Algebra/Accelerate/Matrix.hs deleted file mode 100644 index dbad2b8..0000000 --- a/src/SubHask/Algebra/Accelerate/Matrix.hs +++ /dev/null @@ -1,264 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# OPTIONS_GHC -fno-warn-unused-binds #-} -{-# OPTIONS_GHC -fno-warn-missing-methods #-} -{-# LANGUAGE OverloadedStrings #-} - -module SubHask.Algebra.Accelerate.Matrix - ( - --ValidMatrix - ACCMatrix (..) - , ValidACCMatrix - , ACCMatrix'(..) - , mmult - , transpose - , row - , col - , nCols - , nRows - , (!!) - , mkAccMatrixFromList - , mkAccMatrixFromMatrix - ) - where - -import qualified Data.Array.Accelerate as A -import qualified Data.Array.Accelerate.CUDA as CUDA -import qualified Data.Array.Accelerate.Interpreter as I -import SubHask.Algebra.Accelerate.Vector (ACCVector(..)) -import SubHask.Algebra.Accelerate.AccelerateBackend (Backend) - -import Data.Primitive hiding (sizeOf) -import Control.Monad.Primitive -import Control.Monad - -import SubHask.Algebra -import SubHask.Category -import qualified SubHask.Algebra.Matrix as M (Matrix(..), ValidMatrix, colLength) -import SubHask.Internal.Prelude - - -import qualified Prelude as P - - -newtype ACCMatrix (bknd::Backend) vect (m::k) (n::k) a = ACCMatrix (A.Acc (A.Array A.DIM2 a)) - -type ValidACCMatrix (bknd::Backend) vect r = - ( - FiniteModule vect - , r ~ Scalar (Elem vect) - , Hilbert vect - , VectorSpace r - , Prim r - , A.Elt r - , P.Num r - , P.Num (A.Exp r) - , Actor r ~ A.Exp r - , Elem r ~ A.Exp r - , P.Integral (A.Exp Int) - , Scalar (A.Exp r) ~ A.Exp r - , (A.Exp r >< A.Exp r) ~ A.Exp r - , Ring (A.Exp Int) - , Ord_ (A.Exp r) - , Normed(A.Exp r) - , Ring(A.Exp r) - , Logic(A.Exp r) ~ Bool - , Field (A.Exp r) - - ) - -type instance Scalar (ACCMatrix b v m n r) = Scalar r -type instance ACCMatrix b v m n r > IsMutable (ACCMatrix bknd v m n r) - - - -{-# INLINE nCols #-} -nCols :: (A.Elt r) => ACCMatrix b v m n r -> A.Exp Int -nCols (ACCMatrix arr) = let - (A.Z A.:. cols A.:. rows) = A.unlift (A.shape arr) :: (A.Z A.:. A.Exp Int A.:. A.Exp Int) - in cols -{-# INLINE nRows #-} -nRows :: (A.Elt r) => ACCMatrix b v m n r -> A.Exp Int -nRows (ACCMatrix arr) = let - (A.Z A.:. cols A.:. rows) = A.unlift (A.shape arr) :: (A.Z A.:. A.Exp Int A.:. A.Exp Int) - in rows -{-# INLINE (!!) #-} -(!!) (ACCMatrix m) (i,j) = m A.! A.index2 i j - - --- algebra -instance - (Prim r, Monoid r, ValidACCMatrix b v r) => - Semigroup (ACCMatrix b v m n r) where - {-# INLINE (+) #-} - (+) (ACCMatrix m1) (ACCMatrix m2) = ACCMatrix (A.zipWith (P.+) m1 m2) - -instance - (Monoid r, Cancellative r, Prim r, ValidACCMatrix b v r) - => Cancellative (ACCMatrix b v (n::Symbol) (m::Symbol) r) where - {-# INLINE (-) #-} ; - (-) (ACCMatrix m1) (ACCMatrix m2) = ACCMatrix (A.zipWith (P.-) m1 m2) - ---Need the correct dim for this fill ---also not sure to to handle the types of the index and zero value; ---the Ring() constraints made it happy for Ints -instance - (Monoid r, Prim r, ValidACCMatrix b v r) => - Monoid (ACCMatrix b v (n::Symbol) (m::Symbol) r) where - {-# INLINE zero #-} - zero = ACCMatrix (A.fill (A.index2 2 4) 0) - -instance - (Monoid r, Abelian r, Prim r, ValidACCMatrix b v r) => - Abelian (ACCMatrix b v (n::Symbol) (m::Symbol) r) - -instance - (Module r, Prim r, ValidACCMatrix b v r) => - Module (ACCMatrix b v (n::Symbol) (m::Symbol) r) where - {-# INLINE (.*) #-} - (.*) (ACCMatrix v) r = ACCMatrix( A.map (\x -> x P.* A.constant r) v) - -instance -- had to add Monoid r, to this instance - (Group r, Prim r, ValidACCMatrix b v r) => - Group (ACCMatrix b v (n::Symbol) (m::Symbol) r) where - {-# INLINE negate #-} - negate (ACCMatrix v) = ACCMatrix( A.map (\x -> x P.* A.constant (P.negate 1)) v) - ---Could not deduce (r ~ A.Exp r) -instance - (Actor(A.Exp r) ~ (A.Exp r), Semigroup (Actor(A.Exp r)), Action r, Semigroup r, Prim r, ValidACCMatrix b v r) => - Action (ACCMatrix b v (n::Symbol) (m::Symbol) r) - where - (.+) :: ACCMatrix b v m n r -> A.Exp r -> ACCMatrix b v m n r - {-# INLINE (.+) #-} - (.+) (ACCMatrix v) r = ACCMatrix( A.map (P.+ r) v) - -instance - (FreeModule r, Prim r, ValidACCMatrix b v r) => - FreeModule (ACCMatrix b v (n::Symbol) (m::Symbol) r) where - {-# INLINE (.*.) #-} - (.*.) (ACCMatrix v1) (ACCMatrix v2) = ACCMatrix(A.zipWith (P.*) v1 v2) - ones = undefined - -instance - (P.Fractional (A.Exp r), VectorSpace r, Prim r, ValidACCMatrix b v r) => - VectorSpace (ACCMatrix b v (n::Symbol) (m::Symbol) r) where - (./) :: ACCMatrix b v m n r -> A.Exp r -> ACCMatrix b v m n r - {-# INLINE (./) #-} - (./) (ACCMatrix v) r = ACCMatrix(A.map ( P./ r) v) - {-# INLINE (./.) #-} - (./.) (ACCMatrix v1) (ACCMatrix v2) = ACCMatrix(A.zipWith (A./) v1 v2) - -instance - (Index r ~ A.Exp r, Complemented (A.Acc(A.Scalar Bool)), Integral(A.Exp Int), Ring (A.Exp r), Ring (A.Exp Int), Complemented r, ValidACCMatrix b v r, Monoid r, ValidLogic r, Prim r, IsScalar r) - => IxContainer (ACCMatrix b v (n::Symbol) (m::Symbol) r) where - - {-# INLINE (!) #-} - (!) :: ACCMatrix b v m n r -> A.Exp r -> A.Exp r--A.Acc (Scalar r) - (!) (ACCMatrix m) i = let - l = A.size m - rval = m!!(i `div` l, i `mod` l) - in A.the rval - -{-# INLINE col #-} -col :: (ValidACCMatrix b v r - ) => ACCMatrix b v (n::Symbol) (m::Symbol) r -> Int -> ACCVector b n r -col (ACCMatrix m) i = ACCVector (A.slice m (A.lift (A.Z A.:. i A.:. A.All))) - -{-# INLINE row #-} -row :: - ( ValidACCMatrix b v r - ) => ACCMatrix b v (n::Symbol) (m::Symbol) r -> Int -> ACCVector b m r -row (ACCMatrix m) j = ACCVector (A.slice m (A.lift (A.Z A.:. A.All A.:. j))) - ---taken from http://www.cse.unsw.edu.au/~chak/papers/repa.pdf -{-# INLINE mmult #-} -mmult :: - ( ValidACCMatrix b v r - , Field (A.Exp r) - ) - => ACCMatrix b v (n::Symbol) (x0::Symbol) r - -> ACCMatrix b v (x0::Symbol) (m::Symbol) r - -> ACCMatrix b v (n::Symbol) (m::Symbol) r -mmult (ACCMatrix arr) (ACCMatrix brr) = ACCMatrix out - where - trr = A.transpose brr - (A.Z A.:. colsA A.:. rowsA) = A.unlift (A.shape arr) :: (A.Z A.:. A.Exp Int A.:. A.Exp Int) - (A.Z A.:. colsB A.:. rowsB) = A.unlift (A.shape brr) :: (A.Z A.:. A.Exp Int A.:. A.Exp Int) - arrRepl = A.replicate (A.lift $ A.Z A.:. A.All A.:. colsB A.:. A.All) arr - brrRepl = A.replicate (A.lift $ A.Z A.:. rowsA A.:. A.All A.:. A.All) trr - out = A.fold (P.+) 0.0 $ (A.zipWith (P.*) arrRepl brrRepl) - - -{-# INLINE transpose #-} -transpose :: - ( ValidACCMatrix b v r - ) - => ACCMatrix b v (m::Symbol) (n::Symbol) r - -> ACCMatrix b v (m::Symbol) (n::Symbol) r -transpose (ACCMatrix m) = ACCMatrix (A.transpose (A.unlift m)) - -data ACCMatrix' b v r (m::Symbol) (n::Symbol) where - Zero :: - (ValidACCMatrix b v r) => - ACCMatrix' b v r (m::Symbol) (n::Symbol) - - Id :: - (ValidACCMatrix b v r) => - {-#UNPACK#-}!(Scalar r) -> ACCMatrix' b v r (m::Symbol) (n::Symbol) - - Mat :: - (ValidACCMatrix b v r) => - {-#UNPACK#-}!(ACCMatrix b v (m::Symbol) (n::Symbol) r) - -> ACCMatrix' b v r (m::Symbol) (n::Symbol) - -type instance Scalar (ACCMatrix' b v r (m::Symbol) (n::Symbol)) = Scalar r -type instance Logic (ACCMatrix' b v r (m::Symbol) (n::Symbol)) = Logic r--Bool - -type instance ACCMatrix' b v r (m::Symbol) (n::Symbol) >< m = - ACCTensor_Linear (ACCMatrix' b v r (m::Symbol) (n::Symbol)) m -type family ACCTensor_Linear m n where - ACCTensor_Linear (ACCMatrix' b v r (m::Symbol) (n::Symbol)) c = - ACCMatrix' b v r (m::Symbol) (n::Symbol) - -instance Category (ACCMatrix' b v r) where - type ValidCategory (ACCMatrix' b v r ) m = ValidACCMatrix b v r - - id = Id 1 - - Zero . Zero = Zero - Zero . (Id _ ) = Zero - Zero . (Mat _ ) = Zero - - (Id _ ) . Zero = Zero - (Id r1) . (Id r2) = Id $ r1 * r2 - -- Could not deduce (b ~ c) - --(Id (r::Scalar r)) . (Mat (m::ACCMatrix b v (m::Symbol) (n::Symbol) r)) = Mat $ m .* A.constant r - - (Mat _) . Zero = Zero - --Could not deduce (b ~ a) - --(Mat m ) . (Id r ) = Mat $ m .* A.constant r - --Could not deduce (b1 ~ b2) - --(Mat m1) . (Mat m2) = Mat $ mmult m2 m1 - -mkAccMatrixFromList :: A.Elt a => Int -> [a] -> ACCMatrix b v m n a -mkAccMatrixFromList m l = let - ln = P.length l - n = ln `div` m - in ACCMatrix (A.use (A.fromList (A.Z A.:.m A.:.n) l)) - ---FIXME: use accelerate-io functions https://github.com/AccelerateHS/accelerate-io/tree/master/Data/Array/Accelerate/IO -mkAccMatrixFromMatrix :: (M.ValidMatrix vect r, A.Elt r) => M.Matrix vect r (m::Symbol) (n::Symbol) -> ACCMatrix b v m n r -mkAccMatrixFromMatrix mat@(M.Matrix_Dynamic vect ln) = - mkAccMatrixFromList cln l - where - cln = M.colLength mat - l = P.foldr (\x xs -> vect!x : xs) [] [0..(ln * cln)-1] diff --git a/src/SubHask/Algebra/Accelerate/Vector.hs b/src/SubHask/Algebra/Accelerate/Vector.hs index b7b1ad9..18e4ecb 100644 --- a/src/SubHask/Algebra/Accelerate/Vector.hs +++ b/src/SubHask/Algebra/Accelerate/Vector.hs @@ -39,72 +39,44 @@ import Unsafe.Coerce newtype ACCVector (bknd::Backend) (n::k) a = ACCVector (A.Acc (A.Array A.DIM1 a)) -type instance Scalar (ACCVector bknd n r) = A.Exp r--Scalar r -type instance Logic (ACCVector bknd n r) = A.Exp r--Logic r - -type instance ACCVector bknd m a >< b = Tensor_ACCVector (ACCVector bknd m a) b -type family Tensor_ACCVector a b where - Tensor_ACCVector (ACCVector bknd n r1) (ACCVector bknd m r2) = ACCVector bknd n r1 +> ACCVector bknd m r2 - Tensor_ACCVector (ACCVector bknd n r1) r1 = ACCVector bknd n r1 -- (r1><(A.Exp r))) - -type ValidACCVector bknd n a = ((ACCVector (bknd::Backend) n a>< A.Exp a) ~ A.Exp a - -- , ACCVector (bknd::Backend) n a ~ ACCVector (bknd::Backend) n (A.Exp a) - , Prim a - , IsExpScalar a +type instance Scalar (ACCVector bknd n r) = Scalar (A.Acc(A.Scalar r)) +type instance Logic (ACCVector bknd n r) = Logic (A.Acc(A.Scalar Bool)) + +type ValidACCVector bknd n a = ( + Prim a , A.Elt a - --, Elem a ~ A.Exp a - --, A.IsNum a - , Tensor_ACCVector (ACCVector bknd n a) a - ~ ACCVector bknd n a - , Tensor_ACCVector (ACCVector bknd n a) (A.Exp a) - ~ ACCVector bknd n a - -- , A.Eq (A.Array A.DIM1 a) - -- , A.Lift A.Exp (A.Acc (A.Array A.DIM1 a)) , P.Num (A.Exp a) - --, P.Floating (A.Exp a) - --, A.IsFloating a - -- , Scalar (Scalar (A.Exp a)) ~ A.Exp a - , a ~ Scalar (Scalar a) - -- , Scalar a ~ a - -- , Scalar (A.Exp a) ~ Scalar (Scalar (A.Exp a)) - -- , Scalar (A.Exp a) ~ (A.Exp a) - -- , Logic (A.Exp Bool) ~ A.Exp Bool - --, Logic (A.Exp a) ~ A.Exp Bool - -- , Logic (A.Exp a) ~ Bool - --, Normed (A.Exp a) - -- , Ord_ (A.Exp a) - --, Ring (A.Exp a) - -- , Field (A.Exp a) + , Scalar (A.Acc (A.Scalar a)) ~ A.Acc (A.Scalar a) + , Logic (A.Acc (A.Scalar a)) ~ A.Acc (A.Scalar a) + , Actor (A.Acc (A.Scalar a)) ~ A.Acc (A.Scalar a) + , Container (A.Acc (A.Scalar a)) + , Container (Logic (A.Acc (A.Scalar Bool))) + , Boolean (Logic (A.Acc (A.Scalar Bool))) + , Logic (Logic (A.Acc (A.Scalar Bool))) ~ Logic (A.Acc (A.Scalar Bool)) + , Logic (A.Acc (A.Scalar Bool)) ~ A.Acc (A.Scalar Bool) + , Elem (A.Acc (A.Scalar a)) ~ A.Acc (A.Scalar a) , P.Fractional (A.Exp a) , P.Floating (A.Exp a) - -- , Actor a ~ A.Exp a - , A.Eq (A.Array A.DIM1 a) - , A.Lift A.Exp (A.Acc (A.Array A.DIM1 a)) - --, P.Floating (A.Acc (A.Scalar a)) - ) + , P.Floating (A.Acc (A.Scalar a)) + , P.Floating (A.Acc (A.Array A.DIM0 a)) -type instance Index (ACCVector bknd n r) = A.Exp Int --Index r -type instance Elem (ACCVector bknd n r) = A.Exp r -type instance SetElem (ACCVector (bknd::Backend) n r) b = ACCVector (bknd::Backend) n b + ) +type instance Index (ACCVector bknd n r) = Index (A.Acc(A.Scalar Int)) +type instance Elem (ACCVector bknd n r) = Elem (A.Acc(A.Scalar r)) -type instance Actor (ACCVector (bknd::Backend) n r) = A.Exp r +type instance Actor (ACCVector (bknd::Backend) n r) = Actor (A.Acc(A.Scalar r)) instance (KnownNat n, Prim a) => IsMutable (ACCVector (bknd::Backend) (n::Nat) a) instance (KnownNat n, Monoid r, ValidACCVector b n r) => Semigroup (ACCVector (b::Backend) (n::Nat) r) where {-# INLINE (+) #-} - (+) (ACCVector v1) (ACCVector v2)=ACCVector (A.zipWith (A.+) v1 v2) + (+) :: ACCVector bknd n r -> ACCVector bknd n r -> ACCVector bknd n r + (+) (ACCVector v1) (ACCVector v2)=ACCVector (A.zipWith (P.+) v1 v2) -instance (KnownNat n, ValidACCVector bknd n r, Action r, Semigroup r, Prim r) => Action (ACCVector (bknd::Backend) (n::Nat) r) where - {-# INLINE (.+) #-} - (.+) (ACCVector v) r = ACCVector (A.map (P.+ r) v) +instance (Semigroup (Actor (A.Acc (A.Scalar r))), KnownNat n, ValidACCVector bknd n r, Action r, Semigroup r, Prim r) => Action (ACCVector (bknd::Backend) (n::Nat) r) where + {-# INLINE (.+) #-} + (.+) (ACCVector v) r = ACCVector (A.map (A.+ (A.the r)) v) instance (KnownNat n, Monoid r, Cancellative r, ValidACCVector bknd n r) => Cancellative (ACCVector (bknd::Backend) (n::Nat) r) where {-# INLINE (-) #-} @@ -123,68 +95,66 @@ instance (KnownNat n, Group r, ValidACCVector bknd n r) => Group (ACCVector (bkn instance (KnownNat n, Monoid r, Abelian r, ValidACCVector bknd n r) => Abelian (ACCVector (bknd::Backend) (n::Nat) r) -instance (KnownNat n, FreeModule r, ValidACCVector bknd n r, IsExpScalar r) => FreeModule (ACCVector (bknd::Backend) (n::Nat) r) where +instance (Ring (A.Acc (A.Scalar r)), KnownNat n, FreeModule r, ValidACCVector bknd n r) => FreeModule (ACCVector (bknd::Backend) (n::Nat) r) where {-# INLINE (.*.) #-} (.*.) (ACCVector a1) (ACCVector a2) = ACCVector( A.zipWith (P.*) a1 a2) -instance (KnownNat n, Module r, ValidACCVector bknd n r) => Module (ACCVector (bknd::Backend) (n::Nat) r) where +instance (Ring (A.Acc (A.Scalar r)), KnownNat n, Module r, ValidACCVector bknd n r) => Module (ACCVector (bknd::Backend) (n::Nat) r) where {-# INLINE (.*) #-} - (.*) (ACCVector v) r = ACCVector (A.map (P.* r) v) + (.*) (ACCVector v) r = ACCVector (A.map (P.* (A.the r)) v) -instance (KnownNat n, VectorSpace r, ValidACCVector bknd n r) => VectorSpace (ACCVector (bknd::Backend) (n::Nat) r) where +instance (Field (A.Acc (A.Scalar r)), KnownNat n, VectorSpace r, ValidACCVector bknd n r) => VectorSpace (ACCVector (bknd::Backend) (n::Nat) r) where {-# INLINE (./) #-} - (./) (ACCVector v) r = ACCVector (A.map (P./ r) v) + (./) (ACCVector v) r = ACCVector (A.map (P./ (A.the r)) v) {-# INLINE (./.) #-} (./.) (ACCVector a1) (ACCVector a2) = ACCVector (A.zipWith (P./) a1 a2) --- Could not deduce (r ~ Elem r) --- In the instance declaration for ‘FiniteModule (ACCVector b n r)’ - -instance (KnownNat n, FreeModule r, ValidLogic r, ValidACCVector b n r) => FiniteModule (ACCVector b (n::Nat) r) ---Couldn't match expected type ‘Int’ with actual type ‘A.Exp Int’ +instance (Index (A.Acc (A.Scalar Int)) ~ A.Acc (A.Scalar Int), Ring (A.Acc (A.Scalar r)), KnownNat n, FreeModule r, ValidACCVector b n r) => FiniteModule (ACCVector b (n::Nat) r) +--dim wants an Int but here gets an A.Exp Int. I tried changing the signiture to a generic type in Alegbra.hs but that produced numerous errors. where - --dim :: ACCVector b (n::Nat) r -> Index(A.Exp Int) - {-# INLINE dim #-} - dim (ACCVector v) = A.size v + -- dim :: ACCVector b (n::Nat) r -> A.Exp Int + -- {-# INLINE dim #-} + -- dim (ACCVector v) = A.size v --- Could not deduce (r ~ Elem r) instance ( Monoid r - , ValidLogic r , ValidACCVector b n r - , IsExpScalar r , KnownNat n + , Index (A.Acc (A.Scalar Int)) ~ A.Acc (A.Scalar Int) , FreeModule r ) => IxContainer (ACCVector b (n::Nat) r) where {-# INLINE (!) #-} - (!) (ACCVector v) i = A.the (v A.! A.index1 i) + (!) (ACCVector v) i = A.unit (v A.! A.index1 (A.the (i:: Index(A.Acc (A.Scalar Int))))) - {-# INLINABLE imap #-} - imap f (ACCVector v) = let - mpd = A.imap (\x i -> f i x) v - in ACCVector mpd + -- {-# INLINABLE imap #-} + -- -- imap f (ACCVector v) = A.zipWith (\i x -> f ((A.unit i)::A.Acc (A.Scalar Int)) ((A.unit x)::A.Acc (A.Scalar r))) ((A.generate (A.shape v) P.id):: A.Array A.DIM1 Int) v + -- imap f (ACCVector v) = let + -- mapd = A.imap (\x (i::A.Exp r) -> let A.Z A.:. idx = A.unlift x -- This dance is probably not optimal but f expects A.Scalars so we have to build them + -- in A.the (f ((A.unit i) :: Index (ACCVector b n r)) (x ! idx))) v + -- in ACCVector mapd type ValidElem (ACCVector b n r) e = (FiniteModule e, ValidACCVector b n e) -instance (A.Eq r, KnownNat n, Eq_ r, Monoid r, ValidACCVector b n r) => Eq_ (ACCVector b (n::Nat) r) where - --(==) :: ACCVector b n r -> ACCVector b n r -> A.Acc (A.Scalar Bool) +instance (A.Eq r, KnownNat n, Eq r, Monoid r, ValidACCVector b n r) => Eq (ACCVector b (n::Nat) r) where {-# INLINE (==) #-} (ACCVector v2) == (ACCVector v1) = let - l = A.zipWith (A.==*) v1 v2 + l = A.zipWith (\x y -> x A.==* y) v1 v2 :: A.Acc (A.Array A.DIM1 Bool) ele = l A.! A.index1 (A.constant 0) bl = A.all (A.&&* ele) l - in A.the bl + in bl instance ( ValidACCVector b n r + , A.Eq r , ExpField r - --, Normed r - , Ord_ r - , IsExpScalar r + , Ord (A.Acc (A.Scalar r)) + , Normed (A.Acc (A.Scalar r)) + , Ring (A.Acc (A.Scalar r)) + , Ord r , VectorSpace r , KnownNat n ) => Metric (ACCVector b (n::Nat) r) @@ -195,66 +165,71 @@ instance dmag = A.zipWith (P.-) v1 v2 dsq = A.zipWith (P.*) dmag dmag drt = A.sqrt (A.sum dsq) - in A.the drt + in drt -instance (P.Floating (A.Acc (A.Array A.DIM0 r)), KnownNat n, VectorSpace r, ValidACCVector b n r, ExpField r) => Normed (ACCVector b (n::Nat) r) where +instance (Ring (A.Acc (A.Scalar r)), Ord (A.Acc (A.Scalar r)), Ord r, KnownNat n, VectorSpace r, ValidACCVector b n r, ExpField r) => Normed (ACCVector b (n::Nat) r) where {-# INLINE size #-} - --Could not deduce (r ~ A.Exp r) - size :: ACCVector b (n::Nat) r -> A.Exp r size (ACCVector v1) = let - sq = A.zipWith (P.*) v1 v1 :: A.Acc (A.Array A.DIM1 r) + sq = A.zipWith (P.*) v1 v1 s = A.fold (P.+) (A.constant 0.0) sq - srt = A.sqrt (s::A.Acc (A.Array A.DIM0 r)) - in A.the srt :: A.Exp r - - --- -- Couldn't match type ‘A.Exp Bool’ with ‘Bool’ + srt = A.sqrt s + in srt instance ( VectorSpace r + , A.Eq r + , Normed r + , Normed (A.Acc (A.Scalar r)) , ValidACCVector b n r - , IsExpScalar r + , Field (A.Acc (A.Scalar r)) + , Ord (A.Acc (A.Scalar r)) , ExpField r , Real r + , Ord r , KnownNat n ) => Banach (ACCVector b (n::Nat) r) -instance - ( FiniteModule (ACCVector b (n::Nat) r) - , VectorSpace (ACCVector b (n::Nat) r) - , Normed (ACCVector b n r +> ACCVector b n r) - , KnownNat n - , MatrixField r - ) => TensorAlgebra (ACCVector b (n::Nat) r) - where - (ACCVector v1)><(ACCVector v2) = let - r = A.size v1 - c = A.size v2 - arr = A.map (\i -> A.lift (A.map (\j -> i * j ) v1)) v2 - m = A.reshape (A.index2 r c) arr :: ACCVector bknd n r +> ACCVector bknd m r - in m +-- instance +-- ( FiniteModule (ACCVector b (n::Nat) r) +-- , VectorSpace (ACCVector b (n::Nat) r) +-- , Normed (ACCVector b n r +> ACCVector b n r) +-- , KnownNat n +-- , MatrixField r +-- ) => TensorAlgebra (ACCVector b (n::Nat) r) +-- where +-- (ACCVector v1)><(ACCVector v2) = let +-- r = A.size v1 +-- c = A.size v2 +-- arr = A.map (\i -> A.lift (A.map (\j -> i * j ) v1)) v2 +-- m = A.reshape (A.index2 r c) arr :: ACCVector bknd n r +> ACCVector bknd m r +-- in m instance ( VectorSpace r , ValidACCVector b n r - , IsExpScalar r + , Ord (A.Acc (A.Scalar r)) + , Normed (A.Acc (A.Scalar r)) , ExpField r , Real r + , A.Eq r , OrdField r + , Field (A.Acc (A.Scalar r)) , MatrixField r + , Rg (A.Exp r) + , Semigroup (A.Exp r) + , Field (A.Exp r) , KnownNat n , P.Num r ) => Hilbert (ACCVector b (n::Nat) r) where {-# INLINE (<>) #-} (<>) (ACCVector v1) (ACCVector v2) = let - singleton = A.fold (+) 0 (A.zipWith (*) v1 v2) - in A.the singleton :: A.Exp r + singlton = A.fold (+) 0.0 (A.zipWith (*) v1 v2) --This float-valued accumulator forces a Field (A.Exp r) constraint above. Is there a way to formulate the constraints such that a more general zero-value could be used? + in singlton + --- In Alegebra.Vector.hs this is defined in terms of HMatrix --- recreated here to satisfy constraints type MatrixField r = - ( IsExpScalar r - , VectorSpace r + ( + VectorSpace r , Field r ) diff --git a/stack.yaml b/stack.yaml index d012111..fbdb045 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,77 +1,33 @@ - +flags: + accelerate: + unsafe-checks: false + bounds-checks: true + debug: true + internal-checks: false +extra-include-dirs: +- /usr/local/include +- /usr/local/include +extra-lib-dirs: +- /usr/local/lib packages: - '.' - location: - git: https://github.com/AccelerateHS/accelerate.git + git: https://github.com/AccelerateHS/accelerate.git commit: aed12138a9788ff5d6289d214c84ff6108dc04bd extra-dep: true - location: git: https://github.com/AccelerateHS/accelerate-cuda commit: 05acd3adca9fd89a8ac19184afbed47d1b7d1505 extra-dep: true -#- location: -# git: https://github.com/AccelerateHS/accelerate-llvm.git - # commit: 2c26ca7755a3f5acc3a56dd0f4a23565ba620501 - # extra-dep: true - # subdirs: - # - accelerate-llvm - # - accelerate-llvm-native - # - accelerate-llvm-ptx - -# required on OS X due to https://github.com/bscarlet/llvm-general/issues/155 # - location: -# git: https://github.com/bscarlet/llvm-general.git -# commit: 1ee693cc7577aab2f3e11ec9bd7f4244a5182c89 +# git: https://github.com/AccelerateHS/accelerate-llvm/ +# commit: 2c26ca7755a3f5acc3a56dd0f4a23565ba620501 # extra-dep: true -# subdirs: -# - llvm-general - -extra-include-dirs: - - /usr/local/include - - /usr/local/include -extra-lib-dirs: - - /usr/local/lib - extra-deps: -- 'unique-0' - -# accelerate-llvm -- 'chaselev-deque-0.5.0.5' -# - 'llvm-general-pure-3.5.0.0' - -# accelerate-llvm-native -- 'libffi-0.1' - -# accelerate-llvm-ptx -- 'cuda-0.7.0.0' - -- gamma-0.9.0.2 -- language-c-quote-0.11.6.2 -- mainland-pretty-0.4.1.4 -- continued-fractions-0.9.1.1 -- converge-0.1.0.1 -- exception-mtl-0.4.0.1 -- symbol-0.2.4 +- accelerate-2.0.0.0 +- bloomfilter-2.0.1.0 +- cuda-0.7.0.0 - homoiconic-0.1.2.0 - - -# Override default flag values for local packages and extra-deps -flags: - accelerate: - unsafe-checks: false - bounds-checks: true - debug: true - internal-checks: false - # accelerate-llvm: - # debug: true - # chase-lev: true - # accelerate-llvm-native: - # debug: true - # accelerate-llvm-ptx: - # debug: true - # libnvvm: false - # llvm-general: - # shared-llvm: true -resolver: lts-5.9 -resolver: nightly-2016-06-15 +- unique-0 compiler: ghc-8.0.1 +resolver: nightly-2016-06-15 diff --git a/subhask.cabal b/subhask.cabal index e6a8382..0dc5a76 100644 --- a/subhask.cabal +++ b/subhask.cabal @@ -57,7 +57,6 @@ library SubHask.Algebra.Accelerate.Accelerate SubHask.Algebra.Accelerate.AccelerateBackend SubHask.Algebra.Accelerate.Vector - SubHask.Algebra.Accelerate.Matrix SubHask.Category @@ -178,8 +177,8 @@ library containers , vector , array , - hyperloglog , - reflection , + -- hyperloglog , + reflection -- required for hyperloglog compatibility -- hyperloglog, @@ -253,4 +252,3 @@ benchmark bench if flag(llvmsupport) ghc-options: -fllvm - diff --git a/test/TestSuite.hs b/test/TestSuite.hs index 3b61032..2570d58 100644 --- a/test/TestSuite.hs +++ b/test/TestSuite.hs @@ -1,28 +1,29 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} module Main where -import SubHask -import SubHask.Algebra.Array -import SubHask.Algebra.Group -import SubHask.Algebra.Container -import SubHask.Algebra.Logic -import SubHask.Algebra.Metric -import SubHask.Algebra.Parallel -import SubHask.Algebra.Vector -import SubHask.Compatibility.ByteString -import SubHask.Compatibility.Containers +import SubHask +import SubHask.Algebra.Accelerate.Vector +import SubHask.Algebra.Array +import SubHask.Algebra.Container +import SubHask.Algebra.Group +import SubHask.Algebra.Logic +import SubHask.Algebra.Metric +import SubHask.Algebra.Parallel +import SubHask.Algebra.Vector +import SubHask.Compatibility.ByteString +import SubHask.Compatibility.Containers -import SubHask.TemplateHaskell.Deriving -import SubHask.TemplateHaskell.Test +import SubHask.TemplateHaskell.Deriving +import SubHask.TemplateHaskell.Test -import Test.Framework (defaultMain, testGroup) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.Framework.Runners.Console -import Test.Framework.Runners.Options +import Test.Framework (defaultMain, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.Framework.Runners.Console +import Test.Framework.Runners.Options -------------------------------------------------------------------------------- @@ -49,6 +50,13 @@ main = defaultMainWithOpts , $( mkSpecializedClassTests [t| SVector "dyn" Int |] [ ''Module ] ) , $( mkSpecializedClassTests [t| UVector "dyn" Int |] [ ''Module ] ) ] + , testGroup "accelerate-vector" + [ $( mkSpecializedClassTests [t| ACCVector 0 Int |] [ ''Module ] ) + , $( mkSpecializedClassTests [t| ACCVector 1 Int |] [ ''Module ] ) + , $( mkSpecializedClassTests [t| ACCVector 2 Int |] [ ''Module ] ) + , $( mkSpecializedClassTests [t| ACCVector 19 Int |] [ ''Module ] ) + , $( mkSpecializedClassTests [t| ACCVector 1001 Int |] [ ''Module ] ) + ] , testGroup "non-numeric" [ $( mkSpecializedClassTests [t| Bool |] [''Enum,''Boolean] ) , $( mkSpecializedClassTests [t| Char |] [''Enum,''Bounded] ) From b2bec0cfd50b8fb4cbf9e1df405a3a19a867f721 Mon Sep 17 00:00:00 2001 From: tpierson Date: Tue, 26 Jul 2016 22:07:02 -0400 Subject: [PATCH 12/20] updated test deps --- subhask.cabal | 5 ++++- test/TestSuite.hs | 17 ++++++++++------- 2 files changed, 14 insertions(+), 8 deletions(-) diff --git a/subhask.cabal b/subhask.cabal index 0dc5a76..f5683e5 100644 --- a/subhask.cabal +++ b/subhask.cabal @@ -200,7 +200,10 @@ Test-Suite test build-depends: subhask, test-framework-quickcheck2, - test-framework + test-framework, + accelerate , + accelerate-cuda , + cuda if flag(dotestoptimise) ghc-options: -O2 if flag(llvmsupport) diff --git a/test/TestSuite.hs b/test/TestSuite.hs index 2570d58..4c59cd4 100644 --- a/test/TestSuite.hs +++ b/test/TestSuite.hs @@ -5,7 +5,9 @@ module Main where +import qualified Data.Array.Accelerate as A import SubHask +import SubHask.Algebra.Accelerate.AccelerateBackend import SubHask.Algebra.Accelerate.Vector import SubHask.Algebra.Array import SubHask.Algebra.Container @@ -20,8 +22,9 @@ import SubHask.Compatibility.Containers import SubHask.TemplateHaskell.Deriving import SubHask.TemplateHaskell.Test -import Test.Framework (defaultMain, testGroup) -import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.Framework (defaultMain, + testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.Framework.Runners.Console import Test.Framework.Runners.Options @@ -51,11 +54,11 @@ main = defaultMainWithOpts , $( mkSpecializedClassTests [t| UVector "dyn" Int |] [ ''Module ] ) ] , testGroup "accelerate-vector" - [ $( mkSpecializedClassTests [t| ACCVector 0 Int |] [ ''Module ] ) - , $( mkSpecializedClassTests [t| ACCVector 1 Int |] [ ''Module ] ) - , $( mkSpecializedClassTests [t| ACCVector 2 Int |] [ ''Module ] ) - , $( mkSpecializedClassTests [t| ACCVector 19 Int |] [ ''Module ] ) - , $( mkSpecializedClassTests [t| ACCVector 1001 Int |] [ ''Module ] ) + [ $( mkSpecializedClassTests [t| ACCVector Interpreter 3 Int |] [ ''Module ] ) + , $( mkSpecializedClassTests [t| ACCVector Interpreter 1 Int |] [ ''Module ] ) + , $( mkSpecializedClassTests [t| ACCVector Interpreter 2 Int |] [ ''Module ] ) + , $( mkSpecializedClassTests [t| ACCVector Interpreter 19 Int |] [ ''Module ] ) + , $( mkSpecializedClassTests [t| ACCVector Interpreter 1001 Int |] [ ''Module ] ) ] , testGroup "non-numeric" [ $( mkSpecializedClassTests [t| Bool |] [''Enum,''Boolean] ) From 6eb2b16b0502b7fbea25cbd6a6f6f4608ed2d8f3 Mon Sep 17 00:00:00 2001 From: tpierson Date: Mon, 1 Aug 2016 21:26:16 -0400 Subject: [PATCH 13/20] check --- test/TestSuite.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/TestSuite.hs b/test/TestSuite.hs index 4c59cd4..5196870 100644 --- a/test/TestSuite.hs +++ b/test/TestSuite.hs @@ -54,7 +54,7 @@ main = defaultMainWithOpts , $( mkSpecializedClassTests [t| UVector "dyn" Int |] [ ''Module ] ) ] , testGroup "accelerate-vector" - [ $( mkSpecializedClassTests [t| ACCVector Interpreter 3 Int |] [ ''Module ] ) + [ $( mkSpecializedClassTests [t| ACCVector Interpreter 0 Int |] [ ''Module ] ) , $( mkSpecializedClassTests [t| ACCVector Interpreter 1 Int |] [ ''Module ] ) , $( mkSpecializedClassTests [t| ACCVector Interpreter 2 Int |] [ ''Module ] ) , $( mkSpecializedClassTests [t| ACCVector Interpreter 19 Int |] [ ''Module ] ) From 8243a2b37db96c6dfcd8fb57b9af5b4c35647333 Mon Sep 17 00:00:00 2001 From: tpierson Date: Sat, 13 Aug 2016 22:31:45 -0400 Subject: [PATCH 14/20] reworked all ~Scalar instances to be of A.Acc (A.Scalar r) --- src/SubHask/Algebra/Accelerate/Vector.hs | 109 +++++++++++++---------- 1 file changed, 60 insertions(+), 49 deletions(-) diff --git a/src/SubHask/Algebra/Accelerate/Vector.hs b/src/SubHask/Algebra/Accelerate/Vector.hs index 18e4ecb..80814c4 100644 --- a/src/SubHask/Algebra/Accelerate/Vector.hs +++ b/src/SubHask/Algebra/Accelerate/Vector.hs @@ -39,33 +39,54 @@ import Unsafe.Coerce newtype ACCVector (bknd::Backend) (n::k) a = ACCVector (A.Acc (A.Array A.DIM1 a)) -type instance Scalar (ACCVector bknd n r) = Scalar (A.Acc(A.Scalar r)) -type instance Logic (ACCVector bknd n r) = Logic (A.Acc(A.Scalar Bool)) +type instance Scalar (ACCVector bknd n r) = A.Acc(A.Scalar r) +type instance Logic (ACCVector bknd n r) = A.Acc(A.Scalar Bool) type ValidACCVector bknd n a = ( Prim a , A.Elt a , P.Num (A.Exp a) , Scalar (A.Acc (A.Scalar a)) ~ A.Acc (A.Scalar a) - , Logic (A.Acc (A.Scalar a)) ~ A.Acc (A.Scalar a) - , Actor (A.Acc (A.Scalar a)) ~ A.Acc (A.Scalar a) - , Container (A.Acc (A.Scalar a)) - , Container (Logic (A.Acc (A.Scalar Bool))) - , Boolean (Logic (A.Acc (A.Scalar Bool))) - , Logic (Logic (A.Acc (A.Scalar Bool))) ~ Logic (A.Acc (A.Scalar Bool)) - , Logic (A.Acc (A.Scalar Bool)) ~ A.Acc (A.Scalar Bool) - , Elem (A.Acc (A.Scalar a)) ~ A.Acc (A.Scalar a) - , P.Fractional (A.Exp a) - , P.Floating (A.Exp a) + , Ring (A.Acc (A.Scalar a)) + , Logic (Logic (A.Acc (A.Scalar Bool))) ~ Logic (A.Acc (A.Scalar Bool)) + , Container (A.Acc (A.Scalar Bool)) + , Boolean (A.Acc (A.Scalar Bool)) + , Ord (A.Acc (A.Scalar a)) + , Normed (A.Acc (A.Scalar a)) + , Vector (ACCVector bknd n a) + , Vector (Square (ACCVector bknd n a)) + , Elem (Square (ACCVector bknd n a)) ~ ACCVector bknd n a + , Semigroup (A.Exp a) + , Field (A.Exp a) + , Rg (A.Exp a) + , Index (Square (ACCVector bknd n a)) ~ A.Acc (A.Scalar Int) + -- , Logic (A.Acc (A.Scalar a)) ~ A.Acc (A.Scalar a) + -- , Actor (A.Acc (A.Scalar a)) ~ A.Acc (A.Scalar a) + -- , Container (A.Acc (A.Scalar a)) + -- , Container (Logic (A.Acc (A.Scalar Bool))) + -- , Boolean (Logic (A.Acc (A.Scalar Bool))) + -- , Logic (Logic (A.Acc (A.Scalar Bool))) ~ Logic (A.Acc (A.Scalar Bool)) + -- , Logic (A.Acc (A.Scalar Bool)) ~ A.Acc (A.Scalar Bool) + -- , Elem (A.Acc (A.Scalar a)) ~ A.Acc (A.Scalar a) + -- , P.Fractional (A.Exp a) + -- , P.Floating (A.Exp a) , P.Floating (A.Acc (A.Scalar a)) , P.Floating (A.Acc (A.Array A.DIM0 a)) + -- , Elem (Square (ACCVector bknd n a)) ~ ACCVector bknd n a + -- , Index (Square (ACCVector bknd n a)) ~ A.Acc (A.Scalar Int) + -- , Index (A.Acc (A.Scalar Int)) ~ A.Acc (A.Scalar Int) + -- , Vector (Square (ACCVector bknd n a)) + -- , Transposable (Square (ACCVector bknd n a)) + -- , IxContainer (Square (ACCVector bknd n a)) + -- , FreeModule a + -- , Vector (ACCVector bknd n a) ) -type instance Index (ACCVector bknd n r) = Index (A.Acc(A.Scalar Int)) -type instance Elem (ACCVector bknd n r) = Elem (A.Acc(A.Scalar r)) +type instance Index (ACCVector bknd n r) = A.Acc(A.Scalar Int) +type instance Elem (ACCVector bknd n r) = A.Acc(A.Scalar r) -type instance Actor (ACCVector (bknd::Backend) n r) = Actor (A.Acc(A.Scalar r)) +type instance Actor (ACCVector (bknd::Backend) n r) = A.Acc(A.Scalar r) instance (KnownNat n, Prim a) => IsMutable (ACCVector (bknd::Backend) (n::Nat) a) @@ -74,7 +95,7 @@ instance (KnownNat n, Monoid r, ValidACCVector b n r) => Semigroup (ACCVector (b (+) :: ACCVector bknd n r -> ACCVector bknd n r -> ACCVector bknd n r (+) (ACCVector v1) (ACCVector v2)=ACCVector (A.zipWith (P.+) v1 v2) -instance (Semigroup (Actor (A.Acc (A.Scalar r))), KnownNat n, ValidACCVector bknd n r, Action r, Semigroup r, Prim r) => Action (ACCVector (bknd::Backend) (n::Nat) r) where +instance (Semigroup (A.Acc (A.Scalar r)), KnownNat n, ValidACCVector bknd n r, Action r, Semigroup r, Prim r) => Action (ACCVector (bknd::Backend) (n::Nat) r) where {-# INLINE (.+) #-} (.+) (ACCVector v) r = ACCVector (A.map (A.+ (A.the r)) v) @@ -95,22 +116,22 @@ instance (KnownNat n, Group r, ValidACCVector bknd n r) => Group (ACCVector (bkn instance (KnownNat n, Monoid r, Abelian r, ValidACCVector bknd n r) => Abelian (ACCVector (bknd::Backend) (n::Nat) r) -instance (Ring (A.Acc (A.Scalar r)), KnownNat n, FreeModule r, ValidACCVector bknd n r) => FreeModule (ACCVector (bknd::Backend) (n::Nat) r) where +instance ( KnownNat n, FreeModule r, ValidACCVector bknd n r) => FreeModule (ACCVector (bknd::Backend) (n::Nat) r) where {-# INLINE (.*.) #-} (.*.) (ACCVector a1) (ACCVector a2) = ACCVector( A.zipWith (P.*) a1 a2) -instance (Ring (A.Acc (A.Scalar r)), KnownNat n, Module r, ValidACCVector bknd n r) => Module (ACCVector (bknd::Backend) (n::Nat) r) where +instance ( KnownNat n, Module r, ValidACCVector bknd n r) => Module (ACCVector (bknd::Backend) (n::Nat) r) where {-# INLINE (.*) #-} (.*) (ACCVector v) r = ACCVector (A.map (P.* (A.the r)) v) -instance (Field (A.Acc (A.Scalar r)), KnownNat n, VectorSpace r, ValidACCVector bknd n r) => VectorSpace (ACCVector (bknd::Backend) (n::Nat) r) where - {-# INLINE (./) #-} - (./) (ACCVector v) r = ACCVector (A.map (P./ (A.the r)) v) +-- instance (Field (A.Acc (A.Scalar r)), KnownNat n, VectorSpace r, ValidACCVector bknd n r) => VectorSpace (ACCVector (bknd::Backend) (n::Nat) r) where +-- {-# INLINE (./) #-} +-- (./) (ACCVector v) r = ACCVector (A.map (P./ (A.the r)) v) +-- +-- {-# INLINE (./.) #-} +-- (./.) (ACCVector a1) (ACCVector a2) = ACCVector (A.zipWith (P./) a1 a2) - {-# INLINE (./.) #-} - (./.) (ACCVector a1) (ACCVector a2) = ACCVector (A.zipWith (P./) a1 a2) - -instance (Index (A.Acc (A.Scalar Int)) ~ A.Acc (A.Scalar Int), Ring (A.Acc (A.Scalar r)), KnownNat n, FreeModule r, ValidACCVector b n r) => FiniteModule (ACCVector b (n::Nat) r) +instance (KnownNat n, FreeModule r, ValidACCVector b n r) => FiniteModule (ACCVector b (n::Nat) r) --dim wants an Int but here gets an A.Exp Int. I tried changing the signiture to a generic type in Alegbra.hs but that produced numerous errors. where -- dim :: ACCVector b (n::Nat) r -> A.Exp Int @@ -119,16 +140,18 @@ instance (Index (A.Acc (A.Scalar Int)) ~ A.Acc (A.Scalar Int), Ring (A.Acc (A.Sc instance - ( Monoid r + ( + Eq r + , A.Eq r + , Monoid r , ValidACCVector b n r , KnownNat n - , Index (A.Acc (A.Scalar Int)) ~ A.Acc (A.Scalar Int) , FreeModule r ) => IxContainer (ACCVector b (n::Nat) r) where {-# INLINE (!) #-} - (!) (ACCVector v) i = A.unit (v A.! A.index1 (A.the (i:: Index(A.Acc (A.Scalar Int))))) + (!) (ACCVector v) i = A.unit (v A.! A.index1 (A.the (i))) -- {-# INLINABLE imap #-} -- -- imap f (ACCVector v) = A.zipWith (\i x -> f ((A.unit i)::A.Acc (A.Scalar Int)) ((A.unit x)::A.Acc (A.Scalar r))) ((A.generate (A.shape v) P.id):: A.Array A.DIM1 Int) v @@ -142,7 +165,7 @@ instance instance (A.Eq r, KnownNat n, Eq r, Monoid r, ValidACCVector b n r) => Eq (ACCVector b (n::Nat) r) where {-# INLINE (==) #-} (ACCVector v2) == (ACCVector v1) = let - l = A.zipWith (\x y -> x A.==* y) v1 v2 :: A.Acc (A.Array A.DIM1 Bool) + l = A.zipWith (\x y -> x A.==* y) v1 v2 ele = l A.! A.index1 (A.constant 0) bl = A.all (A.&&* ele) l in bl @@ -151,11 +174,8 @@ instance ( ValidACCVector b n r , A.Eq r , ExpField r - , Ord (A.Acc (A.Scalar r)) - , Normed (A.Acc (A.Scalar r)) - , Ring (A.Acc (A.Scalar r)) , Ord r - , VectorSpace r + -- , VectorSpace r , KnownNat n ) => Metric (ACCVector b (n::Nat) r) @@ -167,7 +187,7 @@ instance drt = A.sqrt (A.sum dsq) in drt -instance (Ring (A.Acc (A.Scalar r)), Ord (A.Acc (A.Scalar r)), Ord r, KnownNat n, VectorSpace r, ValidACCVector b n r, ExpField r) => Normed (ACCVector b (n::Nat) r) where +instance (KnownNat n, ValidACCVector b n r, ExpField r) => Normed (ACCVector b (n::Nat) r) where {-# INLINE size #-} size (ACCVector v1) = let sq = A.zipWith (P.*) v1 v1 @@ -176,13 +196,9 @@ instance (Ring (A.Acc (A.Scalar r)), Ord (A.Acc (A.Scalar r)), Ord r, KnownNat in srt instance - ( VectorSpace r - , A.Eq r + ( A.Eq r , Normed r - , Normed (A.Acc (A.Scalar r)) , ValidACCVector b n r - , Field (A.Acc (A.Scalar r)) - , Ord (A.Acc (A.Scalar r)) , ExpField r , Real r , Ord r @@ -205,19 +221,15 @@ instance -- in m instance - ( VectorSpace r - , ValidACCVector b n r - , Ord (A.Acc (A.Scalar r)) - , Normed (A.Acc (A.Scalar r)) + ( ValidACCVector b n r + , Transposable (Square (ACCVector b n r)) + , IxContainer (Square (ACCVector b n r)) + , FreeModule r , ExpField r , Real r , A.Eq r , OrdField r - , Field (A.Acc (A.Scalar r)) , MatrixField r - , Rg (A.Exp r) - , Semigroup (A.Exp r) - , Field (A.Exp r) , KnownNat n , P.Num r ) => Hilbert (ACCVector b (n::Nat) r) @@ -230,6 +242,5 @@ instance type MatrixField r = ( - VectorSpace r - , Field r + Field r ) From 9d8f7a8a635a52bcd12980e2924d88ca735b0464 Mon Sep 17 00:00:00 2001 From: Tim Pierson Date: Thu, 1 Sep 2016 09:10:43 -0400 Subject: [PATCH 15/20] picking up work again --- .haskell-ghc-mod.json | 1 + examples/example0005-accelerate_backend.lhs | 32 +++++++++--------- src/SubHask/Algebra/Accelerate/Accelerate.hs | 4 +-- src/SubHask/Algebra/Accelerate/Vector.hs | 35 +++++++++++--------- 4 files changed, 39 insertions(+), 33 deletions(-) create mode 100644 .haskell-ghc-mod.json diff --git a/.haskell-ghc-mod.json b/.haskell-ghc-mod.json new file mode 100644 index 0000000..c82d1fe --- /dev/null +++ b/.haskell-ghc-mod.json @@ -0,0 +1 @@ +{ "suppressErrors": true } diff --git a/examples/example0005-accelerate_backend.lhs b/examples/example0005-accelerate_backend.lhs index 1acf081..2d7dc94 100644 --- a/examples/example0005-accelerate_backend.lhs +++ b/examples/example0005-accelerate_backend.lhs @@ -10,27 +10,27 @@ > import SubHask > import SubHask.Algebra.Accelerate.Vector (ACCVector) > import SubHask.Algebra.Vector (UVector) -> import SubHask.Algebra.Matrix (Matrix, unsafeToModuleM) -> import SubHask.Algebra.Accelerate.Matrix (ACCMatrix, mmult) -> import SubHask.Algebra.Accelerate.Accelerate (ValidBackend(..), mkAccVector, mkAccVectorFromList, mkAccMatrixFromList, mkAccMatrixFromMatrix) +> --import SubHask.Algebra.Matrix (Matrix, unsafeToModuleM) +> --import SubHask.Algebra.Accelerate.Matrix (ACCMatrix, mmult) +> import SubHask.Algebra.Accelerate.Accelerate (ValidBackend(..), mkAccVectorFromList) > import SubHask.Algebra.Accelerate.AccelerateBackend (Backend(..)) > import System.IO > -> v :: ACCVector Interpreter "a" Double -> v = mkAccVectorFromList [0..5] +> v :: ACCVector Interpreter 6 Double +> v = mkAccVectorFromList [0.0, 1.0, 2.0, 3.0, 4.0, 5.0] > -> v' :: ACCVector Interpreter "a" Double +> v' :: ACCVector Interpreter 6 Double > v' = mkAccVectorFromList [0..5] > > -> mmat :: Matrix (UVector "v" Double) Double "a" "b" -> mmat = unsafeToModuleM 2 [0..5] +> --mmat :: Matrix (UVector "v" Double) Double "a" "b" +> --mmat = unsafeToModuleM 2 [0..5] > -> m :: ACCMatrix Interpreter (ACCVector Interpreter "v" Double ) "a" "b" Double -> m = mkAccMatrixFromMatrix mmat +> --m :: ACCMatrix Interpreter (ACCVector Interpreter "v" Double ) "a" "b" Double +> --m = mkAccMatrixFromMatrix mmat > -> mm :: ACCMatrix Interpreter (ACCVector Interpreter "v" Double ) "b" "a" Double -> mm = mkAccMatrixFromList 5 [0,1,2,3,4,5,6,7,8,9] +> --mm :: ACCMatrix Interpreter (ACCVector Interpreter "v" Double ) "b" "a" Double +> --mm = mkAccMatrixFromList 5 [0,1,2,3,4,5,6,7,8,9] > > main :: IO () > main = do @@ -41,7 +41,7 @@ > putStrLn $ "v * v / v = " ++ show (runAccVector (v .*. v ./. v')) > putStrLn $ "v' * 2 = " ++ show (runAccVector (v' .* 2)) > putStrLn $ "v' * 2 = " ++ show (runAccVector (v' .* 2)) -> putStrLn $ "m * 2 = " ++ show (runAccMatrix (m .* 2)) -> putStrLn $ "m + 2 = " ++ show (runAccMatrix ((m + 2) - 1 )) -> putStrLn $ "m / 2 = " ++ show (runAccMatrix (m / 2)) -> putStrLn $ "m mmult mm = " ++ show (runAccMatrix (mmult m mm)) +> --putStrLn $ "m * 2 = " ++ show (runAccMatrix (m .* 2)) +> --putStrLn $ "m + 2 = " ++ show (runAccMatrix ((m + 2) - 1 )) +> --putStrLn $ "m / 2 = " ++ show (runAccMatrix (m / 2)) +> --putStrLn $ "m mmult mm = " ++ show (runAccMatrix (mmult m mm)) diff --git a/src/SubHask/Algebra/Accelerate/Accelerate.hs b/src/SubHask/Algebra/Accelerate/Accelerate.hs index 4baffaa..a413175 100644 --- a/src/SubHask/Algebra/Accelerate/Accelerate.hs +++ b/src/SubHask/Algebra/Accelerate/Accelerate.hs @@ -20,7 +20,7 @@ import SubHask.Internal.Prelude import qualified Prelude as P --FIXME: Replace all intermediary lists with correct use of acclerate-io -mkAccVectorFromList :: A.Elt a => [a] -> ACCVector bknd (n::Symbol) a +mkAccVectorFromList :: A.Elt a => [a] -> ACCVector bknd (n::Nat) a mkAccVectorFromList l = let len = P.length l in ACCVector (A.use (A.fromList (A.Z A.:.len) l)) @@ -39,7 +39,7 @@ mkAccVectorFromList l = let class ValidBackend (b::Backend) where - runAccVector :: (ValidACCVector (b::Backend) n a, A.IsScalar a) => ACCVector (b::Backend) n a -> [a] + runAccVector :: (ValidACCVector (b::Backend) n a) => ACCVector (b::Backend) n a -> [a] -- runAccMatrix :: (ValidACCMatrix (b::Backend) v r, A.IsScalar a, A.Elt a) => ACCMatrix (b::Backend) v n m a -> [a] instance ValidBackend 'Interpreter where diff --git a/src/SubHask/Algebra/Accelerate/Vector.hs b/src/SubHask/Algebra/Accelerate/Vector.hs index 80814c4..0531ff4 100644 --- a/src/SubHask/Algebra/Accelerate/Vector.hs +++ b/src/SubHask/Algebra/Accelerate/Vector.hs @@ -2,6 +2,7 @@ module SubHask.Algebra.Accelerate.Vector ( ValidACCVector , ACCVector (..) + ) where @@ -37,30 +38,28 @@ import Unsafe.Coerce -- | Accelerate based Vector -- | A.Acc is an accelreate computation, A.Array A.DIM1 a is a one dimensional array -newtype ACCVector (bknd::Backend) (n::k) a = ACCVector (A.Acc (A.Array A.DIM1 a)) +newtype ACCVector (bknd::Backend) (n::Nat) a = ACCVector (A.Acc (A.Array A.DIM1 a)) type instance Scalar (ACCVector bknd n r) = A.Acc(A.Scalar r) -type instance Logic (ACCVector bknd n r) = A.Acc(A.Scalar Bool) +type instance Logic (ACCVector bknd n r) = A.Acc(A.Scalar r) type ValidACCVector bknd n a = ( Prim a , A.Elt a , P.Num (A.Exp a) - , Scalar (A.Acc (A.Scalar a)) ~ A.Acc (A.Scalar a) + --, Scalar (A.Acc (A.Scalar a)) ~ A.Acc (A.Scalar a) , Ring (A.Acc (A.Scalar a)) - , Logic (Logic (A.Acc (A.Scalar Bool))) ~ Logic (A.Acc (A.Scalar Bool)) + --, Logic (Logic (A.Acc (A.Scalar Bool))) ~ Logic (A.Acc (A.Scalar Bool)) , Container (A.Acc (A.Scalar Bool)) , Boolean (A.Acc (A.Scalar Bool)) , Ord (A.Acc (A.Scalar a)) , Normed (A.Acc (A.Scalar a)) , Vector (ACCVector bknd n a) , Vector (Square (ACCVector bknd n a)) - , Elem (Square (ACCVector bknd n a)) ~ ACCVector bknd n a + , Semigroup (A.Exp a) , Field (A.Exp a) , Rg (A.Exp a) - , Index (Square (ACCVector bknd n a)) ~ A.Acc (A.Scalar Int) - -- , Logic (A.Acc (A.Scalar a)) ~ A.Acc (A.Scalar a) -- , Actor (A.Acc (A.Scalar a)) ~ A.Acc (A.Scalar a) -- , Container (A.Acc (A.Scalar a)) -- , Container (Logic (A.Acc (A.Scalar Bool))) @@ -71,7 +70,7 @@ type ValidACCVector bknd n a = ( -- , P.Fractional (A.Exp a) -- , P.Floating (A.Exp a) , P.Floating (A.Acc (A.Scalar a)) - , P.Floating (A.Acc (A.Array A.DIM0 a)) + --, P.Floating (A.Acc (A.Array A.DIM0 a)) -- , Elem (Square (ACCVector bknd n a)) ~ ACCVector bknd n a -- , Index (Square (ACCVector bknd n a)) ~ A.Acc (A.Scalar Int) -- , Index (A.Acc (A.Scalar Int)) ~ A.Acc (A.Scalar Int) @@ -146,6 +145,7 @@ instance , Monoid r , ValidACCVector b n r , KnownNat n + , Eq (ACCVector b n r) , FreeModule r ) => IxContainer (ACCVector b (n::Nat) r) where @@ -162,19 +162,20 @@ instance type ValidElem (ACCVector b n r) e = (FiniteModule e, ValidACCVector b n e) -instance (A.Eq r, KnownNat n, Eq r, Monoid r, ValidACCVector b n r) => Eq (ACCVector b (n::Nat) r) where - {-# INLINE (==) #-} - (ACCVector v2) == (ACCVector v1) = let - l = A.zipWith (\x y -> x A.==* y) v1 v2 - ele = l A.! A.index1 (A.constant 0) - bl = A.all (A.&&* ele) l - in bl +-- instance (A.Eq r, KnownNat n, Eq r, Monoid r, ValidACCVector b n r) => Eq (ACCVector b (n::Nat) r) where +-- {-# INLINE (==) #-} +-- (ACCVector v2) == (ACCVector v1) = let +-- l = A.zipWith (\x y -> x A.==* y) v1 v2 +-- ele = l A.! A.index1 (A.constant 0) +-- bl = A.all (A.&&* ele) l +-- in bl instance ( ValidACCVector b n r , A.Eq r , ExpField r , Ord r + , Eq (ACCVector b n r) -- , VectorSpace r , KnownNat n ) => Metric (ACCVector b (n::Nat) r) @@ -201,6 +202,7 @@ instance , ValidACCVector b n r , ExpField r , Real r + , Eq (ACCVector b n r) , Ord r , KnownNat n ) => Banach (ACCVector b (n::Nat) r) @@ -226,12 +228,15 @@ instance , IxContainer (Square (ACCVector b n r)) , FreeModule r , ExpField r + , Eq (ACCVector b n r) , Real r , A.Eq r , OrdField r + , Index (Square (ACCVector b n r)) ~ A.Acc (A.Scalar Int) , MatrixField r , KnownNat n , P.Num r + , Elem (Square (ACCVector b n r)) ~ ACCVector b n r ) => Hilbert (ACCVector b (n::Nat) r) where {-# INLINE (<>) #-} From 9b39b78484c9adb0295e2af202aec92e6cf0618a Mon Sep 17 00:00:00 2001 From: tpierson Date: Sat, 8 Oct 2016 22:55:19 -0400 Subject: [PATCH 16/20] Still fails --- src/SubHask/Algebra/Accelerate/Vector.hs | 125 ++++++++++------------- 1 file changed, 53 insertions(+), 72 deletions(-) diff --git a/src/SubHask/Algebra/Accelerate/Vector.hs b/src/SubHask/Algebra/Accelerate/Vector.hs index 0531ff4..f9d1aa7 100644 --- a/src/SubHask/Algebra/Accelerate/Vector.hs +++ b/src/SubHask/Algebra/Accelerate/Vector.hs @@ -40,52 +40,21 @@ import Unsafe.Coerce newtype ACCVector (bknd::Backend) (n::Nat) a = ACCVector (A.Acc (A.Array A.DIM1 a)) -type instance Scalar (ACCVector bknd n r) = A.Acc(A.Scalar r) -type instance Logic (ACCVector bknd n r) = A.Acc(A.Scalar r) +type instance Scalar (ACCVector bknd n r) = A.Exp r +type instance Logic (ACCVector bknd n r) = A.Exp r type ValidACCVector bknd n a = ( Prim a , A.Elt a , P.Num (A.Exp a) - --, Scalar (A.Acc (A.Scalar a)) ~ A.Acc (A.Scalar a) - , Ring (A.Acc (A.Scalar a)) - --, Logic (Logic (A.Acc (A.Scalar Bool))) ~ Logic (A.Acc (A.Scalar Bool)) - , Container (A.Acc (A.Scalar Bool)) - , Boolean (A.Acc (A.Scalar Bool)) - , Ord (A.Acc (A.Scalar a)) - , Normed (A.Acc (A.Scalar a)) - , Vector (ACCVector bknd n a) - , Vector (Square (ACCVector bknd n a)) - - , Semigroup (A.Exp a) - , Field (A.Exp a) - , Rg (A.Exp a) - -- , Actor (A.Acc (A.Scalar a)) ~ A.Acc (A.Scalar a) - -- , Container (A.Acc (A.Scalar a)) - -- , Container (Logic (A.Acc (A.Scalar Bool))) - -- , Boolean (Logic (A.Acc (A.Scalar Bool))) - -- , Logic (Logic (A.Acc (A.Scalar Bool))) ~ Logic (A.Acc (A.Scalar Bool)) - -- , Logic (A.Acc (A.Scalar Bool)) ~ A.Acc (A.Scalar Bool) - -- , Elem (A.Acc (A.Scalar a)) ~ A.Acc (A.Scalar a) - -- , P.Fractional (A.Exp a) - -- , P.Floating (A.Exp a) - , P.Floating (A.Acc (A.Scalar a)) - --, P.Floating (A.Acc (A.Array A.DIM0 a)) - -- , Elem (Square (ACCVector bknd n a)) ~ ACCVector bknd n a - -- , Index (Square (ACCVector bknd n a)) ~ A.Acc (A.Scalar Int) - -- , Index (A.Acc (A.Scalar Int)) ~ A.Acc (A.Scalar Int) - -- , Vector (Square (ACCVector bknd n a)) - -- , Transposable (Square (ACCVector bknd n a)) - -- , IxContainer (Square (ACCVector bknd n a)) - -- , FreeModule a - -- , Vector (ACCVector bknd n a) + , Scalar (A.Exp a) ~ A.Exp a ) -type instance Index (ACCVector bknd n r) = A.Acc(A.Scalar Int) -type instance Elem (ACCVector bknd n r) = A.Acc(A.Scalar r) +type instance Index (ACCVector bknd n r) = A.Exp Int +type instance Elem (ACCVector bknd n r) = A.Exp r -type instance Actor (ACCVector (bknd::Backend) n r) = A.Acc(A.Scalar r) +type instance Actor (ACCVector (bknd::Backend) n r) = A.Exp r instance (KnownNat n, Prim a) => IsMutable (ACCVector (bknd::Backend) (n::Nat) a) @@ -94,9 +63,9 @@ instance (KnownNat n, Monoid r, ValidACCVector b n r) => Semigroup (ACCVector (b (+) :: ACCVector bknd n r -> ACCVector bknd n r -> ACCVector bknd n r (+) (ACCVector v1) (ACCVector v2)=ACCVector (A.zipWith (P.+) v1 v2) -instance (Semigroup (A.Acc (A.Scalar r)), KnownNat n, ValidACCVector bknd n r, Action r, Semigroup r, Prim r) => Action (ACCVector (bknd::Backend) (n::Nat) r) where +instance (Semigroup (A.Exp r), KnownNat n, ValidACCVector bknd n r, Action r, Semigroup r, Prim r) => Action (ACCVector (bknd::Backend) (n::Nat) r) where {-# INLINE (.+) #-} - (.+) (ACCVector v) r = ACCVector (A.map (A.+ (A.the r)) v) + (.+) (ACCVector v) r = ACCVector (A.map (A.+ (r)) v) instance (KnownNat n, Monoid r, Cancellative r, ValidACCVector bknd n r) => Cancellative (ACCVector (bknd::Backend) (n::Nat) r) where {-# INLINE (-) #-} @@ -115,13 +84,13 @@ instance (KnownNat n, Group r, ValidACCVector bknd n r) => Group (ACCVector (bkn instance (KnownNat n, Monoid r, Abelian r, ValidACCVector bknd n r) => Abelian (ACCVector (bknd::Backend) (n::Nat) r) -instance ( KnownNat n, FreeModule r, ValidACCVector bknd n r) => FreeModule (ACCVector (bknd::Backend) (n::Nat) r) where +instance (Ring (A.Exp r), KnownNat n, FreeModule r, ValidACCVector bknd n r) => FreeModule (ACCVector (bknd::Backend) (n::Nat) r) where {-# INLINE (.*.) #-} (.*.) (ACCVector a1) (ACCVector a2) = ACCVector( A.zipWith (P.*) a1 a2) -instance ( KnownNat n, Module r, ValidACCVector bknd n r) => Module (ACCVector (bknd::Backend) (n::Nat) r) where +instance (Ring (A.Exp r), KnownNat n, Module r, ValidACCVector bknd n r) => Module (ACCVector (bknd::Backend) (n::Nat) r) where {-# INLINE (.*) #-} - (.*) (ACCVector v) r = ACCVector (A.map (P.* (A.the r)) v) + (.*) (ACCVector v) r = ACCVector (A.map (P.* (r)) v) -- instance (Field (A.Acc (A.Scalar r)), KnownNat n, VectorSpace r, ValidACCVector bknd n r) => VectorSpace (ACCVector (bknd::Backend) (n::Nat) r) where -- {-# INLINE (./) #-} @@ -130,7 +99,7 @@ instance ( KnownNat n, Module r, ValidACCVector bknd n r) => Module (ACCVector ( -- {-# INLINE (./.) #-} -- (./.) (ACCVector a1) (ACCVector a2) = ACCVector (A.zipWith (P./) a1 a2) -instance (KnownNat n, FreeModule r, ValidACCVector b n r) => FiniteModule (ACCVector b (n::Nat) r) +instance (Ring (A.Exp r), KnownNat n, FreeModule r, ValidACCVector b n r) => FiniteModule (ACCVector b (n::Nat) r) --dim wants an Int but here gets an A.Exp Int. I tried changing the signiture to a generic type in Alegbra.hs but that produced numerous errors. where -- dim :: ACCVector b (n::Nat) r -> A.Exp Int @@ -149,9 +118,9 @@ instance , FreeModule r ) => IxContainer (ACCVector b (n::Nat) r) where - - {-# INLINE (!) #-} - (!) (ACCVector v) i = A.unit (v A.! A.index1 (A.the (i))) + -- + -- {-# INLINE (!) #-} + -- (!) (ACCVector v) i = A.unit (v A.! A.index1 i) -- {-# INLINABLE imap #-} -- -- imap f (ACCVector v) = A.zipWith (\i x -> f ((A.unit i)::A.Acc (A.Scalar Int)) ((A.unit x)::A.Acc (A.Scalar r))) ((A.generate (A.shape v) P.id):: A.Array A.DIM1 Int) v @@ -172,37 +141,45 @@ instance instance ( ValidACCVector b n r + , Normed (A.Exp r) , A.Eq r , ExpField r , Ord r + , Ring (A.Exp r) , Eq (ACCVector b n r) + , Boolean (A.Exp r) + , Ord (A.Exp r) -- , VectorSpace r , KnownNat n ) => Metric (ACCVector b (n::Nat) r) - where - {-# INLINE[2] distance #-} - distance (ACCVector v1) (ACCVector v2) = {-# SCC distance_ACCVector #-}let - dmag = A.zipWith (P.-) v1 v2 - dsq = A.zipWith (P.*) dmag dmag - drt = A.sqrt (A.sum dsq) - in drt - -instance (KnownNat n, ValidACCVector b n r, ExpField r) => Normed (ACCVector b (n::Nat) r) where - {-# INLINE size #-} - size (ACCVector v1) = let - sq = A.zipWith (P.*) v1 v1 - s = A.fold (P.+) (A.constant 0.0) sq - srt = A.sqrt s - in srt + -- where + -- {-# INLINE[2] distance #-} + -- distance (ACCVector v1) (ACCVector v2) = {-# SCC distance_ACCVector #-}let + -- dmag = A.zipWith (P.-) v1 v2 + -- dsq = A.zipWith (P.*) dmag dmag + -- drt = A.sqrt (A.sum dsq) + -- in drt + +instance (Ord (A.Exp r), KnownNat n, Ring (A.Exp r), ValidACCVector b n r, ExpField r) => Normed (ACCVector b (n::Nat) r) +-- where +-- {-# INLINE size #-} +-- size (ACCVector v1) = let +-- sq = A.zipWith (P.*) v1 v1 +-- s = A.fold (P.+) (A.constant 0.0) sq +-- srt = A.sqrt s +-- in srt instance ( A.Eq r , Normed r + , Eq (ACCVector b n r) + , Normed (A.Exp r) + , Ord (A.Exp r) , ValidACCVector b n r , ExpField r , Real r - , Eq (ACCVector b n r) + , Vector (ACCVector b n r) , Ord r , KnownNat n ) => Banach (ACCVector b (n::Nat) r) @@ -224,25 +201,29 @@ instance instance ( ValidACCVector b n r - , Transposable (Square (ACCVector b n r)) - , IxContainer (Square (ACCVector b n r)) + , Normed (A.Exp r) + , Eq (ACCVector b n r) , FreeModule r + , Ord (A.Exp r) + , IxContainer (Square (ACCVector b n r)) + , Transposable (Square (ACCVector b n r)) + , A.Eq r + , Vector (ACCVector b n r) + , Vector (Square (ACCVector b n r)) , ExpField r - , Eq (ACCVector b n r) + , Index (Square (ACCVector b n r)) ~ A.Exp Int , Real r - , A.Eq r , OrdField r - , Index (Square (ACCVector b n r)) ~ A.Acc (A.Scalar Int) , MatrixField r , KnownNat n , P.Num r , Elem (Square (ACCVector b n r)) ~ ACCVector b n r ) => Hilbert (ACCVector b (n::Nat) r) - where - {-# INLINE (<>) #-} - (<>) (ACCVector v1) (ACCVector v2) = let - singlton = A.fold (+) 0.0 (A.zipWith (*) v1 v2) --This float-valued accumulator forces a Field (A.Exp r) constraint above. Is there a way to formulate the constraints such that a more general zero-value could be used? - in singlton + -- where + -- {-# INLINE (<>) #-} + -- (<>) (ACCVector v1) (ACCVector v2) = let + -- singlton = A.fold (+) 0.0 (A.zipWith (*) v1 v2) --This float-valued accumulator forces a Field (A.Exp r) constraint above. Is there a way to formulate the constraints such that a more general zero-value could be used? + -- in singlton type MatrixField r = From 47ec671796e9f4d5c354d935be00ae147b2c570e Mon Sep 17 00:00:00 2001 From: tpierson Date: Sun, 9 Oct 2016 13:40:37 -0400 Subject: [PATCH 17/20] MakingProgress --- examples/example0005-accelerate_backend.lhs | 3 +- src/SubHask/Algebra/Accelerate/Accelerate.hs | 55 --------- src/SubHask/Algebra/Accelerate/Vector.hs | 118 +++++++++++++++++-- subhask.cabal | 2 - 4 files changed, 109 insertions(+), 69 deletions(-) delete mode 100644 src/SubHask/Algebra/Accelerate/Accelerate.hs diff --git a/examples/example0005-accelerate_backend.lhs b/examples/example0005-accelerate_backend.lhs index 2d7dc94..58664ab 100644 --- a/examples/example0005-accelerate_backend.lhs +++ b/examples/example0005-accelerate_backend.lhs @@ -8,11 +8,10 @@ > {-# LANGUAGE DataKinds #-} > import qualified Prelude as P > import SubHask -> import SubHask.Algebra.Accelerate.Vector (ACCVector) +> import SubHask.Algebra.Accelerate.Vector (ACCVector, ValidBackend(..), mkAccVectorFromList) > import SubHask.Algebra.Vector (UVector) > --import SubHask.Algebra.Matrix (Matrix, unsafeToModuleM) > --import SubHask.Algebra.Accelerate.Matrix (ACCMatrix, mmult) -> import SubHask.Algebra.Accelerate.Accelerate (ValidBackend(..), mkAccVectorFromList) > import SubHask.Algebra.Accelerate.AccelerateBackend (Backend(..)) > import System.IO > diff --git a/src/SubHask/Algebra/Accelerate/Accelerate.hs b/src/SubHask/Algebra/Accelerate/Accelerate.hs deleted file mode 100644 index a413175..0000000 --- a/src/SubHask/Algebra/Accelerate/Accelerate.hs +++ /dev/null @@ -1,55 +0,0 @@ -module SubHask.Algebra.Accelerate.Accelerate -( - ValidBackend(..) - -- , runAccVector - , mkAccVectorFromList - -- , mkAccMatrixFromList - -- , mkAccMatrixFromMatrix - --, acc2SVector -) -where - -import SubHask.Algebra.Accelerate.AccelerateBackend (Backend(..)) -import SubHask.Algebra.Accelerate.Vector --- import SubHask.Algebra.Accelerate.Matrix -import qualified Data.Array.Accelerate as A --- import qualified Data.Array.Accelerate.LLVM.Array.Data as LLVM -import qualified Data.Array.Accelerate.CUDA as CUDA -import qualified Data.Array.Accelerate.Interpreter as I -import SubHask.Internal.Prelude -import qualified Prelude as P - ---FIXME: Replace all intermediary lists with correct use of acclerate-io -mkAccVectorFromList :: A.Elt a => [a] -> ACCVector bknd (n::Nat) a -mkAccVectorFromList l = let - len = P.length l - in ACCVector (A.use (A.fromList (A.Z A.:.len) l)) - --- mkAccVector :: (A.Elt a, ValidSVector (n::Symbol) a) => SVector (n::Symbol) a -> ACCVector (bknd::Backend) (n::Symbol) a --- mkAccVector v @(SVector_Dynamic fp off n) = let --- arr = A.fromList (A.Z A.:. n) $ unsafeInlineIO $ go (n-1) [] --- go (-1) xs = return $ xs --- go i xs = withForeignPtr fp $ \p -> do --- x <- peekElemOff p (off+i) --- go (i-1) (x:xs) --- in ACCVector (A.use arr) - --- acc2SVector :: ValidACCVector (b::Backend) n a => ACCVector (b::Backend) n a -> SVector n a --- acc2SVector (ACCVector v) = unsafeToModule $ (runAccVector v) :: SVector n a - - -class ValidBackend (b::Backend) where - runAccVector :: (ValidACCVector (b::Backend) n a) => ACCVector (b::Backend) n a -> [a] - -- runAccMatrix :: (ValidACCMatrix (b::Backend) v r, A.IsScalar a, A.Elt a) => ACCMatrix (b::Backend) v n m a -> [a] - -instance ValidBackend 'Interpreter where - runAccVector (ACCVector a) = A.toList (I.run a) - -- runAccMatrix (ACCMatrix a) = A.toList (I.run a) - -instance ValidBackend 'CUDA where - runAccVector (ACCVector a) = A.toList (CUDA.run a) - -- runAccMatrix (ACCMatrix a) = A.toList (CUDA.run a) - --- instance ValidBackend LLVM where --- runAccVector (ACCVector a) = A.toList (LLVM.runArray a) --- runAccMatrix (ACCMatrix a) = A.toList (LLVM.runArray a) diff --git a/src/SubHask/Algebra/Accelerate/Vector.hs b/src/SubHask/Algebra/Accelerate/Vector.hs index 0531ff4..c782a1b 100644 --- a/src/SubHask/Algebra/Accelerate/Vector.hs +++ b/src/SubHask/Algebra/Accelerate/Vector.hs @@ -2,7 +2,8 @@ module SubHask.Algebra.Accelerate.Vector ( ValidACCVector , ACCVector (..) - + , ValidBackend(..) + , mkAccVectorFromList ) where @@ -20,7 +21,7 @@ import Foreign.Marshal.Utils import qualified Data.Array.Accelerate as A import SubHask.Algebra -import SubHask.Algebra.Accelerate.AccelerateBackend (Backend) +import SubHask.Algebra.Accelerate.AccelerateBackend (Backend(..)) import SubHask.Category import SubHask.Algebra.Vector (SVector, type (+>)) import SubHask.Compatibility.Base @@ -30,7 +31,45 @@ import SubHask.SubType import System.IO.Unsafe import Unsafe.Coerce +import qualified Data.Array.Accelerate.CUDA as CUDA +import qualified Data.Array.Accelerate.Interpreter as I +import SubHask.Internal.Prelude +import qualified Prelude as P + +--FIXME: Replace all intermediary lists with correct use of acclerate-io +mkAccVectorFromList :: A.Elt a => [a] -> ACCVector bknd (n::Nat) a +mkAccVectorFromList l = let + len = P.length l + in ACCVector (A.use (A.fromList (A.Z A.:.len) l)) + +-- mkAccVector :: (A.Elt a, ValidSVector (n::Symbol) a) => SVector (n::Symbol) a -> ACCVector (bknd::Backend) (n::Symbol) a +-- mkAccVector v @(SVector_Dynamic fp off n) = let +-- arr = A.fromList (A.Z A.:. n) $ unsafeInlineIO $ go (n-1) [] +-- go (-1) xs = return $ xs +-- go i xs = withForeignPtr fp $ \p -> do +-- x <- peekElemOff p (off+i) +-- go (i-1) (x:xs) +-- in ACCVector (A.use arr) + +-- acc2SVector :: ValidACCVector (b::Backend) n a => ACCVector (b::Backend) n a -> SVector n a +-- acc2SVector (ACCVector v) = unsafeToModule $ (runAccVector v) :: SVector n a + + +class ValidBackend (b::Backend) where + runAccVector :: (ValidACCVector (b::Backend) n a) => ACCVector (b::Backend) n a -> [a] + -- runAccMatrix :: (ValidACCMatrix (b::Backend) v r, A.IsScalar a, A.Elt a) => ACCMatrix (b::Backend) v n m a -> [a] + +instance ValidBackend 'Interpreter where + runAccVector (ACCVector a) = A.toList (I.run a) + -- runAccMatrix (ACCMatrix a) = A.toList (I.run a) + +instance ValidBackend 'CUDA where + runAccVector (ACCVector a) = A.toList (CUDA.run a) + -- runAccMatrix (ACCMatrix a) = A.toList (CUDA.run a) +-- instance ValidBackend LLVM where +-- runAccVector (ACCVector a) = A.toList (LLVM.runArray a) +-- runAccMatrix (ACCMatrix a) = A.toList (LLVM.runArray a) -------------------------------------------------------------------------------- @@ -40,8 +79,10 @@ import Unsafe.Coerce newtype ACCVector (bknd::Backend) (n::Nat) a = ACCVector (A.Acc (A.Array A.DIM1 a)) -type instance Scalar (ACCVector bknd n r) = A.Acc(A.Scalar r) -type instance Logic (ACCVector bknd n r) = A.Acc(A.Scalar r) +type instance Scalar (A.Acc(A.Scalar r)) = A.Acc(A.Scalar r) +type instance Scalar (ACCVector bknd n r) = Scalar (A.Acc(A.Scalar r)) +type instance Logic (A.Acc(A.Scalar r)) = A.Acc(A.Scalar Bool) +type instance Logic (ACCVector bknd n r) = Logic (A.Acc(A.Scalar r)) type ValidACCVector bknd n a = ( Prim a @@ -69,7 +110,7 @@ type ValidACCVector bknd n a = ( -- , Elem (A.Acc (A.Scalar a)) ~ A.Acc (A.Scalar a) -- , P.Fractional (A.Exp a) -- , P.Floating (A.Exp a) - , P.Floating (A.Acc (A.Scalar a)) + -- , P.Floating (A.Acc (A.Scalar a)) --, P.Floating (A.Acc (A.Array A.DIM0 a)) -- , Elem (Square (ACCVector bknd n a)) ~ ACCVector bknd n a -- , Index (Square (ACCVector bknd n a)) ~ A.Acc (A.Scalar Int) @@ -83,9 +124,9 @@ type ValidACCVector bknd n a = ( ) type instance Index (ACCVector bknd n r) = A.Acc(A.Scalar Int) -type instance Elem (ACCVector bknd n r) = A.Acc(A.Scalar r) +type instance Elem (ACCVector bknd n r) = Scalar (A.Acc(A.Scalar r)) -type instance Actor (ACCVector (bknd::Backend) n r) = A.Acc(A.Scalar r) +type instance Actor (ACCVector (bknd::Backend) n r) = Scalar (A.Acc(A.Scalar r)) instance (KnownNat n, Prim a) => IsMutable (ACCVector (bknd::Backend) (n::Nat) a) @@ -119,6 +160,10 @@ instance ( KnownNat n, FreeModule r, ValidACCVector bknd n r) => FreeModule (ACC {-# INLINE (.*.) #-} (.*.) (ACCVector a1) (ACCVector a2) = ACCVector( A.zipWith (P.*) a1 a2) +instance (KnownNat n, Vector r, P.Fractional (A.Exp r), ValidACCVector bknd n r) => Vector (ACCVector (bknd::Backend) (n::Nat) r) where + {-# INLINE (./) #-} ; (./) (ACCVector v) r = ACCVector $ A.map (P./ (A.the r)) v + {-# INLINE (./.) #-} ; (./.) (ACCVector a1) (ACCVector a2) = ACCVector $ (A.zipWith (P./) a1 a2) + instance ( KnownNat n, Module r, ValidACCVector bknd n r) => Module (ACCVector (bknd::Backend) (n::Nat) r) where {-# INLINE (.*) #-} (.*) (ACCVector v) r = ACCVector (A.map (P.* (A.the r)) v) @@ -160,9 +205,9 @@ instance -- in A.the (f ((A.unit i) :: Index (ACCVector b n r)) (x ! idx))) v -- in ACCVector mapd - type ValidElem (ACCVector b n r) e = (FiniteModule e, ValidACCVector b n e) + type ValidElem (ACCVector b n r) e = (ClassicalLogic e, ValidScalar e, FiniteModule e, ValidACCVector b n e) --- instance (A.Eq r, KnownNat n, Eq r, Monoid r, ValidACCVector b n r) => Eq (ACCVector b (n::Nat) r) where +instance (A.Eq r, KnownNat n, Eq r, Monoid r, ValidACCVector b n r) => Eq (ACCVector b (n::Nat) r) where -- {-# INLINE (==) #-} -- (ACCVector v2) == (ACCVector v1) = let -- l = A.zipWith (\x y -> x A.==* y) v1 v2 @@ -170,6 +215,7 @@ instance -- bl = A.all (A.&&* ele) l -- in bl + instance ( ValidACCVector b n r , A.Eq r @@ -177,6 +223,7 @@ instance , Ord r , Eq (ACCVector b n r) -- , VectorSpace r + , P.Floating (A.Acc (A.Scalar r)) , KnownNat n ) => Metric (ACCVector b (n::Nat) r) @@ -188,7 +235,7 @@ instance drt = A.sqrt (A.sum dsq) in drt -instance (KnownNat n, ValidACCVector b n r, ExpField r) => Normed (ACCVector b (n::Nat) r) where +instance (KnownNat n, P.Floating (A.Acc (A.Scalar r)), ValidACCVector b n r, ExpField r) => Normed (ACCVector b (n::Nat) r) where {-# INLINE size #-} size (ACCVector v1) = let sq = A.zipWith (P.*) v1 v1 @@ -204,6 +251,7 @@ instance , Real r , Eq (ACCVector b n r) , Ord r + , P.Floating (A.Acc (A.Scalar r)) , KnownNat n ) => Banach (ACCVector b (n::Nat) r) @@ -235,6 +283,7 @@ instance , Index (Square (ACCVector b n r)) ~ A.Acc (A.Scalar Int) , MatrixField r , KnownNat n + , P.Floating (A.Acc (A.Scalar r)) , P.Num r , Elem (Square (ACCVector b n r)) ~ ACCVector b n r ) => Hilbert (ACCVector b (n::Nat) r) @@ -244,8 +293,57 @@ instance singlton = A.fold (+) 0.0 (A.zipWith (*) v1 v2) --This float-valued accumulator forces a Field (A.Exp r) constraint above. Is there a way to formulate the constraints such that a more general zero-value could be used? in singlton + type Square (ACCVector b n r) = ACCVector b n r +> ACCVector b n r + +instance (Show r, ValidBackend b, ValidACCVector (b::Backend) n r, KnownNat n) => Show (ACCVector (b::Backend) n r) where + show v = show (runAccVector v) + type MatrixField r = ( Field r ) +-- +-- instance ValidACCVector (b::Backend) n a => Rg (a +> a) where +-- (*) = (>>>) + +-- instance ValidACCVector (b::Backend) n a => Rig (a +> a) +-- where +-- one = Id_ one + +-- instance ValidACCVector (b::Backend) n a => Ring (a +> a) +-- where +-- fromInteger i = Id_ $ fromInteger i + +-- instance ValidACCVector (b::Backend) n a=> Field (a +> a) +-- where +-- fromRational r = Id_ $ fromRational r +-- +-- reciprocal Zero = undefined +-- reciprocal (Id_ r ) = Id_ $ reciprocal r +-- reciprocal (Mat_ m) = Mat_ $ HM.inv m + +-- instance (ValidACCVector (b::Backend) n a, ValidACCVector (b::Backend) n a) => Module (a +> b) +-- where +-- Zero .* _ = Zero +-- (Id_ r1) .* r2 = Id_ $ r1*r2 +-- (Mat_ m) .* r2 = Mat_ $ HM.scale r2 m + +-- instance (ValidACCVector (b::Backend) n a, ValidACCVector (b::Backend) n a) => FreeModule (a +> b) +-- where +-- Zero .*. _ = Zero +-- _ .*. Zero = Zero +-- (Id_ r1) .*. (Id_ r2) = Id_ $ r1*r2 +-- (Id_ r ) .*. (Mat_ m ) = Mat_ $ HM.scale r (HM.ident (HM.rows m)) P.* m +-- (Mat_ m ) .*. (Id_ r ) = Mat_ $ m P.* HM.scale r (HM.ident (HM.rows m)) +-- (Mat_ m1) .*. (Mat_ m2) = Mat_ $ m1 P.* m2 + +-- instance (ValidACCVector (b::Backend) n a, ValidACCVector (b::Backend) n a) => Vector (a +> b) +-- where +-- Zero ./. _ = Zero +-- (Id_ _) ./. Zero = undefined +-- (Mat_ _) ./. Zero = undefined +-- (Id_ r1) ./. (Id_ r2) = Id_ $ r1/r2 +-- (Id_ r ) ./. (Mat_ m ) = Mat_ $ (HM.scale r (HM.ident (HM.rows m))) P./ m +-- (Mat_ m ) ./. (Id_ r ) = Mat_ $ m P./ HM.scale r (HM.ident (HM.rows m)) +-- (Mat_ m1) ./. (Mat_ m2) = Mat_ $ m1 P./ m2 diff --git a/subhask.cabal b/subhask.cabal index 51e2f06..70c0f5f 100644 --- a/subhask.cabal +++ b/subhask.cabal @@ -54,7 +54,6 @@ library SubHask.Algebra.Ring SubHask.Algebra.Vector SubHask.Algebra.Vector.FFI - SubHask.Algebra.Accelerate.Accelerate SubHask.Algebra.Accelerate.AccelerateBackend SubHask.Algebra.Accelerate.Vector @@ -255,4 +254,3 @@ benchmark bench if flag(llvmsupport) ghc-options: -fllvm - From f343f2491eb6b19c65135e01e481ee2743559209 Mon Sep 17 00:00:00 2001 From: tpierson Date: Thu, 13 Oct 2016 17:59:26 -0400 Subject: [PATCH 18/20] Hacked together a bunch of garbage Examples are calculating but the laws are failing, unsurprisingly. --- examples/example0005-accelerate_backend.lhs | 35 +- .../Algebra/Accelerate/AccelerateBackend.hs | 2 +- src/SubHask/Algebra/Accelerate/Vector.hs | 302 ++++++++++-------- src/SubHask/Algebra/Vector.hs | 1 - stack.yaml | 19 +- 5 files changed, 193 insertions(+), 166 deletions(-) diff --git a/examples/example0005-accelerate_backend.lhs b/examples/example0005-accelerate_backend.lhs index 58664ab..8280602 100644 --- a/examples/example0005-accelerate_backend.lhs +++ b/examples/example0005-accelerate_backend.lhs @@ -9,19 +9,20 @@ > import qualified Prelude as P > import SubHask > import SubHask.Algebra.Accelerate.Vector (ACCVector, ValidBackend(..), mkAccVectorFromList) -> import SubHask.Algebra.Vector (UVector) > --import SubHask.Algebra.Matrix (Matrix, unsafeToModuleM) -> --import SubHask.Algebra.Accelerate.Matrix (ACCMatrix, mmult) +> --import SubHask.Algebra.Accelerate.Matrix (ACCMatrix, mmult +> import SubHask.Algebra.Array +> import SubHask.Algebra.Vector +> import qualified Data.Array.Accelerate as A > import SubHask.Algebra.Accelerate.AccelerateBackend (Backend(..)) > import System.IO > -> v :: ACCVector Interpreter 6 Double -> v = mkAccVectorFromList [0.0, 1.0, 2.0, 3.0, 4.0, 5.0] -> -> v' :: ACCVector Interpreter 6 Double -> v' = mkAccVectorFromList [0..5] -> +> v :: ACCVector Interpreter 4 Float +> v = mkAccVectorFromList [0.0, 1.0, 2.0, 3.0] > +> v' :: ACCVector Interpreter 4 Float +> v' = mkAccVectorFromList [0..3] +> sngtln = (A.constant 2.0) > --mmat :: Matrix (UVector "v" Double) Double "a" "b" > --mmat = unsafeToModuleM 2 [0..5] > @@ -33,13 +34,17 @@ > > main :: IO () > main = do -> putStrLn $ "v = " ++ show (runAccVector v) -> putStrLn $ "v' = " ++ show (runAccVector v') -> putStrLn $ "v + v = " ++ show (runAccVector (v + v)) -> putStrLn $ "v + v - v = " ++ show (runAccVector (v + v - v')) -> putStrLn $ "v * v / v = " ++ show (runAccVector (v .*. v ./. v')) -> putStrLn $ "v' * 2 = " ++ show (runAccVector (v' .* 2)) -> putStrLn $ "v' * 2 = " ++ show (runAccVector (v' .* 2)) +> putStrLn $ "v = " + show v +> putStrLn $ "v' = " + show v' +> putStrLn $ "v + v = " + (show $ runAccVector (v + v)) +> putStrLn $ "v + v - v = " + (show $ runAccVector(v + v - v')) +> putStrLn $ "v * v = " + (show $ runAccVector (v .*. v )) +> putStrLn $ "v / v' = " + (show $ runAccVector (v ./. v')) +> putStrLn $ "v * v / v' = " + (show $ runAccVector (v .*. v ./. v')) +> putStrLn $ "v' .* 2 = " + (show $ runAccVector (v' .* sngtln)) +> putStrLn $ "v' ./ 2 = " + (show $ runAccVector (v' ./ sngtln)) +> putStrLn $ "v >< v' = " + (show $ runAccVector (v >< v')) +> putStrLn $ "v**2 = " + (show $ runAccVector (v**v')) > --putStrLn $ "m * 2 = " ++ show (runAccMatrix (m .* 2)) > --putStrLn $ "m + 2 = " ++ show (runAccMatrix ((m + 2) - 1 )) > --putStrLn $ "m / 2 = " ++ show (runAccMatrix (m / 2)) diff --git a/src/SubHask/Algebra/Accelerate/AccelerateBackend.hs b/src/SubHask/Algebra/Accelerate/AccelerateBackend.hs index a1b9c8a..076abe4 100644 --- a/src/SubHask/Algebra/Accelerate/AccelerateBackend.hs +++ b/src/SubHask/Algebra/Accelerate/AccelerateBackend.hs @@ -7,6 +7,6 @@ where data Backend = Interpreter - | CUDA + -- | CUDA -- | LLVM -- LLVM has an SoC project slated, so check back in 60 days for non-parial functionality diff --git a/src/SubHask/Algebra/Accelerate/Vector.hs b/src/SubHask/Algebra/Accelerate/Vector.hs index c782a1b..f7290ba 100644 --- a/src/SubHask/Algebra/Accelerate/Vector.hs +++ b/src/SubHask/Algebra/Accelerate/Vector.hs @@ -4,6 +4,7 @@ module SubHask.Algebra.Accelerate.Vector , ACCVector (..) , ValidBackend(..) , mkAccVectorFromList + ) where @@ -31,7 +32,7 @@ import SubHask.SubType import System.IO.Unsafe import Unsafe.Coerce -import qualified Data.Array.Accelerate.CUDA as CUDA +-- import qualified Data.Array.Accelerate.CUDA as CUDA import qualified Data.Array.Accelerate.Interpreter as I import SubHask.Internal.Prelude import qualified Prelude as P @@ -63,15 +64,57 @@ instance ValidBackend 'Interpreter where runAccVector (ACCVector a) = A.toList (I.run a) -- runAccMatrix (ACCMatrix a) = A.toList (I.run a) -instance ValidBackend 'CUDA where - runAccVector (ACCVector a) = A.toList (CUDA.run a) +-- instance ValidBackend 'CUDA where +-- runAccVector (ACCVector a) = A.toList (CUDA.run a) -- runAccMatrix (ACCMatrix a) = A.toList (CUDA.run a) -- instance ValidBackend LLVM where -- runAccVector (ACCVector a) = A.toList (LLVM.runArray a) -- runAccMatrix (ACCMatrix a) = A.toList (LLVM.runArray a) +-------------------------------------------------------------------------------- +--A.Exp Instances +instance (Prim r) => IsMutable (A.Exp r ) + +instance (Monoid r, Prim r ) => Semigroup (A.Exp r ) +instance (Prim r, FreeModule r) => Field (A.Exp r ) +instance (Prim r, Monoid r, Cancellative r) => Cancellative (A.Exp r ) +instance (Semigroup (Actor(A.Exp r)), Action r, Semigroup r, Prim r) => Action (A.Exp r ) +instance (Prim r, Monoid r) => Monoid (A.Exp r ) +instance (Monoid r, Abelian r, Prim r) => Abelian (A.Exp r ) +instance (Prim r, Cancellative r, Monoid r) => Group (A.Exp r ) +instance (P.Num (A.Exp r ), FreeModule r, Prim r, Abelian r , Group r, Ring (Scalar r), Scalar (Scalar r) ~ Scalar r ) => Module (A.Exp r) where + {-# INLINE (.*) #-} + (.*) = (A.*) +instance (Abelian r, Cancellative r, Monoid r, Prim r) => Ring(A.Exp r ) +instance (Abelian r, Prim r, Monoid r) => Rig(A.Exp r ) +instance (Prim r, Monoid r, Abelian r) => Rg(A.Exp r ) +instance (Prim r, P.Num (A.Exp r), P.Num r, FreeModule r) => FreeModule (A.Exp r ) +instance Module (A.Exp Int) where (.*) = (A.*) +instance (P.Num (A.Exp Integer), Prim Integer) => Module (A.Exp Integer) where (.*) = (A.*) +instance Module (A.Exp Float) where (.*) = (A.*) +instance Module (A.Exp Double) where (.*) = (A.*) +-- instance (Prim (GHC.Real.Ratio Integer), P.Num (A.Exp Rational), Prim Integer) => Module (A.Exp Rational) where (.*) = (A.*) +-------------------------------------------------------------------------------- +--A.Acc (A.Scalar r) Instances +-- newtype ACCScalar r = ACCScalar (A.Acc (A.Scalar r)) +instance (Prim r) => IsMutable (A.Acc (A.Scalar r)) +-- instance (Prim r) => Scalar(A.Acc (A.Scalar r)) +instance (Prim r, Monoid r) => Semigroup (A.Acc (A.Scalar r)) +instance (Prim r, Monoid r) => Monoid (A.Acc (A.Scalar r)) +-- +instance (Monoid r, Abelian r, Prim r) => Abelian (A.Acc (A.Scalar r)) +instance (Scalar (Scalar (A.Acc (A.Scalar r))) + ~ + Scalar (A.Acc (A.Scalar r)), Ring (Scalar (A.Acc (A.Scalar r))), Prim r, Abelian r, Group r, Ring (Scalar r), Scalar (Scalar r) ~ Scalar r) => Module (A.Acc (A.Scalar r)) where + +instance ( Prim r, Cancellative r, Monoid r) => Group (A.Acc (A.Scalar r)) +instance (Prim r, Monoid r, Cancellative r) => Cancellative (A.Acc (A.Scalar r)) +instance (Prim r, FreeModule r) => Ring(A.Acc (A.Scalar r)) +instance (Prim r, FreeModule r) => Rig(A.Acc (A.Scalar r)) +instance (Prim r, FreeModule r) => Rg(A.Acc (A.Scalar r)) +instance (Prim r, FreeModule r) => Field (A.Acc (A.Scalar r)) -------------------------------------------------------------------------------- -- | Accelerate based Vector @@ -79,108 +122,101 @@ instance ValidBackend 'CUDA where newtype ACCVector (bknd::Backend) (n::Nat) a = ACCVector (A.Acc (A.Array A.DIM1 a)) -type instance Scalar (A.Acc(A.Scalar r)) = A.Acc(A.Scalar r) -type instance Scalar (ACCVector bknd n r) = Scalar (A.Acc(A.Scalar r)) -type instance Logic (A.Acc(A.Scalar r)) = A.Acc(A.Scalar Bool) -type instance Logic (ACCVector bknd n r) = Logic (A.Acc(A.Scalar r)) +type instance Scalar (A.Acc(A.Scalar Int)) = A.Acc(A.Scalar Int) +type instance Scalar (A.Acc(A.Scalar Float)) = A.Acc(A.Scalar Float) +type instance Scalar (A.Acc(A.Scalar Double)) = A.Acc(A.Scalar Double) +type instance Scalar (A.Acc(A.Scalar Rational)) = A.Acc(A.Scalar Rational) +type instance Scalar (A.Exp r) = A.Exp r +type instance Actor (A.Exp r) = Scalar (A.Exp r) +type instance Logic (A.Exp r) = A.Exp Bool + +-- type instance Scalar (A.Acc(A.Scalar r)) = ACCExp r +type instance Scalar (ACCVector bknd n r) = Scalar (A.Exp r) + +-- type instance Logic (A.Acc(A.Scalar r)) = A.Acc(A.Scalar Bool) +type instance Logic (ACCVector bknd n r) = Logic (A.Exp r) type ValidACCVector bknd n a = ( Prim a , A.Elt a , P.Num (A.Exp a) - --, Scalar (A.Acc (A.Scalar a)) ~ A.Acc (A.Scalar a) - , Ring (A.Acc (A.Scalar a)) - --, Logic (Logic (A.Acc (A.Scalar Bool))) ~ Logic (A.Acc (A.Scalar Bool)) - , Container (A.Acc (A.Scalar Bool)) - , Boolean (A.Acc (A.Scalar Bool)) - , Ord (A.Acc (A.Scalar a)) - , Normed (A.Acc (A.Scalar a)) - , Vector (ACCVector bknd n a) - , Vector (Square (ACCVector bknd n a)) - - , Semigroup (A.Exp a) - , Field (A.Exp a) - , Rg (A.Exp a) - -- , Actor (A.Acc (A.Scalar a)) ~ A.Acc (A.Scalar a) - -- , Container (A.Acc (A.Scalar a)) - -- , Container (Logic (A.Acc (A.Scalar Bool))) - -- , Boolean (Logic (A.Acc (A.Scalar Bool))) - -- , Logic (Logic (A.Acc (A.Scalar Bool))) ~ Logic (A.Acc (A.Scalar Bool)) - -- , Logic (A.Acc (A.Scalar Bool)) ~ A.Acc (A.Scalar Bool) - -- , Elem (A.Acc (A.Scalar a)) ~ A.Acc (A.Scalar a) -- , P.Fractional (A.Exp a) -- , P.Floating (A.Exp a) - -- , P.Floating (A.Acc (A.Scalar a)) - --, P.Floating (A.Acc (A.Array A.DIM0 a)) - -- , Elem (Square (ACCVector bknd n a)) ~ ACCVector bknd n a - -- , Index (Square (ACCVector bknd n a)) ~ A.Acc (A.Scalar Int) - -- , Index (A.Acc (A.Scalar Int)) ~ A.Acc (A.Scalar Int) - -- , Vector (Square (ACCVector bknd n a)) - -- , Transposable (Square (ACCVector bknd n a)) - -- , IxContainer (Square (ACCVector bknd n a)) - -- , FreeModule a - -- , Vector (ACCVector bknd n a) - + -- , P.Num (A.Acc(A.Scalar a)) + -- , P.Fractional (A.Acc(A.Scalar a)) + -- , P.Floating (A.Acc(A.Scalar a)) ) -type instance Index (ACCVector bknd n r) = A.Acc(A.Scalar Int) -type instance Elem (ACCVector bknd n r) = Scalar (A.Acc(A.Scalar r)) +type instance Index (ACCVector bknd n r) = Scalar (A.Exp Int) +type instance Elem (ACCVector bknd n r) = Scalar (A.Exp r) + +type instance Actor (ACCVector (bknd::Backend) n r) = Scalar (A.Exp r) + + +instance (Arbitrary r, ValidACCVector b n r, FreeModule r, ValidScalar r) => Arbitrary (ACCVector (bknd::Backend) n r) +-- where +-- arbitrary = frequency +-- [ (1,return zero) +-- , (9,fmap unsafeToModule $ replicateM 27 arbitrary) +-- ] +-- instance NFData (ACCVector (bknd::Backend) n r) +-- where +-- rnf (SVector_Dynamic fp _ _) = seq fp () + + +-- instance (FromField r, ACCVector (bknd::Backend) n r, ValidScalar r, FreeModule r) => FromRecord (ACCVector (bknd::Backend) n r) +-- where +-- parseRecord r = do +-- rs :: [r] <- parseRecord r +-- return $ mkAccVectorFromList rs -type instance Actor (ACCVector (bknd::Backend) n r) = Scalar (A.Acc(A.Scalar r)) instance (KnownNat n, Prim a) => IsMutable (ACCVector (bknd::Backend) (n::Nat) a) instance (KnownNat n, Monoid r, ValidACCVector b n r) => Semigroup (ACCVector (b::Backend) (n::Nat) r) where {-# INLINE (+) #-} - (+) :: ACCVector bknd n r -> ACCVector bknd n r -> ACCVector bknd n r - (+) (ACCVector v1) (ACCVector v2)=ACCVector (A.zipWith (P.+) v1 v2) + (+) (ACCVector v1) (ACCVector v2)=ACCVector (A.zipWith (A.+) v1 v2) -instance (Semigroup (A.Acc (A.Scalar r)), KnownNat n, ValidACCVector bknd n r, Action r, Semigroup r, Prim r) => Action (ACCVector (bknd::Backend) (n::Nat) r) where +instance ( Semigroup (A.Exp r), Monoid r, KnownNat n, ValidACCVector bknd n r, Action r, Semigroup r, Prim r) => Action (ACCVector (bknd::Backend) (n::Nat) r) where {-# INLINE (.+) #-} - (.+) (ACCVector v) r = ACCVector (A.map (A.+ (A.the r)) v) + (.+) (ACCVector v) r = ACCVector (A.map ((A.+) r) v) instance (KnownNat n, Monoid r, Cancellative r, ValidACCVector bknd n r) => Cancellative (ACCVector (bknd::Backend) (n::Nat) r) where {-# INLINE (-) #-} - (-) (ACCVector a1) (ACCVector a2) = ACCVector (A.zipWith (P.-) a1 a2) + (-) (ACCVector a1) (ACCVector a2) = ACCVector (A.zipWith (A.-) a1 a2) --The zero method wants a Ring r in the case where zero is the integer "0" --or Field r in the case of "0.0" --In either case, the Group instance wants the same constraint. Not exactly sure how to handle this. -instance (KnownNat n, Monoid r, ValidACCVector bknd n r) => Monoid (ACCVector (bknd::Backend) (n::Nat) r) where +instance (KnownNat n, Monoid r, ValidACCVector bknd n r) => Monoid (ACCVector (bknd::Backend) (n::Nat) r) + -- where -- {-# INLINE zero #-} -- zero = ACCVector(A.use (A.fromList (A.Z A.:.1) [(0::r)])) -instance (KnownNat n, Group r, ValidACCVector bknd n r) => Group (ACCVector (bknd::Backend) (n::Nat) r) where +instance (KnownNat n, Group r, ValidACCVector bknd n r) => Group (ACCVector (bknd::Backend) (n::Nat) r) + where {-# INLINE negate #-} negate = negate instance (KnownNat n, Monoid r, Abelian r, ValidACCVector bknd n r) => Abelian (ACCVector (bknd::Backend) (n::Nat) r) -instance ( KnownNat n, FreeModule r, ValidACCVector bknd n r) => FreeModule (ACCVector (bknd::Backend) (n::Nat) r) where +instance (Rg (A.Exp r), Ring (A.Exp r), KnownNat n, FreeModule r, ValidACCVector bknd n r) => FreeModule (ACCVector (bknd::Backend) (n::Nat) r) where {-# INLINE (.*.) #-} - (.*.) (ACCVector a1) (ACCVector a2) = ACCVector( A.zipWith (P.*) a1 a2) + (.*.) (ACCVector a1) (ACCVector a2) = ACCVector( A.zipWith (A.*) a1 a2) -instance (KnownNat n, Vector r, P.Fractional (A.Exp r), ValidACCVector bknd n r) => Vector (ACCVector (bknd::Backend) (n::Nat) r) where - {-# INLINE (./) #-} ; (./) (ACCVector v) r = ACCVector $ A.map (P./ (A.the r)) v - {-# INLINE (./.) #-} ; (./.) (ACCVector a1) (ACCVector a2) = ACCVector $ (A.zipWith (P./) a1 a2) +instance (Ring (A.Acc (A.Scalar r)), P.Fractional (A.Exp r), Ring (A.Exp r),Field (A.Exp r), KnownNat n, Vector r, ValidACCVector bknd n r) => Vector (ACCVector (bknd::Backend) (n::Nat) r) where + {-# INLINE (./) #-} ; (./) (ACCVector v) r = ACCVector $ A.map ((A./) r) v + {-# INLINE (./.) #-} ; (./.) (ACCVector a1) (ACCVector a2) = ACCVector $ (A.zipWith (A./) a1 a2) -instance ( KnownNat n, Module r, ValidACCVector bknd n r) => Module (ACCVector (bknd::Backend) (n::Nat) r) where +instance (Rg (A.Exp r), Ring(A.Exp r), KnownNat n, Module r, ValidACCVector bknd n r) => Module (ACCVector (bknd::Backend) (n::Nat) r) where {-# INLINE (.*) #-} - (.*) (ACCVector v) r = ACCVector (A.map (P.* (A.the r)) v) + (.*) (ACCVector v) r = ACCVector (A.map ((A.*) r) v) --- instance (Field (A.Acc (A.Scalar r)), KnownNat n, VectorSpace r, ValidACCVector bknd n r) => VectorSpace (ACCVector (bknd::Backend) (n::Nat) r) where --- {-# INLINE (./) #-} --- (./) (ACCVector v) r = ACCVector (A.map (P./ (A.the r)) v) --- --- {-# INLINE (./.) #-} --- (./.) (ACCVector a1) (ACCVector a2) = ACCVector (A.zipWith (P./) a1 a2) - -instance (KnownNat n, FreeModule r, ValidACCVector b n r) => FiniteModule (ACCVector b (n::Nat) r) +instance (Ring (A.Exp r), Rg (A.Exp r), Ring (A.Acc (A.Scalar r)), KnownNat n, FreeModule r, ValidACCVector b n r) => FiniteModule (ACCVector b (n::Nat) r) --dim wants an Int but here gets an A.Exp Int. I tried changing the signiture to a generic type in Alegbra.hs but that produced numerous errors. - where - -- dim :: ACCVector b (n::Nat) r -> A.Exp Int - -- {-# INLINE dim #-} - -- dim (ACCVector v) = A.size v + -- where + -- {-# INLINE dim #-} + -- dim (ACCVector v) = A.size v instance @@ -192,63 +228,82 @@ instance , KnownNat n , Eq (ACCVector b n r) , FreeModule r + ) => IxContainer (ACCVector b (n::Nat) r) where {-# INLINE (!) #-} - (!) (ACCVector v) i = A.unit (v A.! A.index1 (A.the (i))) + (!) (ACCVector v) i = (v A.! A.index1 i) + + {-# INLINABLE imap #-} + -- imap f (ACCVector v) = A.zipWith (\i x -> f ((A.unit i)::A.Acc (A.Scalar Int)) ((A.unit x)::A.Acc (A.Scalar r))) ((A.generate (A.shape v) P.id):: A.Array A.DIM1 Int) v + imap f (ACCVector v) = ACCVector $ A.imap (\i x ->let + A.Z A.:. idx = A.unlift i + in f idx x + + ) v - -- {-# INLINABLE imap #-} - -- -- imap f (ACCVector v) = A.zipWith (\i x -> f ((A.unit i)::A.Acc (A.Scalar Int)) ((A.unit x)::A.Acc (A.Scalar r))) ((A.generate (A.shape v) P.id):: A.Array A.DIM1 Int) v - -- imap f (ACCVector v) = let - -- mapd = A.imap (\x (i::A.Exp r) -> let A.Z A.:. idx = A.unlift x -- This dance is probably not optimal but f expects A.Scalars so we have to build them - -- in A.the (f ((A.unit i) :: Index (ACCVector b n r)) (x ! idx))) v - -- in ACCVector mapd type ValidElem (ACCVector b n r) e = (ClassicalLogic e, ValidScalar e, FiniteModule e, ValidACCVector b n e) -instance (A.Eq r, KnownNat n, Eq r, Monoid r, ValidACCVector b n r) => Eq (ACCVector b (n::Nat) r) where --- {-# INLINE (==) #-} --- (ACCVector v2) == (ACCVector v1) = let --- l = A.zipWith (\x y -> x A.==* y) v1 v2 --- ele = l A.! A.index1 (A.constant 0) --- bl = A.all (A.&&* ele) l --- in bl +instance (Ord (A.Exp r), A.Eq r, Boolean (A.Exp Bool), Container (A.Exp Bool), KnownNat n, Eq r, Monoid r, ValidACCVector b n r) => Eq (ACCVector b (n::Nat) r) where + {-# INLINE (==) #-} + (ACCVector v2) == (ACCVector v1) = let + l = A.zipWith (\x y -> x A.==* y) v1 v2 + ele = l A.! A.index1 (A.constant 0) + bl = A.all (A.&&* ele) l + in A.the bl instance ( ValidACCVector b n r , A.Eq r + , Ord (A.Exp r) + , Normed (A.Acc (A.Scalar r)) , ExpField r , Ord r , Eq (ACCVector b n r) - -- , VectorSpace r - , P.Floating (A.Acc (A.Scalar r)) , KnownNat n + , Ring (A.Exp r) + , P.Num r + , Normed (A.Exp r) + , ExpField (A.Acc (A.Scalar r)) ) => Metric (ACCVector b (n::Nat) r) where {-# INLINE[2] distance #-} distance (ACCVector v1) (ACCVector v2) = {-# SCC distance_ACCVector #-}let - dmag = A.zipWith (P.-) v1 v2 - dsq = A.zipWith (P.*) dmag dmag - drt = A.sqrt (A.sum dsq) - in drt + dmag = A.zipWith (A.-) v1 v2 + dsq = A.zipWith (A.*) dmag dmag + drt = sqrt (A.sum dsq) + in A.the drt -instance (KnownNat n, P.Floating (A.Acc (A.Scalar r)), ValidACCVector b n r, ExpField r) => Normed (ACCVector b (n::Nat) r) where +instance (Ord (A.Exp r), Ring (A.Exp r), ExpField (A.Acc (A.Scalar r)), Rg (A.Exp r), Ord (A.Acc (A.Scalar r)), Ring (A.Acc (A.Scalar r)), KnownNat n, ValidACCVector b n r, ExpField r) => Normed (ACCVector b (n::Nat) r) where {-# INLINE size #-} size (ACCVector v1) = let - sq = A.zipWith (P.*) v1 v1 - s = A.fold (P.+) (A.constant 0.0) sq - srt = A.sqrt s - in srt + sq = A.zipWith (A.*) v1 v1 + s = A.fold (A.+) (A.constant 0.0) sq + srt = sqrt s + in A.the srt instance ( A.Eq r , Normed r + , Normed (A.Exp r) + , Ord (A.Exp r) + , Ring (A.Exp r) + , Field (A.Exp r) , ValidACCVector b n r , ExpField r + , Vector r + , Ord (A.Acc (A.Scalar r)) , Real r + , P.Num r + , ExpField (A.Acc (A.Scalar r)) + , Rg (A.Exp r) + , Normed (A.Acc (A.Scalar r)) + , P.Fractional (A.Exp r) + , Field (A.Acc (A.Scalar r)) , Eq (ACCVector b n r) , Ord r , P.Floating (A.Acc (A.Scalar r)) @@ -272,26 +327,33 @@ instance instance ( ValidACCVector b n r - , Transposable (Square (ACCVector b n r)) - , IxContainer (Square (ACCVector b n r)) + , Normed (A.Acc (A.Scalar r)) + , Ord (A.Exp r) + , Ord (A.Acc (A.Scalar r)) , FreeModule r + , ExpField (A.Acc (A.Scalar r)) + , Ring (A.Acc (A.Scalar r)) + , P.Floating (A.Acc (A.Scalar r)) , ExpField r + , P.Fractional (A.Exp r) + , Normed (A.Exp r) , Eq (ACCVector b n r) , Real r , A.Eq r + , Vector r , OrdField r - , Index (Square (ACCVector b n r)) ~ A.Acc (A.Scalar Int) , MatrixField r + -- , Field (A.Acc (A.Scalar r)) , KnownNat n - , P.Floating (A.Acc (A.Scalar r)) + , Field (A.Exp r) , P.Num r , Elem (Square (ACCVector b n r)) ~ ACCVector b n r ) => Hilbert (ACCVector b (n::Nat) r) where {-# INLINE (<>) #-} (<>) (ACCVector v1) (ACCVector v2) = let - singlton = A.fold (+) 0.0 (A.zipWith (*) v1 v2) --This float-valued accumulator forces a Field (A.Exp r) constraint above. Is there a way to formulate the constraints such that a more general zero-value could be used? - in singlton + s = A.sum (A.zipWith (A.*) v1 v2) + in A.the s type Square (ACCVector b n r) = ACCVector b n r +> ACCVector b n r @@ -303,47 +365,3 @@ type MatrixField r = ( Field r ) --- --- instance ValidACCVector (b::Backend) n a => Rg (a +> a) where --- (*) = (>>>) - --- instance ValidACCVector (b::Backend) n a => Rig (a +> a) --- where --- one = Id_ one - --- instance ValidACCVector (b::Backend) n a => Ring (a +> a) --- where --- fromInteger i = Id_ $ fromInteger i - --- instance ValidACCVector (b::Backend) n a=> Field (a +> a) --- where --- fromRational r = Id_ $ fromRational r --- --- reciprocal Zero = undefined --- reciprocal (Id_ r ) = Id_ $ reciprocal r --- reciprocal (Mat_ m) = Mat_ $ HM.inv m - --- instance (ValidACCVector (b::Backend) n a, ValidACCVector (b::Backend) n a) => Module (a +> b) --- where --- Zero .* _ = Zero --- (Id_ r1) .* r2 = Id_ $ r1*r2 --- (Mat_ m) .* r2 = Mat_ $ HM.scale r2 m - --- instance (ValidACCVector (b::Backend) n a, ValidACCVector (b::Backend) n a) => FreeModule (a +> b) --- where --- Zero .*. _ = Zero --- _ .*. Zero = Zero --- (Id_ r1) .*. (Id_ r2) = Id_ $ r1*r2 --- (Id_ r ) .*. (Mat_ m ) = Mat_ $ HM.scale r (HM.ident (HM.rows m)) P.* m --- (Mat_ m ) .*. (Id_ r ) = Mat_ $ m P.* HM.scale r (HM.ident (HM.rows m)) --- (Mat_ m1) .*. (Mat_ m2) = Mat_ $ m1 P.* m2 - --- instance (ValidACCVector (b::Backend) n a, ValidACCVector (b::Backend) n a) => Vector (a +> b) --- where --- Zero ./. _ = Zero --- (Id_ _) ./. Zero = undefined --- (Mat_ _) ./. Zero = undefined --- (Id_ r1) ./. (Id_ r2) = Id_ $ r1/r2 --- (Id_ r ) ./. (Mat_ m ) = Mat_ $ (HM.scale r (HM.ident (HM.rows m))) P./ m --- (Mat_ m ) ./. (Id_ r ) = Mat_ $ m P./ HM.scale r (HM.ident (HM.rows m)) --- (Mat_ m1) ./. (Mat_ m2) = Mat_ $ m1 P./ m2 diff --git a/src/SubHask/Algebra/Vector.hs b/src/SubHask/Algebra/Vector.hs index 13c61b6..46b2080 100644 --- a/src/SubHask/Algebra/Vector.hs +++ b/src/SubHask/Algebra/Vector.hs @@ -1554,4 +1554,3 @@ instance Vector a => Field (a +> a) where reciprocal Zero = undefined reciprocal (Id_ r ) = Id_ $ reciprocal r reciprocal (Mat_ m) = Mat_ $ HM.inv m - diff --git a/stack.yaml b/stack.yaml index fbdb045..59ffd70 100644 --- a/stack.yaml +++ b/stack.yaml @@ -11,14 +11,19 @@ extra-lib-dirs: - /usr/local/lib packages: - '.' -- location: - git: https://github.com/AccelerateHS/accelerate.git - commit: aed12138a9788ff5d6289d214c84ff6108dc04bd +- location: ../accelerate extra-dep: true -- location: - git: https://github.com/AccelerateHS/accelerate-cuda - commit: 05acd3adca9fd89a8ac19184afbed47d1b7d1505 +# - location: +# git: https://github.com/AccelerateHS/accelerate.git +# commit: aed12138a9788ff5d6289d214c84ff6108dc04bd +# extra-dep: true +- location: ../accelerate-cuda extra-dep: true + +# - location: +# git: https://github.com/AccelerateHS/accelerate-cuda +# commit: 05acd3adca9fd89a8ac19184afbed47d1b7d1505 +# extra-dep: true # - location: # git: https://github.com/AccelerateHS/accelerate-llvm/ # commit: 2c26ca7755a3f5acc3a56dd0f4a23565ba620501 @@ -30,4 +35,4 @@ extra-deps: - homoiconic-0.1.2.0 - unique-0 compiler: ghc-8.0.1 -resolver: nightly-2016-06-15 +resolver: lts-7.2 From 598f73770340f8c539c26d030e51b8b1aaaf427b Mon Sep 17 00:00:00 2001 From: tpierson Date: Thu, 20 Oct 2016 18:44:45 +0200 Subject: [PATCH 19/20] Initial rewrite of Vector.hs complete --- examples/example0005-accelerate_backend.lhs | 2 +- src/SubHask/Algebra/Accelerate/Vector.hs | 301 +++++++++++++++++--- 2 files changed, 256 insertions(+), 47 deletions(-) diff --git a/examples/example0005-accelerate_backend.lhs b/examples/example0005-accelerate_backend.lhs index 8280602..19a7019 100644 --- a/examples/example0005-accelerate_backend.lhs +++ b/examples/example0005-accelerate_backend.lhs @@ -43,7 +43,7 @@ > putStrLn $ "v * v / v' = " + (show $ runAccVector (v .*. v ./. v')) > putStrLn $ "v' .* 2 = " + (show $ runAccVector (v' .* sngtln)) > putStrLn $ "v' ./ 2 = " + (show $ runAccVector (v' ./ sngtln)) -> putStrLn $ "v >< v' = " + (show $ runAccVector (v >< v')) +> putStrLn $ "v >< v' = " + (show $ runAccVector (v >< v)) > putStrLn $ "v**2 = " + (show $ runAccVector (v**v')) > --putStrLn $ "m * 2 = " ++ show (runAccMatrix (m .* 2)) > --putStrLn $ "m + 2 = " ++ show (runAccMatrix ((m + 2) - 1 )) diff --git a/src/SubHask/Algebra/Accelerate/Vector.hs b/src/SubHask/Algebra/Accelerate/Vector.hs index 90cec5d..e19faff 100644 --- a/src/SubHask/Algebra/Accelerate/Vector.hs +++ b/src/SubHask/Algebra/Accelerate/Vector.hs @@ -24,7 +24,7 @@ import qualified Data.Array.Accelerate as A import SubHask.Algebra import SubHask.Algebra.Accelerate.AccelerateBackend (Backend(..)) import SubHask.Category -import SubHask.Algebra.Vector (SVector, type (+>)) +import SubHask.Algebra.Vector (SVector) import SubHask.Compatibility.Base import SubHask.Internal.Prelude import SubHask.SubType @@ -43,26 +43,14 @@ mkAccVectorFromList l = let len = P.length l in ACCVector (A.use (A.fromList (A.Z A.:.len) l)) --- mkAccVector :: (A.Elt a, ValidSVector (n::Symbol) a) => SVector (n::Symbol) a -> ACCVector (bknd::Backend) (n::Symbol) a --- mkAccVector v @(SVector_Dynamic fp off n) = let --- arr = A.fromList (A.Z A.:. n) $ unsafeInlineIO $ go (n-1) [] --- go (-1) xs = return $ xs --- go i xs = withForeignPtr fp $ \p -> do --- x <- peekElemOff p (off+i) --- go (i-1) (x:xs) --- in ACCVector (A.use arr) - --- acc2SVector :: ValidACCVector (b::Backend) n a => ACCVector (b::Backend) n a -> SVector n a --- acc2SVector (ACCVector v) = unsafeToModule $ (runAccVector v) :: SVector n a - - class ValidBackend (b::Backend) where runAccVector :: (ValidACCVector (b::Backend) n a) => ACCVector (b::Backend) n a -> [a] - -- runAccMatrix :: (ValidACCMatrix (b::Backend) v r, A.IsScalar a, A.Elt a) => ACCMatrix (b::Backend) v n m a -> [a] + runAccMatrix :: (A.IsScalar a, A.Elt a) => ACCMatrix (b::Backend) n m a -> [a] instance ValidBackend 'Interpreter where runAccVector (ACCVector a) = A.toList (I.run a) - -- runAccMatrix (ACCMatrix a) = A.toList (I.run a) + --how to preserve the >< = a+>a interface since I.run wants a plain A.Acc? + --runAccMatrix (ACCMatrix m) = A.toList (I.run m) -- instance ValidBackend 'CUDA where -- runAccVector (ACCVector a) = A.toList (CUDA.run a) @@ -73,7 +61,7 @@ instance ValidBackend 'Interpreter where -- runAccMatrix (ACCMatrix a) = A.toList (LLVM.runArray a) -------------------------------------------------------------------------------- ---A.Exp Instances +--A.Exp Orphaned Instances; I'm sure there's a way to clean these up . . . instance (Prim r) => IsMutable (A.Exp r ) instance (Monoid r, Prim r ) => Semigroup (A.Exp r ) @@ -94,12 +82,10 @@ instance Module (A.Exp Int) where (.*) = (A.*) instance (P.Num (A.Exp Integer), Prim Integer) => Module (A.Exp Integer) where (.*) = (A.*) instance Module (A.Exp Float) where (.*) = (A.*) instance Module (A.Exp Double) where (.*) = (A.*) --- instance (Prim (GHC.Real.Ratio Integer), P.Num (A.Exp Rational), Prim Integer) => Module (A.Exp Rational) where (.*) = (A.*) + -------------------------------------------------------------------------------- --A.Acc (A.Scalar r) Instances --- newtype ACCScalar r = ACCScalar (A.Acc (A.Scalar r)) instance (Prim r) => IsMutable (A.Acc (A.Scalar r)) --- instance (Prim r) => Scalar(A.Acc (A.Scalar r)) instance (Prim r, Monoid r) => Semigroup (A.Acc (A.Scalar r)) instance (Prim r, Monoid r) => Monoid (A.Acc (A.Scalar r)) @@ -185,9 +171,7 @@ instance (KnownNat n, Monoid r, Cancellative r, ValidACCVector bknd n r) => Canc {-# INLINE (-) #-} (-) (ACCVector a1) (ACCVector a2) = ACCVector (A.zipWith (A.-) a1 a2) ---The zero method wants a Ring r in the case where zero is the integer "0" ---or Field r in the case of "0.0" ---In either case, the Group instance wants the same constraint. Not exactly sure how to handle this. + instance (KnownNat n, Monoid r, ValidACCVector bknd n r) => Monoid (ACCVector (bknd::Backend) (n::Nat) r) -- where -- {-# INLINE zero #-} @@ -231,15 +215,11 @@ instance ) => IxContainer (ACCVector b (n::Nat) r) where - -- - -- {-# INLINE (!) #-} - -- (!) (ACCVector v) i = A.unit (v A.! A.index1 i) {-# INLINE (!) #-} (!) (ACCVector v) i = (v A.! A.index1 i) {-# INLINABLE imap #-} - -- imap f (ACCVector v) = A.zipWith (\i x -> f ((A.unit i)::A.Acc (A.Scalar Int)) ((A.unit x)::A.Acc (A.Scalar r))) ((A.generate (A.shape v) P.id):: A.Array A.DIM1 Int) v imap f (ACCVector v) = ACCVector $ A.imap (\i x ->let A.Z A.:. idx = A.unlift i in f idx x @@ -303,7 +283,7 @@ instance , Vector r , Ord (A.Acc (A.Scalar r)) , Real r - , P.Num r + , P.Num r , ExpField (A.Acc (A.Scalar r)) , Rg (A.Exp r) , Normed (A.Acc (A.Scalar r)) @@ -315,20 +295,12 @@ instance , KnownNat n ) => Banach (ACCVector b (n::Nat) r) --- instance --- ( FiniteModule (ACCVector b (n::Nat) r) --- , VectorSpace (ACCVector b (n::Nat) r) --- , Normed (ACCVector b n r +> ACCVector b n r) --- , KnownNat n --- , MatrixField r --- ) => TensorAlgebra (ACCVector b (n::Nat) r) --- where --- (ACCVector v1)><(ACCVector v2) = let --- r = A.size v1 --- c = A.size v2 --- arr = A.map (\i -> A.lift (A.map (\j -> i * j ) v1)) v2 --- m = A.reshape (A.index2 r c) arr :: ACCVector bknd n r +> ACCVector bknd m r --- in m + +-- So far unable to get the dagger interface to square with the fact that any operation returns inside the A.Acc monad. +--newtype ACCMatrix b m n a = ACCMatrix( A.Acc (A.Array A.DIM2 a))--ACCVector b m a +> ACCVector b n a +newtype ACCMatrix b m n a = ACCMatrix (ACCVector b m a +> ACCVector b n a) + +mkACCMatrix r c l = Mat_ $ A.use $ A.fromList (A.Z A.:. r A.:. c) l instance ( ValidACCVector b n r @@ -348,9 +320,9 @@ instance , Vector r , OrdField r , MatrixField r - -- , Field (A.Acc (A.Scalar r)) , KnownNat n , Field (A.Exp r) + , IsMutable (ACCVector b n r +> ACCVector b n r) , P.Num r , Elem (Square (ACCVector b n r)) ~ ACCVector b n r ) => Hilbert (ACCVector b (n::Nat) r) @@ -361,12 +333,249 @@ instance in A.the s type Square (ACCVector b n r) = ACCVector b n r +> ACCVector b n r + --Does this need an unsafeCoerce to get GHC to accept that the result is ACCVector b n r + > ACCVector b n r and not the acclerate types? + -- (ACCVector v1)><(ACCVector v2) = let + -- r = A.size v1 + -- c = A.size v2 + -- m = A.zipWith (A.*) (A.replicate (A.lift $ A.Any A.:. r A.:. A.All) v1 ) (A.replicate (A.lift $ A.Any A.:. A.All A.:. c) v2) + -- in m + + mXv m v= m $ v + vXm v m = trans m $ v instance (Show r, ValidBackend b, ValidACCVector (b::Backend) n r, KnownNat n) => Show (ACCVector (b::Backend) n r) where show v = show (runAccVector v) type MatrixField r = - ( - Field r - ) + (ValidScalar r + , Vector r + , Field r + ) + +class ToFromVector a where + toVector :: a -> ACCVector b n a + fromVector :: ACCVector b n a -> a + +instance ToFromVector Double where + toVector x = mkAccVectorFromList [x] + --fromVector v = A.toList v + +-- These are building what from what, exactly? +-- instance MatrixField r => ToFromVector (ACCVector b (n::Symbol) r) where +-- toVector (SVector_Dynamic fp off n) = VS.unsafeFromForeignPtr fp off n +-- fromVector v = SVector_Dynamic fp off n +-- where +-- (fp,off,n) = VS.unsafeToForeignPtr v + +-- instance (KnownNat n, MatrixField r) => ToFromVector (SVector (n::Nat) r) where + -- toVector (SVector_Nat fp) = VS.unsafeFromForeignPtr fp 0 n +-- where +-- n = nat2int (Proxy::Proxy n) +-- fromVector v = SVector_Nat fp +-- where +-- (fp,_,_) = VS.unsafeToForeignPtr v + +-- what is this? +-- apMat_ :: +-- ( Scalar a~Scalar b +-- , Scalar b ~ Scalar (Scalar b) +-- , MatrixField (Scalar a) +-- , ToFromVector a +-- , ToFromVector b +-- ) => HM.Matrix (Scalar a) -> a -> b +-- apMat_ m a = fromVector $ A.flatten $ m HM.<> HM.asColumn (toVector a) + + +data (+>) a b where + Zero :: (Module a, Module b) => a +> b + Id_ :: (Vector b) => !(Scalar b) -> b +> b + Mat_ :: + (MatrixField (Scalar b), Scalar a ~ Scalar b, + Scalar b ~ Scalar (Scalar b), Scalar a ~ A.Exp a, + Scalar b ~ A.Exp b, P.Fractional (A.Exp a), P.Fractional (A.Exp b), + P.Num (A.Exp b), P.Num (A.Exp a), Prim a, Prim b, A.Elt b, A.Elt a, + Vector a, Vector b, ToFromVector a, ToFromVector b) => + A.Acc (A.Array A.DIM2 b) -> a +> b + +type instance Scalar (a +> b) = Scalar b +type instance Logic (a +> b) = A.Exp Bool + +-- type instance (a +> b) >< c = Tensor_Linear (a +> b) c +-- type family Tensor_Linear a b where +-- Tensor_Linear (a +> b) c = a +> b + +-------------------------------------------------------------------------------- +-- instances + +deriving instance (A.Elt b, A.Elt a, MatrixField (Scalar b), Show (Scalar b) ) => Show (a +> b) + + + + + + +--------------------------------------------------------------------------------- +-- accelerate linear algebra helpers +-- omitted some signitures because I couldn't deduce what ghc wanted and it's likely to need refactoring anyway + +--fillsqu_:: (A.Elt a, A.Num a) => (A.Exp((A.Z A.:. Int ) A.:. Int) -> A.Exp a) -> A.Exp Int -> ACCMatrix b m m a +fillsqu_ f d = A.generate (A.index2 d d) f + +--ident_:: A.Exp((A.Z A.:. Int ) A.:. Int) -> A.Exp Int +ident_ d = let + A.Z A.:. rows A.:. cols = A.unlift d + in A.cond (rows A.==* cols ) (A.constant one) (A.constant zero) + +identFrm_ :: (A.IsNum a , A.Elt a ) => A.Acc (A.Array A.DIM2 a) -> A.Acc (A.Array A.DIM2 Int) +identFrm_ m = fillsqu_ ident_ (fst $ matrixShape_ m) + +matrixShape_ :: (A.IsNum a , A.Elt a ) => A.Acc (A.Array A.DIM2 a) -> (A.Exp Int, A.Exp Int) +matrixShape_ arr = let + A.Z A.:. rows A.:. cols = A.unlift (A.shape arr) + in (rows, cols) + +--multiplyMatrixMatrix_ :: (A.IsNum b , A.Elt b ) => (A.Acc (A.Array A.DIM2 b)) -> (A.Acc (A.Array A.DIM2 b)) -> (A.Acc (A.Array A.DIM2 b)) -> (A.Acc (A.Array A.DIM2 b)) +multiplyMatrixMatrix_ arr brr = A.fold1 (+) (A.zipWith (*) arrRepl brrRepl) + where + A.Z A.:. rowsA A.:. _ = A.unlift (A.shape arr) :: A.Z A.:. A.Exp Int A.:. A.Exp Int + A.Z A.:. _ A.:. colsB = A.unlift (A.shape brr) :: A.Z A.:. A.Exp Int A.:. A.Exp Int + + arrRepl = A.replicate (A.lift $ A.Z A.:. A.All A.:. colsB A.:. A.All) arr + brrRepl = A.replicate (A.lift $ A.Z A.:. rowsA A.:. A.All A.:. A.All) (A.transpose brr) + + +---------------------------------------- +-- category + +instance Category (+>) where + type ValidCategory (+>) a = MatrixField a + -- This needs to be an A.Exp a in order for the below binary operations to typecheck. + -- However, I haven't been able to successfully make id an "A.Exp 1" . . . + id = Id_ 1 + + Zero . Zero = Zero + Zero . (Id_ _ ) = Zero + Zero . (Mat_ _ ) = Zero + + (Id_ _ ) . Zero = Zero + (Id_ r1) . (Id_ r2) = Id_ (r1*r2) + (Id_ r ) . (Mat_ m ) = Mat_ $ A.map (A.* r) m + + (Mat_ _) . Zero = Zero + (Mat_ m ) . (Id_ r ) = Mat_ $ A.map (A.* r) m + (Mat_ m1) . (Mat_ m2) = Mat_ $ multiplyMatrixMatrix_ m1 m2 + +instance Sup (+>) (->) (->) +instance Sup (->) (+>) (->) + +instance (+>) <: (->) where + embedType_ = Embed2 (embedType2 go) + where + go :: a +> b -> a -> b + go Zero = zero + go (Id_ r) = (r*.) + -- go (Mat_ m) = apMat_ m + +instance Dagger (+>) where + dagger Zero = Zero + dagger (Id_ r) = Id_ r + dagger (Mat_ m) = Mat_ $ A.transpose m + +instance Groupoid (+>) where + inverse Zero = undefined + inverse (Id_ r) = Id_ $ reciprocal r + -- inverse (Mat_ m) = Mat_ $ HM.inv m + +-- FIXME +type instance Elem (a +> b) = b +type instance Index (a +> b) = Index a + +instance (Container (A.Exp Bool)) => Eq (a +> b) +instance (Container (A.Exp Bool)) => IxContainer (a +> b) +instance Transposable (a +> a) where + trans = dagger + +---------------------------------------- +-- size + +-- FIXME: what's the norm of a tensor? +instance (Ord (A.Exp r), Prim r, MatrixField r) => Normed (ACCVector b m r +> ACCVector b m r) where + size Zero = zero + size (Id_ r) = r + -- size (Mat_ m) = HM.det m + +---------------------------------------- +-- algebra + +instance (IsMutable(a +> b)) => Semigroup (a +> b) where + Zero + a = a + a + Zero = a + (Id_ r1) + (Id_ r2) = Id_ (r1+r2) + -- (Id_ r ) + (Mat_ m ) = Mat_ $ A.zipWith (+) (A.map ((*) $ A.constant r) (identFrm_ m)) m + -- (Mat_ m ) + (Id_ r ) = Mat_ $ A.zipWith (A.+) m (A.map ((A.*) $ A.constant r) (identFrm_ m)) + (Mat_ m1) + (Mat_ m2) = Mat_ $ A.zipWith (A.+) m1 m2 + +instance (Vector a, Vector b, IsMutable(a +> b)) => Monoid (a +> b) where + zero = Zero + +instance (Vector a, Vector b, IsMutable(a +> b)) => Cancellative (a +> b) where + a - Zero = a + Zero - a = negate a + (Id_ r1) - (Id_ r2) = Id_ (r1-r2) + -- (Id_ r ) - (Mat_ m ) = Mat_ $ A.zipWith (A.-) (A.map ((A.*) r) (identFrm_ m)) m + -- (Mat_ m ) - (Id_ r ) = Mat_ $ A.zipWith (A.-) m (A.map ((A.*) r) (identFrm_ m)) + (Mat_ m1) - (Mat_ m2) = Mat_ $ A.zipWith (A.-) m1 m2 + +instance (Vector a, Vector b, IsMutable(a +> b)) => Group (a +> b) where + negate Zero = Zero + negate (Id_ r) = Id_ $ negate r + negate (Mat_ m) = Mat_ $ A.map (A.* (-1)) m + +instance (IsMutable(a +> b)) => Abelian (a +> b) + +------------------- +-- modules + +instance (Vector a, Vector b, IsMutable(a +> b)) => Module (a +> b) where + Zero .* _ = Zero + (Id_ r1) .* r2 = Id_ $ r1*r2 + (Mat_ m) .* r2 = Mat_ $ A.map (A.* (r2)) m + +instance (Vector a, Vector b, IsMutable(a +> b)) => FreeModule (a +> b) where + Zero .*. _ = Zero + _ .*. Zero = Zero + (Id_ r1) .*. (Id_ r2) = Id_ $ r1*r2 + -- (Id_ r ) .*. (Mat_ m ) = Mat_ $ A.zipWith (A.*) (A.map ((A.*) r) (identFrm_ m)) m + -- (Mat_ m ) .*. (Id_ r ) = Mat_ $ A.zipWith (A.*) m (A.map ((A.*) r) (identFrm_ m)) + (Mat_ m1) .*. (Mat_ m2) = Mat_ $ A.zipWith (A.*) m1 m2 + +instance (Vector a, Vector b, IsMutable(a +> b)) => Vector (a +> b) where + Zero ./. _ = Zero + (Id_ _) ./. Zero = undefined + (Mat_ _) ./. Zero = undefined + (Id_ r1) ./. (Id_ r2) = Id_ $ r1/r2 + -- (Id_ r ) ./. (Mat_ m ) = Mat_ $ A.zipWith (A./) (A.map ((A.*) r) (identFrm_ m)) m + -- (Mat_ m ) ./. (Id_ r ) = Mat_ $ A.zipWith (A./) m (A.map ((A.*) r) (identFrm_ m)) + (Mat_ m1) ./. (Mat_ m2) = Mat_ $ A.zipWith (A./) m1 m2 + +------------------- +-- rings +-- +-- NOTE: matrices are only a ring when their dimensions are equal + +instance (Vector a, IsMutable(a +> a)) => Rg (a +> a) where + (*) = (>>>) + +instance (Vector a, IsMutable(a +> a)) => Rig (a +> a) where + one = Id_ one + +instance (Vector a, IsMutable(a +> a)) => Ring (a +> a) where + fromInteger i = Id_ $ fromInteger i + +instance (Vector a, IsMutable(a +> a)) => Field (a +> a) where + fromRational r = Id_ $ fromRational r + + reciprocal Zero = undefined + reciprocal (Id_ r ) = Id_ $ reciprocal r + -- reciprocal (Mat_ m) = Mat_ $ HM.inv m From 60c9412091f083dc22b7f6a9f2ba9bcb3759f450 Mon Sep 17 00:00:00 2001 From: tpierson Date: Thu, 20 Oct 2016 19:07:55 +0200 Subject: [PATCH 20/20] Merged Dev into ghc-8.0-accelerate-Acc-rewrite Initial rewrite of Vector.hs complete Merged branch ghc-8.0-accelerate-Acc-Exp into ghc-8.0-accelerate-Acc-rewrite --- .haskell-ghc-mod.json | 1 + examples/example0005-accelerate_backend.lhs | 60 +- src/SubHask/Algebra/Accelerate/Accelerate.hs | 55 -- .../Algebra/Accelerate/AccelerateBackend.hs | 2 +- src/SubHask/Algebra/Accelerate/Vector.hs | 551 ++++++++++++++---- src/SubHask/Algebra/Vector.hs | 1 - stack.yaml | 19 +- subhask.cabal | 2 - 8 files changed, 489 insertions(+), 202 deletions(-) create mode 100644 .haskell-ghc-mod.json delete mode 100644 src/SubHask/Algebra/Accelerate/Accelerate.hs diff --git a/.haskell-ghc-mod.json b/.haskell-ghc-mod.json new file mode 100644 index 0000000..c82d1fe --- /dev/null +++ b/.haskell-ghc-mod.json @@ -0,0 +1 @@ +{ "suppressErrors": true } diff --git a/examples/example0005-accelerate_backend.lhs b/examples/example0005-accelerate_backend.lhs index 1acf081..19a7019 100644 --- a/examples/example0005-accelerate_backend.lhs +++ b/examples/example0005-accelerate_backend.lhs @@ -8,40 +8,44 @@ > {-# LANGUAGE DataKinds #-} > import qualified Prelude as P > import SubHask -> import SubHask.Algebra.Accelerate.Vector (ACCVector) -> import SubHask.Algebra.Vector (UVector) -> import SubHask.Algebra.Matrix (Matrix, unsafeToModuleM) -> import SubHask.Algebra.Accelerate.Matrix (ACCMatrix, mmult) -> import SubHask.Algebra.Accelerate.Accelerate (ValidBackend(..), mkAccVector, mkAccVectorFromList, mkAccMatrixFromList, mkAccMatrixFromMatrix) +> import SubHask.Algebra.Accelerate.Vector (ACCVector, ValidBackend(..), mkAccVectorFromList) +> --import SubHask.Algebra.Matrix (Matrix, unsafeToModuleM) +> --import SubHask.Algebra.Accelerate.Matrix (ACCMatrix, mmult +> import SubHask.Algebra.Array +> import SubHask.Algebra.Vector +> import qualified Data.Array.Accelerate as A > import SubHask.Algebra.Accelerate.AccelerateBackend (Backend(..)) > import System.IO > -> v :: ACCVector Interpreter "a" Double -> v = mkAccVectorFromList [0..5] +> v :: ACCVector Interpreter 4 Float +> v = mkAccVectorFromList [0.0, 1.0, 2.0, 3.0] > -> v' :: ACCVector Interpreter "a" Double -> v' = mkAccVectorFromList [0..5] +> v' :: ACCVector Interpreter 4 Float +> v' = mkAccVectorFromList [0..3] +> sngtln = (A.constant 2.0) +> --mmat :: Matrix (UVector "v" Double) Double "a" "b" +> --mmat = unsafeToModuleM 2 [0..5] > +> --m :: ACCMatrix Interpreter (ACCVector Interpreter "v" Double ) "a" "b" Double +> --m = mkAccMatrixFromMatrix mmat > -> mmat :: Matrix (UVector "v" Double) Double "a" "b" -> mmat = unsafeToModuleM 2 [0..5] -> -> m :: ACCMatrix Interpreter (ACCVector Interpreter "v" Double ) "a" "b" Double -> m = mkAccMatrixFromMatrix mmat -> -> mm :: ACCMatrix Interpreter (ACCVector Interpreter "v" Double ) "b" "a" Double -> mm = mkAccMatrixFromList 5 [0,1,2,3,4,5,6,7,8,9] +> --mm :: ACCMatrix Interpreter (ACCVector Interpreter "v" Double ) "b" "a" Double +> --mm = mkAccMatrixFromList 5 [0,1,2,3,4,5,6,7,8,9] > > main :: IO () > main = do -> putStrLn $ "v = " ++ show (runAccVector v) -> putStrLn $ "v' = " ++ show (runAccVector v') -> putStrLn $ "v + v = " ++ show (runAccVector (v + v)) -> putStrLn $ "v + v - v = " ++ show (runAccVector (v + v - v')) -> putStrLn $ "v * v / v = " ++ show (runAccVector (v .*. v ./. v')) -> putStrLn $ "v' * 2 = " ++ show (runAccVector (v' .* 2)) -> putStrLn $ "v' * 2 = " ++ show (runAccVector (v' .* 2)) -> putStrLn $ "m * 2 = " ++ show (runAccMatrix (m .* 2)) -> putStrLn $ "m + 2 = " ++ show (runAccMatrix ((m + 2) - 1 )) -> putStrLn $ "m / 2 = " ++ show (runAccMatrix (m / 2)) -> putStrLn $ "m mmult mm = " ++ show (runAccMatrix (mmult m mm)) +> putStrLn $ "v = " + show v +> putStrLn $ "v' = " + show v' +> putStrLn $ "v + v = " + (show $ runAccVector (v + v)) +> putStrLn $ "v + v - v = " + (show $ runAccVector(v + v - v')) +> putStrLn $ "v * v = " + (show $ runAccVector (v .*. v )) +> putStrLn $ "v / v' = " + (show $ runAccVector (v ./. v')) +> putStrLn $ "v * v / v' = " + (show $ runAccVector (v .*. v ./. v')) +> putStrLn $ "v' .* 2 = " + (show $ runAccVector (v' .* sngtln)) +> putStrLn $ "v' ./ 2 = " + (show $ runAccVector (v' ./ sngtln)) +> putStrLn $ "v >< v' = " + (show $ runAccVector (v >< v)) +> putStrLn $ "v**2 = " + (show $ runAccVector (v**v')) +> --putStrLn $ "m * 2 = " ++ show (runAccMatrix (m .* 2)) +> --putStrLn $ "m + 2 = " ++ show (runAccMatrix ((m + 2) - 1 )) +> --putStrLn $ "m / 2 = " ++ show (runAccMatrix (m / 2)) +> --putStrLn $ "m mmult mm = " ++ show (runAccMatrix (mmult m mm)) diff --git a/src/SubHask/Algebra/Accelerate/Accelerate.hs b/src/SubHask/Algebra/Accelerate/Accelerate.hs deleted file mode 100644 index 4baffaa..0000000 --- a/src/SubHask/Algebra/Accelerate/Accelerate.hs +++ /dev/null @@ -1,55 +0,0 @@ -module SubHask.Algebra.Accelerate.Accelerate -( - ValidBackend(..) - -- , runAccVector - , mkAccVectorFromList - -- , mkAccMatrixFromList - -- , mkAccMatrixFromMatrix - --, acc2SVector -) -where - -import SubHask.Algebra.Accelerate.AccelerateBackend (Backend(..)) -import SubHask.Algebra.Accelerate.Vector --- import SubHask.Algebra.Accelerate.Matrix -import qualified Data.Array.Accelerate as A --- import qualified Data.Array.Accelerate.LLVM.Array.Data as LLVM -import qualified Data.Array.Accelerate.CUDA as CUDA -import qualified Data.Array.Accelerate.Interpreter as I -import SubHask.Internal.Prelude -import qualified Prelude as P - ---FIXME: Replace all intermediary lists with correct use of acclerate-io -mkAccVectorFromList :: A.Elt a => [a] -> ACCVector bknd (n::Symbol) a -mkAccVectorFromList l = let - len = P.length l - in ACCVector (A.use (A.fromList (A.Z A.:.len) l)) - --- mkAccVector :: (A.Elt a, ValidSVector (n::Symbol) a) => SVector (n::Symbol) a -> ACCVector (bknd::Backend) (n::Symbol) a --- mkAccVector v @(SVector_Dynamic fp off n) = let --- arr = A.fromList (A.Z A.:. n) $ unsafeInlineIO $ go (n-1) [] --- go (-1) xs = return $ xs --- go i xs = withForeignPtr fp $ \p -> do --- x <- peekElemOff p (off+i) --- go (i-1) (x:xs) --- in ACCVector (A.use arr) - --- acc2SVector :: ValidACCVector (b::Backend) n a => ACCVector (b::Backend) n a -> SVector n a --- acc2SVector (ACCVector v) = unsafeToModule $ (runAccVector v) :: SVector n a - - -class ValidBackend (b::Backend) where - runAccVector :: (ValidACCVector (b::Backend) n a, A.IsScalar a) => ACCVector (b::Backend) n a -> [a] - -- runAccMatrix :: (ValidACCMatrix (b::Backend) v r, A.IsScalar a, A.Elt a) => ACCMatrix (b::Backend) v n m a -> [a] - -instance ValidBackend 'Interpreter where - runAccVector (ACCVector a) = A.toList (I.run a) - -- runAccMatrix (ACCMatrix a) = A.toList (I.run a) - -instance ValidBackend 'CUDA where - runAccVector (ACCVector a) = A.toList (CUDA.run a) - -- runAccMatrix (ACCMatrix a) = A.toList (CUDA.run a) - --- instance ValidBackend LLVM where --- runAccVector (ACCVector a) = A.toList (LLVM.runArray a) --- runAccMatrix (ACCMatrix a) = A.toList (LLVM.runArray a) diff --git a/src/SubHask/Algebra/Accelerate/AccelerateBackend.hs b/src/SubHask/Algebra/Accelerate/AccelerateBackend.hs index a1b9c8a..076abe4 100644 --- a/src/SubHask/Algebra/Accelerate/AccelerateBackend.hs +++ b/src/SubHask/Algebra/Accelerate/AccelerateBackend.hs @@ -7,6 +7,6 @@ where data Backend = Interpreter - | CUDA + -- | CUDA -- | LLVM -- LLVM has an SoC project slated, so check back in 60 days for non-parial functionality diff --git a/src/SubHask/Algebra/Accelerate/Vector.hs b/src/SubHask/Algebra/Accelerate/Vector.hs index 80814c4..e19faff 100644 --- a/src/SubHask/Algebra/Accelerate/Vector.hs +++ b/src/SubHask/Algebra/Accelerate/Vector.hs @@ -2,6 +2,9 @@ module SubHask.Algebra.Accelerate.Vector ( ValidACCVector , ACCVector (..) + , ValidBackend(..) + , mkAccVectorFromList + ) where @@ -19,9 +22,9 @@ import Foreign.Marshal.Utils import qualified Data.Array.Accelerate as A import SubHask.Algebra -import SubHask.Algebra.Accelerate.AccelerateBackend (Backend) +import SubHask.Algebra.Accelerate.AccelerateBackend (Backend(..)) import SubHask.Category -import SubHask.Algebra.Vector (SVector, type (+>)) +import SubHask.Algebra.Vector (SVector) import SubHask.Compatibility.Base import SubHask.Internal.Prelude import SubHask.SubType @@ -29,114 +32,175 @@ import SubHask.SubType import System.IO.Unsafe import Unsafe.Coerce +-- import qualified Data.Array.Accelerate.CUDA as CUDA +import qualified Data.Array.Accelerate.Interpreter as I +import SubHask.Internal.Prelude +import qualified Prelude as P + +--FIXME: Replace all intermediary lists with correct use of acclerate-io +mkAccVectorFromList :: A.Elt a => [a] -> ACCVector bknd (n::Nat) a +mkAccVectorFromList l = let + len = P.length l + in ACCVector (A.use (A.fromList (A.Z A.:.len) l)) + +class ValidBackend (b::Backend) where + runAccVector :: (ValidACCVector (b::Backend) n a) => ACCVector (b::Backend) n a -> [a] + runAccMatrix :: (A.IsScalar a, A.Elt a) => ACCMatrix (b::Backend) n m a -> [a] +instance ValidBackend 'Interpreter where + runAccVector (ACCVector a) = A.toList (I.run a) + --how to preserve the >< = a+>a interface since I.run wants a plain A.Acc? + --runAccMatrix (ACCMatrix m) = A.toList (I.run m) +-- instance ValidBackend 'CUDA where +-- runAccVector (ACCVector a) = A.toList (CUDA.run a) + -- runAccMatrix (ACCMatrix a) = A.toList (CUDA.run a) + +-- instance ValidBackend LLVM where +-- runAccVector (ACCVector a) = A.toList (LLVM.runArray a) +-- runAccMatrix (ACCMatrix a) = A.toList (LLVM.runArray a) + +-------------------------------------------------------------------------------- +--A.Exp Orphaned Instances; I'm sure there's a way to clean these up . . . +instance (Prim r) => IsMutable (A.Exp r ) + +instance (Monoid r, Prim r ) => Semigroup (A.Exp r ) +instance (Prim r, FreeModule r) => Field (A.Exp r ) +instance (Prim r, Monoid r, Cancellative r) => Cancellative (A.Exp r ) +instance (Semigroup (Actor(A.Exp r)), Action r, Semigroup r, Prim r) => Action (A.Exp r ) +instance (Prim r, Monoid r) => Monoid (A.Exp r ) +instance (Monoid r, Abelian r, Prim r) => Abelian (A.Exp r ) +instance (Prim r, Cancellative r, Monoid r) => Group (A.Exp r ) +instance (P.Num (A.Exp r ), FreeModule r, Prim r, Abelian r , Group r, Ring (Scalar r), Scalar (Scalar r) ~ Scalar r ) => Module (A.Exp r) where + {-# INLINE (.*) #-} + (.*) = (A.*) +instance (Abelian r, Cancellative r, Monoid r, Prim r) => Ring(A.Exp r ) +instance (Abelian r, Prim r, Monoid r) => Rig(A.Exp r ) +instance (Prim r, Monoid r, Abelian r) => Rg(A.Exp r ) +instance (Prim r, P.Num (A.Exp r), P.Num r, FreeModule r) => FreeModule (A.Exp r ) +instance Module (A.Exp Int) where (.*) = (A.*) +instance (P.Num (A.Exp Integer), Prim Integer) => Module (A.Exp Integer) where (.*) = (A.*) +instance Module (A.Exp Float) where (.*) = (A.*) +instance Module (A.Exp Double) where (.*) = (A.*) +-------------------------------------------------------------------------------- +--A.Acc (A.Scalar r) Instances +instance (Prim r) => IsMutable (A.Acc (A.Scalar r)) +instance (Prim r, Monoid r) => Semigroup (A.Acc (A.Scalar r)) + +instance (Prim r, Monoid r) => Monoid (A.Acc (A.Scalar r)) +-- +instance (Monoid r, Abelian r, Prim r) => Abelian (A.Acc (A.Scalar r)) +instance (Scalar (Scalar (A.Acc (A.Scalar r))) + ~ + Scalar (A.Acc (A.Scalar r)), Ring (Scalar (A.Acc (A.Scalar r))), Prim r, Abelian r, Group r, Ring (Scalar r), Scalar (Scalar r) ~ Scalar r) => Module (A.Acc (A.Scalar r)) where + +instance ( Prim r, Cancellative r, Monoid r) => Group (A.Acc (A.Scalar r)) +instance (Prim r, Monoid r, Cancellative r) => Cancellative (A.Acc (A.Scalar r)) +instance (Prim r, FreeModule r) => Ring(A.Acc (A.Scalar r)) +instance (Prim r, FreeModule r) => Rig(A.Acc (A.Scalar r)) +instance (Prim r, FreeModule r) => Rg(A.Acc (A.Scalar r)) +instance (Prim r, FreeModule r) => Field (A.Acc (A.Scalar r)) -------------------------------------------------------------------------------- -- | Accelerate based Vector -- | A.Acc is an accelreate computation, A.Array A.DIM1 a is a one dimensional array -newtype ACCVector (bknd::Backend) (n::k) a = ACCVector (A.Acc (A.Array A.DIM1 a)) +newtype ACCVector (bknd::Backend) (n::Nat) a = ACCVector (A.Acc (A.Array A.DIM1 a)) + +type instance Scalar (A.Acc(A.Scalar Int)) = A.Acc(A.Scalar Int) +type instance Scalar (A.Acc(A.Scalar Float)) = A.Acc(A.Scalar Float) +type instance Scalar (A.Acc(A.Scalar Double)) = A.Acc(A.Scalar Double) +type instance Scalar (A.Acc(A.Scalar Rational)) = A.Acc(A.Scalar Rational) +type instance Scalar (A.Exp r) = A.Exp r +type instance Actor (A.Exp r) = Scalar (A.Exp r) +type instance Logic (A.Exp r) = A.Exp Bool + +-- type instance Scalar (A.Acc(A.Scalar r)) = ACCExp r +type instance Scalar (ACCVector bknd n r) = Scalar (A.Exp r) -type instance Scalar (ACCVector bknd n r) = A.Acc(A.Scalar r) -type instance Logic (ACCVector bknd n r) = A.Acc(A.Scalar Bool) +-- type instance Logic (A.Acc(A.Scalar r)) = A.Acc(A.Scalar Bool) +type instance Logic (ACCVector bknd n r) = Logic (A.Exp r) type ValidACCVector bknd n a = ( Prim a , A.Elt a , P.Num (A.Exp a) - , Scalar (A.Acc (A.Scalar a)) ~ A.Acc (A.Scalar a) - , Ring (A.Acc (A.Scalar a)) - , Logic (Logic (A.Acc (A.Scalar Bool))) ~ Logic (A.Acc (A.Scalar Bool)) - , Container (A.Acc (A.Scalar Bool)) - , Boolean (A.Acc (A.Scalar Bool)) - , Ord (A.Acc (A.Scalar a)) - , Normed (A.Acc (A.Scalar a)) - , Vector (ACCVector bknd n a) - , Vector (Square (ACCVector bknd n a)) - , Elem (Square (ACCVector bknd n a)) ~ ACCVector bknd n a - , Semigroup (A.Exp a) - , Field (A.Exp a) - , Rg (A.Exp a) - , Index (Square (ACCVector bknd n a)) ~ A.Acc (A.Scalar Int) - -- , Logic (A.Acc (A.Scalar a)) ~ A.Acc (A.Scalar a) - -- , Actor (A.Acc (A.Scalar a)) ~ A.Acc (A.Scalar a) - -- , Container (A.Acc (A.Scalar a)) - -- , Container (Logic (A.Acc (A.Scalar Bool))) - -- , Boolean (Logic (A.Acc (A.Scalar Bool))) - -- , Logic (Logic (A.Acc (A.Scalar Bool))) ~ Logic (A.Acc (A.Scalar Bool)) - -- , Logic (A.Acc (A.Scalar Bool)) ~ A.Acc (A.Scalar Bool) - -- , Elem (A.Acc (A.Scalar a)) ~ A.Acc (A.Scalar a) -- , P.Fractional (A.Exp a) -- , P.Floating (A.Exp a) - , P.Floating (A.Acc (A.Scalar a)) - , P.Floating (A.Acc (A.Array A.DIM0 a)) - -- , Elem (Square (ACCVector bknd n a)) ~ ACCVector bknd n a - -- , Index (Square (ACCVector bknd n a)) ~ A.Acc (A.Scalar Int) - -- , Index (A.Acc (A.Scalar Int)) ~ A.Acc (A.Scalar Int) - -- , Vector (Square (ACCVector bknd n a)) - -- , Transposable (Square (ACCVector bknd n a)) - -- , IxContainer (Square (ACCVector bknd n a)) - -- , FreeModule a - -- , Vector (ACCVector bknd n a) - + -- , P.Num (A.Acc(A.Scalar a)) + -- , P.Fractional (A.Acc(A.Scalar a)) + -- , P.Floating (A.Acc(A.Scalar a)) ) -type instance Index (ACCVector bknd n r) = A.Acc(A.Scalar Int) -type instance Elem (ACCVector bknd n r) = A.Acc(A.Scalar r) +type instance Index (ACCVector bknd n r) = Scalar (A.Exp Int) +type instance Elem (ACCVector bknd n r) = Scalar (A.Exp r) + +type instance Actor (ACCVector (bknd::Backend) n r) = Scalar (A.Exp r) + + +instance (Arbitrary r, ValidACCVector b n r, FreeModule r, ValidScalar r) => Arbitrary (ACCVector (bknd::Backend) n r) +-- where +-- arbitrary = frequency +-- [ (1,return zero) +-- , (9,fmap unsafeToModule $ replicateM 27 arbitrary) +-- ] +-- instance NFData (ACCVector (bknd::Backend) n r) +-- where +-- rnf (SVector_Dynamic fp _ _) = seq fp () + + +-- instance (FromField r, ACCVector (bknd::Backend) n r, ValidScalar r, FreeModule r) => FromRecord (ACCVector (bknd::Backend) n r) +-- where +-- parseRecord r = do +-- rs :: [r] <- parseRecord r +-- return $ mkAccVectorFromList rs -type instance Actor (ACCVector (bknd::Backend) n r) = A.Acc(A.Scalar r) instance (KnownNat n, Prim a) => IsMutable (ACCVector (bknd::Backend) (n::Nat) a) instance (KnownNat n, Monoid r, ValidACCVector b n r) => Semigroup (ACCVector (b::Backend) (n::Nat) r) where {-# INLINE (+) #-} - (+) :: ACCVector bknd n r -> ACCVector bknd n r -> ACCVector bknd n r - (+) (ACCVector v1) (ACCVector v2)=ACCVector (A.zipWith (P.+) v1 v2) + (+) (ACCVector v1) (ACCVector v2)=ACCVector (A.zipWith (A.+) v1 v2) -instance (Semigroup (A.Acc (A.Scalar r)), KnownNat n, ValidACCVector bknd n r, Action r, Semigroup r, Prim r) => Action (ACCVector (bknd::Backend) (n::Nat) r) where +instance ( Semigroup (A.Exp r), Monoid r, KnownNat n, ValidACCVector bknd n r, Action r, Semigroup r, Prim r) => Action (ACCVector (bknd::Backend) (n::Nat) r) where {-# INLINE (.+) #-} - (.+) (ACCVector v) r = ACCVector (A.map (A.+ (A.the r)) v) + (.+) (ACCVector v) r = ACCVector (A.map ((A.+) r) v) instance (KnownNat n, Monoid r, Cancellative r, ValidACCVector bknd n r) => Cancellative (ACCVector (bknd::Backend) (n::Nat) r) where {-# INLINE (-) #-} - (-) (ACCVector a1) (ACCVector a2) = ACCVector (A.zipWith (P.-) a1 a2) + (-) (ACCVector a1) (ACCVector a2) = ACCVector (A.zipWith (A.-) a1 a2) + ---The zero method wants a Ring r in the case where zero is the integer "0" ---or Field r in the case of "0.0" ---In either case, the Group instance wants the same constraint. Not exactly sure how to handle this. -instance (KnownNat n, Monoid r, ValidACCVector bknd n r) => Monoid (ACCVector (bknd::Backend) (n::Nat) r) where +instance (KnownNat n, Monoid r, ValidACCVector bknd n r) => Monoid (ACCVector (bknd::Backend) (n::Nat) r) + -- where -- {-# INLINE zero #-} -- zero = ACCVector(A.use (A.fromList (A.Z A.:.1) [(0::r)])) -instance (KnownNat n, Group r, ValidACCVector bknd n r) => Group (ACCVector (bknd::Backend) (n::Nat) r) where +instance (KnownNat n, Group r, ValidACCVector bknd n r) => Group (ACCVector (bknd::Backend) (n::Nat) r) + where {-# INLINE negate #-} negate = negate instance (KnownNat n, Monoid r, Abelian r, ValidACCVector bknd n r) => Abelian (ACCVector (bknd::Backend) (n::Nat) r) -instance ( KnownNat n, FreeModule r, ValidACCVector bknd n r) => FreeModule (ACCVector (bknd::Backend) (n::Nat) r) where +instance (Rg (A.Exp r), Ring (A.Exp r), KnownNat n, FreeModule r, ValidACCVector bknd n r) => FreeModule (ACCVector (bknd::Backend) (n::Nat) r) where {-# INLINE (.*.) #-} - (.*.) (ACCVector a1) (ACCVector a2) = ACCVector( A.zipWith (P.*) a1 a2) + (.*.) (ACCVector a1) (ACCVector a2) = ACCVector( A.zipWith (A.*) a1 a2) -instance ( KnownNat n, Module r, ValidACCVector bknd n r) => Module (ACCVector (bknd::Backend) (n::Nat) r) where - {-# INLINE (.*) #-} - (.*) (ACCVector v) r = ACCVector (A.map (P.* (A.the r)) v) +instance (Ring (A.Acc (A.Scalar r)), P.Fractional (A.Exp r), Ring (A.Exp r),Field (A.Exp r), KnownNat n, Vector r, ValidACCVector bknd n r) => Vector (ACCVector (bknd::Backend) (n::Nat) r) where + {-# INLINE (./) #-} ; (./) (ACCVector v) r = ACCVector $ A.map ((A./) r) v + {-# INLINE (./.) #-} ; (./.) (ACCVector a1) (ACCVector a2) = ACCVector $ (A.zipWith (A./) a1 a2) --- instance (Field (A.Acc (A.Scalar r)), KnownNat n, VectorSpace r, ValidACCVector bknd n r) => VectorSpace (ACCVector (bknd::Backend) (n::Nat) r) where --- {-# INLINE (./) #-} --- (./) (ACCVector v) r = ACCVector (A.map (P./ (A.the r)) v) --- --- {-# INLINE (./.) #-} --- (./.) (ACCVector a1) (ACCVector a2) = ACCVector (A.zipWith (P./) a1 a2) +instance (Rg (A.Exp r), Ring(A.Exp r), KnownNat n, Module r, ValidACCVector bknd n r) => Module (ACCVector (bknd::Backend) (n::Nat) r) where + {-# INLINE (.*) #-} + (.*) (ACCVector v) r = ACCVector (A.map ((A.*) r) v) -instance (KnownNat n, FreeModule r, ValidACCVector b n r) => FiniteModule (ACCVector b (n::Nat) r) +instance (Ring (A.Exp r), Rg (A.Exp r), Ring (A.Acc (A.Scalar r)), KnownNat n, FreeModule r, ValidACCVector b n r) => FiniteModule (ACCVector b (n::Nat) r) --dim wants an Int but here gets an A.Exp Int. I tried changing the signiture to a generic type in Alegbra.hs but that produced numerous errors. - where - -- dim :: ACCVector b (n::Nat) r -> A.Exp Int - -- {-# INLINE dim #-} - -- dim (ACCVector v) = A.size v + -- where + -- {-# INLINE dim #-} + -- dim (ACCVector v) = A.size v instance @@ -146,101 +210,372 @@ instance , Monoid r , ValidACCVector b n r , KnownNat n + , Eq (ACCVector b n r) , FreeModule r + ) => IxContainer (ACCVector b (n::Nat) r) where {-# INLINE (!) #-} - (!) (ACCVector v) i = A.unit (v A.! A.index1 (A.the (i))) + (!) (ACCVector v) i = (v A.! A.index1 i) - -- {-# INLINABLE imap #-} - -- -- imap f (ACCVector v) = A.zipWith (\i x -> f ((A.unit i)::A.Acc (A.Scalar Int)) ((A.unit x)::A.Acc (A.Scalar r))) ((A.generate (A.shape v) P.id):: A.Array A.DIM1 Int) v - -- imap f (ACCVector v) = let - -- mapd = A.imap (\x (i::A.Exp r) -> let A.Z A.:. idx = A.unlift x -- This dance is probably not optimal but f expects A.Scalars so we have to build them - -- in A.the (f ((A.unit i) :: Index (ACCVector b n r)) (x ! idx))) v - -- in ACCVector mapd + {-# INLINABLE imap #-} + imap f (ACCVector v) = ACCVector $ A.imap (\i x ->let + A.Z A.:. idx = A.unlift i + in f idx x - type ValidElem (ACCVector b n r) e = (FiniteModule e, ValidACCVector b n e) + ) v -instance (A.Eq r, KnownNat n, Eq r, Monoid r, ValidACCVector b n r) => Eq (ACCVector b (n::Nat) r) where + + type ValidElem (ACCVector b n r) e = (ClassicalLogic e, ValidScalar e, FiniteModule e, ValidACCVector b n e) + +instance (Ord (A.Exp r), A.Eq r, Boolean (A.Exp Bool), Container (A.Exp Bool), KnownNat n, Eq r, Monoid r, ValidACCVector b n r) => Eq (ACCVector b (n::Nat) r) where {-# INLINE (==) #-} (ACCVector v2) == (ACCVector v1) = let l = A.zipWith (\x y -> x A.==* y) v1 v2 ele = l A.! A.index1 (A.constant 0) bl = A.all (A.&&* ele) l - in bl + in A.the bl + instance ( ValidACCVector b n r + , Normed (A.Exp r) , A.Eq r + , Ord (A.Exp r) + , Normed (A.Acc (A.Scalar r)) , ExpField r , Ord r - -- , VectorSpace r + , Ring (A.Exp r) + , Eq (ACCVector b n r) , KnownNat n + , Ring (A.Exp r) + , P.Num r + , Normed (A.Exp r) + , ExpField (A.Acc (A.Scalar r)) ) => Metric (ACCVector b (n::Nat) r) where {-# INLINE[2] distance #-} distance (ACCVector v1) (ACCVector v2) = {-# SCC distance_ACCVector #-}let - dmag = A.zipWith (P.-) v1 v2 - dsq = A.zipWith (P.*) dmag dmag - drt = A.sqrt (A.sum dsq) - in drt + dmag = A.zipWith (A.-) v1 v2 + dsq = A.zipWith (A.*) dmag dmag + drt = sqrt (A.sum dsq) + in A.the drt -instance (KnownNat n, ValidACCVector b n r, ExpField r) => Normed (ACCVector b (n::Nat) r) where +instance (Ord (A.Exp r), Ring (A.Exp r), ExpField (A.Acc (A.Scalar r)), Rg (A.Exp r), Ord (A.Acc (A.Scalar r)), Ring (A.Acc (A.Scalar r)), KnownNat n, ValidACCVector b n r, ExpField r) => Normed (ACCVector b (n::Nat) r) where {-# INLINE size #-} size (ACCVector v1) = let - sq = A.zipWith (P.*) v1 v1 - s = A.fold (P.+) (A.constant 0.0) sq - srt = A.sqrt s - in srt + sq = A.zipWith (A.*) v1 v1 + s = A.fold (A.+) (A.constant 0.0) sq + srt = sqrt s + in A.the srt instance ( A.Eq r , Normed r + , Normed (A.Exp r) + , Ord (A.Exp r) + , Ring (A.Exp r) + , Field (A.Exp r) , ValidACCVector b n r , ExpField r + , Vector r + , Ord (A.Acc (A.Scalar r)) , Real r + , P.Num r + , ExpField (A.Acc (A.Scalar r)) + , Rg (A.Exp r) + , Normed (A.Acc (A.Scalar r)) + , P.Fractional (A.Exp r) + , Field (A.Acc (A.Scalar r)) + , Eq (ACCVector b n r) , Ord r + , P.Floating (A.Acc (A.Scalar r)) , KnownNat n ) => Banach (ACCVector b (n::Nat) r) --- instance --- ( FiniteModule (ACCVector b (n::Nat) r) --- , VectorSpace (ACCVector b (n::Nat) r) --- , Normed (ACCVector b n r +> ACCVector b n r) --- , KnownNat n --- , MatrixField r --- ) => TensorAlgebra (ACCVector b (n::Nat) r) --- where --- (ACCVector v1)><(ACCVector v2) = let --- r = A.size v1 --- c = A.size v2 --- arr = A.map (\i -> A.lift (A.map (\j -> i * j ) v1)) v2 --- m = A.reshape (A.index2 r c) arr :: ACCVector bknd n r +> ACCVector bknd m r --- in m + +-- So far unable to get the dagger interface to square with the fact that any operation returns inside the A.Acc monad. +--newtype ACCMatrix b m n a = ACCMatrix( A.Acc (A.Array A.DIM2 a))--ACCVector b m a +> ACCVector b n a +newtype ACCMatrix b m n a = ACCMatrix (ACCVector b m a +> ACCVector b n a) + +mkACCMatrix r c l = Mat_ $ A.use $ A.fromList (A.Z A.:. r A.:. c) l instance ( ValidACCVector b n r - , Transposable (Square (ACCVector b n r)) - , IxContainer (Square (ACCVector b n r)) + , Normed (A.Acc (A.Scalar r)) + , Ord (A.Exp r) + , Ord (A.Acc (A.Scalar r)) , FreeModule r + , ExpField (A.Acc (A.Scalar r)) + , Ring (A.Acc (A.Scalar r)) + , P.Floating (A.Acc (A.Scalar r)) , ExpField r + , P.Fractional (A.Exp r) + , Normed (A.Exp r) + , Eq (ACCVector b n r) , Real r , A.Eq r + , Vector r , OrdField r , MatrixField r , KnownNat n + , Field (A.Exp r) + , IsMutable (ACCVector b n r +> ACCVector b n r) , P.Num r + , Elem (Square (ACCVector b n r)) ~ ACCVector b n r ) => Hilbert (ACCVector b (n::Nat) r) where {-# INLINE (<>) #-} (<>) (ACCVector v1) (ACCVector v2) = let - singlton = A.fold (+) 0.0 (A.zipWith (*) v1 v2) --This float-valued accumulator forces a Field (A.Exp r) constraint above. Is there a way to formulate the constraints such that a more general zero-value could be used? - in singlton + s = A.sum (A.zipWith (A.*) v1 v2) + in A.the s + + type Square (ACCVector b n r) = ACCVector b n r +> ACCVector b n r + --Does this need an unsafeCoerce to get GHC to accept that the result is ACCVector b n r + > ACCVector b n r and not the acclerate types? + -- (ACCVector v1)><(ACCVector v2) = let + -- r = A.size v1 + -- c = A.size v2 + -- m = A.zipWith (A.*) (A.replicate (A.lift $ A.Any A.:. r A.:. A.All) v1 ) (A.replicate (A.lift $ A.Any A.:. A.All A.:. c) v2) + -- in m + + mXv m v= m $ v + vXm v m = trans m $ v + +instance (Show r, ValidBackend b, ValidACCVector (b::Backend) n r, KnownNat n) => Show (ACCVector (b::Backend) n r) where + show v = show (runAccVector v) type MatrixField r = - ( - Field r - ) + (ValidScalar r + , Vector r + , Field r + ) + +class ToFromVector a where + toVector :: a -> ACCVector b n a + fromVector :: ACCVector b n a -> a + +instance ToFromVector Double where + toVector x = mkAccVectorFromList [x] + --fromVector v = A.toList v + +-- These are building what from what, exactly? +-- instance MatrixField r => ToFromVector (ACCVector b (n::Symbol) r) where +-- toVector (SVector_Dynamic fp off n) = VS.unsafeFromForeignPtr fp off n +-- fromVector v = SVector_Dynamic fp off n +-- where +-- (fp,off,n) = VS.unsafeToForeignPtr v + +-- instance (KnownNat n, MatrixField r) => ToFromVector (SVector (n::Nat) r) where + -- toVector (SVector_Nat fp) = VS.unsafeFromForeignPtr fp 0 n +-- where +-- n = nat2int (Proxy::Proxy n) +-- fromVector v = SVector_Nat fp +-- where +-- (fp,_,_) = VS.unsafeToForeignPtr v + +-- what is this? +-- apMat_ :: +-- ( Scalar a~Scalar b +-- , Scalar b ~ Scalar (Scalar b) +-- , MatrixField (Scalar a) +-- , ToFromVector a +-- , ToFromVector b +-- ) => HM.Matrix (Scalar a) -> a -> b +-- apMat_ m a = fromVector $ A.flatten $ m HM.<> HM.asColumn (toVector a) + + +data (+>) a b where + Zero :: (Module a, Module b) => a +> b + Id_ :: (Vector b) => !(Scalar b) -> b +> b + Mat_ :: + (MatrixField (Scalar b), Scalar a ~ Scalar b, + Scalar b ~ Scalar (Scalar b), Scalar a ~ A.Exp a, + Scalar b ~ A.Exp b, P.Fractional (A.Exp a), P.Fractional (A.Exp b), + P.Num (A.Exp b), P.Num (A.Exp a), Prim a, Prim b, A.Elt b, A.Elt a, + Vector a, Vector b, ToFromVector a, ToFromVector b) => + A.Acc (A.Array A.DIM2 b) -> a +> b + +type instance Scalar (a +> b) = Scalar b +type instance Logic (a +> b) = A.Exp Bool + +-- type instance (a +> b) >< c = Tensor_Linear (a +> b) c +-- type family Tensor_Linear a b where +-- Tensor_Linear (a +> b) c = a +> b + +-------------------------------------------------------------------------------- +-- instances + +deriving instance (A.Elt b, A.Elt a, MatrixField (Scalar b), Show (Scalar b) ) => Show (a +> b) + + + + + + +--------------------------------------------------------------------------------- +-- accelerate linear algebra helpers +-- omitted some signitures because I couldn't deduce what ghc wanted and it's likely to need refactoring anyway + +--fillsqu_:: (A.Elt a, A.Num a) => (A.Exp((A.Z A.:. Int ) A.:. Int) -> A.Exp a) -> A.Exp Int -> ACCMatrix b m m a +fillsqu_ f d = A.generate (A.index2 d d) f + +--ident_:: A.Exp((A.Z A.:. Int ) A.:. Int) -> A.Exp Int +ident_ d = let + A.Z A.:. rows A.:. cols = A.unlift d + in A.cond (rows A.==* cols ) (A.constant one) (A.constant zero) + +identFrm_ :: (A.IsNum a , A.Elt a ) => A.Acc (A.Array A.DIM2 a) -> A.Acc (A.Array A.DIM2 Int) +identFrm_ m = fillsqu_ ident_ (fst $ matrixShape_ m) + +matrixShape_ :: (A.IsNum a , A.Elt a ) => A.Acc (A.Array A.DIM2 a) -> (A.Exp Int, A.Exp Int) +matrixShape_ arr = let + A.Z A.:. rows A.:. cols = A.unlift (A.shape arr) + in (rows, cols) + +--multiplyMatrixMatrix_ :: (A.IsNum b , A.Elt b ) => (A.Acc (A.Array A.DIM2 b)) -> (A.Acc (A.Array A.DIM2 b)) -> (A.Acc (A.Array A.DIM2 b)) -> (A.Acc (A.Array A.DIM2 b)) +multiplyMatrixMatrix_ arr brr = A.fold1 (+) (A.zipWith (*) arrRepl brrRepl) + where + A.Z A.:. rowsA A.:. _ = A.unlift (A.shape arr) :: A.Z A.:. A.Exp Int A.:. A.Exp Int + A.Z A.:. _ A.:. colsB = A.unlift (A.shape brr) :: A.Z A.:. A.Exp Int A.:. A.Exp Int + + arrRepl = A.replicate (A.lift $ A.Z A.:. A.All A.:. colsB A.:. A.All) arr + brrRepl = A.replicate (A.lift $ A.Z A.:. rowsA A.:. A.All A.:. A.All) (A.transpose brr) + + +---------------------------------------- +-- category + +instance Category (+>) where + type ValidCategory (+>) a = MatrixField a + -- This needs to be an A.Exp a in order for the below binary operations to typecheck. + -- However, I haven't been able to successfully make id an "A.Exp 1" . . . + id = Id_ 1 + + Zero . Zero = Zero + Zero . (Id_ _ ) = Zero + Zero . (Mat_ _ ) = Zero + + (Id_ _ ) . Zero = Zero + (Id_ r1) . (Id_ r2) = Id_ (r1*r2) + (Id_ r ) . (Mat_ m ) = Mat_ $ A.map (A.* r) m + + (Mat_ _) . Zero = Zero + (Mat_ m ) . (Id_ r ) = Mat_ $ A.map (A.* r) m + (Mat_ m1) . (Mat_ m2) = Mat_ $ multiplyMatrixMatrix_ m1 m2 + +instance Sup (+>) (->) (->) +instance Sup (->) (+>) (->) + +instance (+>) <: (->) where + embedType_ = Embed2 (embedType2 go) + where + go :: a +> b -> a -> b + go Zero = zero + go (Id_ r) = (r*.) + -- go (Mat_ m) = apMat_ m + +instance Dagger (+>) where + dagger Zero = Zero + dagger (Id_ r) = Id_ r + dagger (Mat_ m) = Mat_ $ A.transpose m + +instance Groupoid (+>) where + inverse Zero = undefined + inverse (Id_ r) = Id_ $ reciprocal r + -- inverse (Mat_ m) = Mat_ $ HM.inv m + +-- FIXME +type instance Elem (a +> b) = b +type instance Index (a +> b) = Index a + +instance (Container (A.Exp Bool)) => Eq (a +> b) +instance (Container (A.Exp Bool)) => IxContainer (a +> b) +instance Transposable (a +> a) where + trans = dagger + +---------------------------------------- +-- size + +-- FIXME: what's the norm of a tensor? +instance (Ord (A.Exp r), Prim r, MatrixField r) => Normed (ACCVector b m r +> ACCVector b m r) where + size Zero = zero + size (Id_ r) = r + -- size (Mat_ m) = HM.det m + +---------------------------------------- +-- algebra + +instance (IsMutable(a +> b)) => Semigroup (a +> b) where + Zero + a = a + a + Zero = a + (Id_ r1) + (Id_ r2) = Id_ (r1+r2) + -- (Id_ r ) + (Mat_ m ) = Mat_ $ A.zipWith (+) (A.map ((*) $ A.constant r) (identFrm_ m)) m + -- (Mat_ m ) + (Id_ r ) = Mat_ $ A.zipWith (A.+) m (A.map ((A.*) $ A.constant r) (identFrm_ m)) + (Mat_ m1) + (Mat_ m2) = Mat_ $ A.zipWith (A.+) m1 m2 + +instance (Vector a, Vector b, IsMutable(a +> b)) => Monoid (a +> b) where + zero = Zero + +instance (Vector a, Vector b, IsMutable(a +> b)) => Cancellative (a +> b) where + a - Zero = a + Zero - a = negate a + (Id_ r1) - (Id_ r2) = Id_ (r1-r2) + -- (Id_ r ) - (Mat_ m ) = Mat_ $ A.zipWith (A.-) (A.map ((A.*) r) (identFrm_ m)) m + -- (Mat_ m ) - (Id_ r ) = Mat_ $ A.zipWith (A.-) m (A.map ((A.*) r) (identFrm_ m)) + (Mat_ m1) - (Mat_ m2) = Mat_ $ A.zipWith (A.-) m1 m2 + +instance (Vector a, Vector b, IsMutable(a +> b)) => Group (a +> b) where + negate Zero = Zero + negate (Id_ r) = Id_ $ negate r + negate (Mat_ m) = Mat_ $ A.map (A.* (-1)) m + +instance (IsMutable(a +> b)) => Abelian (a +> b) + +------------------- +-- modules + +instance (Vector a, Vector b, IsMutable(a +> b)) => Module (a +> b) where + Zero .* _ = Zero + (Id_ r1) .* r2 = Id_ $ r1*r2 + (Mat_ m) .* r2 = Mat_ $ A.map (A.* (r2)) m + +instance (Vector a, Vector b, IsMutable(a +> b)) => FreeModule (a +> b) where + Zero .*. _ = Zero + _ .*. Zero = Zero + (Id_ r1) .*. (Id_ r2) = Id_ $ r1*r2 + -- (Id_ r ) .*. (Mat_ m ) = Mat_ $ A.zipWith (A.*) (A.map ((A.*) r) (identFrm_ m)) m + -- (Mat_ m ) .*. (Id_ r ) = Mat_ $ A.zipWith (A.*) m (A.map ((A.*) r) (identFrm_ m)) + (Mat_ m1) .*. (Mat_ m2) = Mat_ $ A.zipWith (A.*) m1 m2 + +instance (Vector a, Vector b, IsMutable(a +> b)) => Vector (a +> b) where + Zero ./. _ = Zero + (Id_ _) ./. Zero = undefined + (Mat_ _) ./. Zero = undefined + (Id_ r1) ./. (Id_ r2) = Id_ $ r1/r2 + -- (Id_ r ) ./. (Mat_ m ) = Mat_ $ A.zipWith (A./) (A.map ((A.*) r) (identFrm_ m)) m + -- (Mat_ m ) ./. (Id_ r ) = Mat_ $ A.zipWith (A./) m (A.map ((A.*) r) (identFrm_ m)) + (Mat_ m1) ./. (Mat_ m2) = Mat_ $ A.zipWith (A./) m1 m2 + +------------------- +-- rings +-- +-- NOTE: matrices are only a ring when their dimensions are equal + +instance (Vector a, IsMutable(a +> a)) => Rg (a +> a) where + (*) = (>>>) + +instance (Vector a, IsMutable(a +> a)) => Rig (a +> a) where + one = Id_ one + +instance (Vector a, IsMutable(a +> a)) => Ring (a +> a) where + fromInteger i = Id_ $ fromInteger i + +instance (Vector a, IsMutable(a +> a)) => Field (a +> a) where + fromRational r = Id_ $ fromRational r + + reciprocal Zero = undefined + reciprocal (Id_ r ) = Id_ $ reciprocal r + -- reciprocal (Mat_ m) = Mat_ $ HM.inv m diff --git a/src/SubHask/Algebra/Vector.hs b/src/SubHask/Algebra/Vector.hs index 13c61b6..46b2080 100644 --- a/src/SubHask/Algebra/Vector.hs +++ b/src/SubHask/Algebra/Vector.hs @@ -1554,4 +1554,3 @@ instance Vector a => Field (a +> a) where reciprocal Zero = undefined reciprocal (Id_ r ) = Id_ $ reciprocal r reciprocal (Mat_ m) = Mat_ $ HM.inv m - diff --git a/stack.yaml b/stack.yaml index fbdb045..59ffd70 100644 --- a/stack.yaml +++ b/stack.yaml @@ -11,14 +11,19 @@ extra-lib-dirs: - /usr/local/lib packages: - '.' -- location: - git: https://github.com/AccelerateHS/accelerate.git - commit: aed12138a9788ff5d6289d214c84ff6108dc04bd +- location: ../accelerate extra-dep: true -- location: - git: https://github.com/AccelerateHS/accelerate-cuda - commit: 05acd3adca9fd89a8ac19184afbed47d1b7d1505 +# - location: +# git: https://github.com/AccelerateHS/accelerate.git +# commit: aed12138a9788ff5d6289d214c84ff6108dc04bd +# extra-dep: true +- location: ../accelerate-cuda extra-dep: true + +# - location: +# git: https://github.com/AccelerateHS/accelerate-cuda +# commit: 05acd3adca9fd89a8ac19184afbed47d1b7d1505 +# extra-dep: true # - location: # git: https://github.com/AccelerateHS/accelerate-llvm/ # commit: 2c26ca7755a3f5acc3a56dd0f4a23565ba620501 @@ -30,4 +35,4 @@ extra-deps: - homoiconic-0.1.2.0 - unique-0 compiler: ghc-8.0.1 -resolver: nightly-2016-06-15 +resolver: lts-7.2 diff --git a/subhask.cabal b/subhask.cabal index 51e2f06..70c0f5f 100644 --- a/subhask.cabal +++ b/subhask.cabal @@ -54,7 +54,6 @@ library SubHask.Algebra.Ring SubHask.Algebra.Vector SubHask.Algebra.Vector.FFI - SubHask.Algebra.Accelerate.Accelerate SubHask.Algebra.Accelerate.AccelerateBackend SubHask.Algebra.Accelerate.Vector @@ -255,4 +254,3 @@ benchmark bench if flag(llvmsupport) ghc-options: -fllvm -