numhask-array 0.2.0.1 → 0.2.1.0
raw patch · 4 files changed
+70/−73 lines, 4 files
Files
- numhask-array.cabal +1/−1
- src/NumHask/Array.hs +63/−68
- stack.yaml +1/−1
- test/test.hs +5/−3
numhask-array.cabal view
@@ -1,5 +1,5 @@ name: numhask-array-version: 0.2.0.1+version: 0.2.1.0 synopsis: n-dimensional arrays description: n-dimensional arrays founded on numhask. category: project
src/NumHask/Array.hs view
@@ -10,35 +10,30 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}--- fixme-{-# OPTIONS_GHC -fno-warn-deprecations #-}-{-# LANGUAGE DatatypeContexts #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-} module NumHask.Array where -import Data.Distributive-import Data.Functor.Rep-import Data.Kind+import Data.Distributive (Distributive(..))+import Data.Functor.Rep (Representable(..), liftR2, pureRep, fmapRep) import Data.List ((!!))-import Data.Promotion.Prelude-import Data.Singletons as S-import Data.Singletons.TypeLits as S-import GHC.Exts-import GHC.Show-import NumHask.Array.Constraints+import GHC.Exts (IsList(..))+import GHC.Show (Show(..))+import NumHask.Error (impossible)+import NumHask.Array.Constraints (Fold, HeadModule, TailModule, IsValidConcat, Concatenate, Transpose, Squeeze) import NumHask.Prelude as P-import NumHask.Shape+import NumHask.Shape (HasShape(..)) import Numeric.Dimensions as D-import Numeric.Dimensions.XDim import qualified Data.Singletons.Prelude as S import qualified Data.Vector as V-import qualified Protolude as Proto import qualified Test.QuickCheck as QC -- $setup@@ -60,7 +55,7 @@ data family Array (c :: Type -> Type) (ds :: [k]) (a :: Type) -- | instance where dimensions are known at compile time-newtype instance (Dimensions ds) =>+newtype instance Array c (ds :: [Nat]) t = Array { _getContainer :: c t} deriving (Functor, Foldable)@@ -126,9 +121,6 @@ instance (Eq (c t), Dimensions ds) => Eq (Array c ds t) where (Array a) == (Array b) = a == b -xdimList :: XDim ds -> [Int]-xdimList (XDim d) = dimList d- dimList :: Dim ds -> [Int] dimList D = [] dimList (d :* ds) = dimList d ++ dimList ds@@ -235,7 +227,6 @@ , AdditiveUnital (Vector c n a) , QC.Arbitrary a , AdditiveUnital a- , Num a ) => QC.Arbitrary (Vector c n a) where arbitrary = QC.frequency [(1, pure zero), (9, fromList <$> QC.vector n)]@@ -250,7 +241,6 @@ , KnownNat n , QC.Arbitrary a , AdditiveUnital a- , Num a ) => QC.Arbitrary (Matrix c m n a) where arbitrary = QC.frequency [(1, pure zero), (9, fromList <$> QC.vector (m * n))]@@ -303,21 +293,19 @@ , Dimensions '[ k, n] , Dimensions '[ m, n] , Container c- , KnownNat m- , KnownNat n- , KnownNat k ) => Matrix c m k a -> Matrix c k n a -> Matrix c m n a-mmult x y = tabulate (\[i, j] -> unsafeRow i x <.> unsafeCol j y)+mmult x y = tabulate go+ where+ go [i, j] = unsafeRow i x <.> unsafeCol j y+ go _ = impossible "mmult only typechecks on arrays" -- | extract the row of a matrix row :: forall c i a m n. ( Dimensions '[ m, n] , Container c- , KnownNat m- , KnownNat n , KnownNat i , ((S.<) i m) ~ 'True )@@ -326,8 +314,17 @@ -> Vector c n a row i_ = unsafeRow i where- i = (Proto.fromIntegral . S.fromSing . S.singByProxy) i_+ i = (fromIntegral . S.fromSing . S.singByProxy) i_ +rank2Shape+ :: Dimensions '[ m, n]+ => Matrix c m n a+ -> (Int, Int)+rank2Shape t =+ case shape t of+ [m, n] -> (m, n)+ _ -> impossible "only typechecks for matricies"+ unsafeRow :: forall c a m n. ( Container c , Dimensions '[ m, n])@@ -336,14 +333,12 @@ -> Vector c n a unsafeRow i t@(Array a) = Array $ cslice (i * n) n a where- [_, n] = shape t+ (_, n) = rank2Shape t -- | extract the column of a matrix col :: forall c j a m n. ( Dimensions '[ m, n] , Container c- , KnownNat m- , KnownNat n , KnownNat j , ((S.<) j n) ~ 'True )@@ -352,7 +347,7 @@ -> Vector c m a col j_ = unsafeCol j where- j = (Proto.fromIntegral . S.fromSing . S.singByProxy) j_+ j = (fromIntegral . S.fromSing . S.singByProxy) j_ unsafeCol :: forall c a m n. (Container c, Dimensions '[ m, n])@@ -361,7 +356,7 @@ -> Vector c m a unsafeCol j t@(Array a) = Array $ generate m (\x -> a `idx` (j + x * n)) where- [m, n] = shape t+ (m, n) = rank2Shape t -- | --@@ -382,20 +377,6 @@ -> Array c r0 a unsafeSlice s t = Array (fromList [unsafeIndex t i | i <- sequence s]) --- | Slice xs = Map Length xs-type family Slice (xss :: [[Nat]]) :: [Nat] where- Slice xss = Data.Promotion.Prelude.Map LengthSym0 xss---- | AllLT xs n = All (n >) xs-data AllLTSym0 (a :: S.TyFun [Nat] (S.TyFun Nat Bool -> Type))--data AllLTSym1 (l :: [Nat]) (a :: S.TyFun Nat Bool)--type instance S.Apply AllLTSym0 l = AllLTSym1 l--type instance S.Apply (AllLTSym1 l) n =- Data.Promotion.Prelude.All ((S.>@#@$$) n) l- -- | -- -- todo: an ambiguous type variable has snuck in here somewhere@@ -425,7 +406,7 @@ -} slice s_ = unsafeSlice s where- s = ((fmap . fmap) fromInteger . fromSing . singByProxy) s_+ s = ((fmap . fmap) fromInteger . S.fromSing . S.singByProxy) s_ -- | --@@ -443,7 +424,7 @@ , KnownNat s , Dimensions uvw , uw ~ (Fold s uvw)- , w ~ (Data.Promotion.Prelude.Drop 1 vw)+ , w ~ (S.Drop 1 vw) , vw ~ (TailModule s uvw) ) => Proxy s@@ -460,7 +441,7 @@ [] md) where- s = (Proto.fromIntegral . fromSing . singByProxy) s_+ s = (fromIntegral . S.fromSing . S.singByProxy) s_ md = chunkItUp [] (product $ drop s $ shape a) v -- |@@ -492,7 +473,7 @@ [] md) where- s = (Proto.fromIntegral . fromSing . singByProxy) s_+ s = (fromIntegral . S.fromSing . S.singByProxy) s_ md = chunkItUp [] (product $ drop s $ shape a) v -- |@@ -508,7 +489,7 @@ concatenate :: forall c s r t a. ( Container c- , SingI s+ , S.SingI s , Dimensions r , Dimensions t , (IsValidConcat s t r) ~ 'True@@ -520,7 +501,7 @@ concatenate s_ r@(Array vr) t@(Array vt) = Array . cconcat $ (concat . reverse . P.transpose) [rm, tm] where- s = (Proto.fromIntegral . fromSing . singByProxy) s_+ s = (fromIntegral . S.fromSing . S.singByProxy) s_ rm = chunkItUp [] (product $ drop s $ shape t) vt tm = chunkItUp [] (product $ drop s $ shape r) vr @@ -644,32 +625,41 @@ instance (Dimensions r, Container c, CRing a) => CRing (Array c r a) +instance (Dimensions r, Container c, Semifield a) => Semifield (Array c r a)+ instance (Dimensions r, Container c, Field a) => Field (Array c r a) instance (Dimensions r, Container c, ExpField a) => ExpField (Array c r a) where exp = fmapRep exp log = fmapRep log -instance (Foldable (Array c r), Dimensions r, Container c, BoundedField a) =>- BoundedField (Array c r a) where+instance (Foldable (Array c r), Dimensions r, Container c, UpperBoundedField a) =>+ UpperBoundedField (Array c r a) where isNaN f = or (fmapRep isNaN f) +instance (Foldable (Array c r), Dimensions r, Container c, LowerBoundedField a) =>+ LowerBoundedField (Array c r a)+ instance (Dimensions r, Container c, Signed a) => Signed (Array c r a) where sign = fmapRep sign abs = fmapRep abs -instance (Functor (Array c r), Foldable (Array c r), ExpField a) =>+instance (Functor (Array c r), Foldable (Array c r), Normed a a, ExpField a) => Normed (Array c r a) a where- size r = sqrt $ foldr (+) zero $ (** (one + one)) <$> r+ normL1 r = foldr (+) zero $ normL1 <$> r+ normL2 r = sqrt $ foldr (+) zero $ (** (one + one)) <$> r+ normLp p r = (** (one / p)) $ foldr (+) zero $ (** p) . normL1 <$> r -instance (Foldable (Array c r), Dimensions r, Container c, Epsilon a) =>+instance (Eq (c a), Foldable (Array c r), Dimensions r, Container c, Epsilon a) => Epsilon (Array c r a) where nearZero f = and (fmapRep nearZero f) aboutEqual a b = and (liftR2 aboutEqual a b) -instance (Foldable (Array c r), Dimensions r, Container c, ExpField a) =>+instance (Foldable (Array c r), Dimensions r, Container c, ExpField a, Normed a a) => Metric (Array c r a) a where- distance a b = size (a - b)+ distanceL1 a b = normL1 (a - b)+ distanceL2 a b = normL2 (a - b)+ distanceLp p a b = normLp p (a - b) instance (Dimensions r, Container c, Integral a) => Integral (Array c r a) where divMod a b = (d, m)@@ -677,6 +667,11 @@ x = liftR2 divMod a b d = fmap fst x m = fmap snd x+ quotRem a b = (q, r)+ where+ x = liftR2 quotRem a b+ q = fmap fst x+ r = fmap snd x instance (Foldable (Array c r), CRing a, Semiring a, Dimensions r, Container c) => Hilbert (Array c r) a where@@ -698,23 +693,23 @@ MultiplicativeGroupBasis (Array c r) a where (./.) = liftR2 (/) -instance (Dimensions r, Container c, Additive a) =>- AdditiveModule (Array c r) a where+instance (Container c, Additive a) =>+ AdditiveModule (Array c (r::[Nat])) a where (.+) r s = fmap (s +) r (+.) s = fmap (s +) -instance (Dimensions r, Container c, AdditiveGroup a) =>- AdditiveGroupModule (Array c r) a where+instance (Container c, AdditiveGroup a) =>+ AdditiveGroupModule (Array c (r::[Nat])) a where (.-) r s = fmap (\x -> x - s) r (-.) s = fmap (\x -> x - s) -instance (Dimensions r, Container c, Multiplicative a) =>- MultiplicativeModule (Array c r) a where+instance (Container c, Multiplicative a) =>+ MultiplicativeModule (Array c (r :: [Nat])) a where (.*) r s = fmap (s *) r (*.) s = fmap (s *) -instance (Dimensions r, Container c, MultiplicativeGroup a) =>- MultiplicativeGroupModule (Array c r) a where+instance (Container c, MultiplicativeGroup a) =>+ MultiplicativeGroupModule (Array c (r::[Nat])) a where (./) r s = fmap (/ s) r (/.) s = fmap (/ s)
stack.yaml view
@@ -1,4 +1,4 @@-resolver: nightly-2018-04-04+resolver: nightly-2018-05-06 packages: - .
test/test.hs view
@@ -91,12 +91,14 @@ testGroup "Vector 6 Float" [ testGroup "MultiplicativeGroup" $- testLawOf ([] :: [Vector [] 6 Float]) <$> multiplicativeGroupLaws+ testLawOf ([] :: [Vector [] 6 Float]) <$> multiplicativeGroupLaws_ , testGroup "Signed" $ testLawOf ([] :: [Vector [] 6 Float]) <$> signedLaws+ , testGroup "Normed" $+ testLawOf2 ([] :: [(Vector [] 6 Float, Float)]) <$> normedLaws , testGroup "Metric" $- testLawOf ([] :: [Vector [] 6 Float]) <$> metricNaperianFloatLaws+ testLawOf2 ([] :: [(Vector [] 6 Float, Float)]) <$> metricRationalLaws , testGroup "Exponential Field" $- testLawOf ([] :: [Vector [] 6 Float]) <$> expFieldNaperianLaws+ testLawOf ([] :: [Vector [] 6 Float]) <$> expFieldContainerLaws , testGroup "Multiplicative Group Module" $ localOption (QuickCheckTests 1000) . testLawOf2 ([] :: [(Vector [] 6 Float, Float)]) <$>