From baf992ef518bb97d9e5d97c7ac76b96b96e67dc3 Mon Sep 17 00:00:00 2001 From: Mikolaj Konarski Date: Tue, 28 Jan 2025 17:08:51 +0100 Subject: [PATCH] Rename Adaptor classes and methods --- bench/common/BenchMnistTools.hs | 20 +-- bench/common/BenchProdTools.hs | 8 +- src/HordeAd/Core/Adaptor.hs | 278 +++++++++++++++--------------- src/HordeAd/Core/Engine.hs | 72 ++++---- test/common/TestMnistCNN.hs | 8 +- test/common/TestMnistFCNN.hs | 4 +- test/simplified/TestMnistCNNR.hs | 24 +-- test/simplified/TestMnistFCNNR.hs | 60 +++---- test/simplified/TestMnistRNNR.hs | 22 +-- test/simplified/TestMnistRNNS.hs | 22 +-- test/tool/CrossTesting.hs | 18 +- 11 files changed, 268 insertions(+), 268 deletions(-) diff --git a/bench/common/BenchMnistTools.hs b/bench/common/BenchMnistTools.hs index 783e5a988..fd5f2ab81 100644 --- a/bench/common/BenchMnistTools.hs +++ b/bench/common/BenchMnistTools.hs @@ -61,7 +61,7 @@ mnistTrainBench1VTA extraPrefix chunkLength xs widthHidden widthHidden2 MnistFcnnRanked1.afcnnMnistLoss1 widthHidden widthHidden2 mnist (unAsHVector - $ parseHVector (AsHVector $ fromDValue valsInit) adinputs) + $ fromTarget (AsHVector $ fromDValue valsInit) adinputs) chunk = take chunkLength xs grad c = tunvector $ fst $ sgd gamma f c (dmkHVector hVectorInit) name = extraPrefix @@ -153,8 +153,8 @@ mnistTrainBench1VTO extraPrefix chunkLength testData widthHidden widthHidden2 (glyphR, labelR) pars g :: AstTensor AstMethodLet FullSpan TKUntyped -> AstTensor AstMethodLet FullSpan TKUntyped - g !hv = toHVectorOf $ AsHVector $ f - $ unAsHVector $ parseHVector (AsHVector $ fromValue (valsInit, dataInit)) hv + g !hv = toTarget $ AsHVector $ f + $ unAsHVector $ fromTarget (AsHVector $ fromValue (valsInit, dataInit)) hv (artRaw, _) = revProduceArtifact False g emptyEnv (FTKUntyped $ voidFromHVector $ hVectorInit @@ -224,18 +224,18 @@ mnistTrainBench2VTA extraPrefix chunkLength testData widthHidden widthHidden2 case someNatVal $ toInteger widthHidden2 of Just (SomeNat @widthHidden2 _) -> forgetShape $ fst - $ randomVals + $ randomValue @(MnistFcnnRanked2.ADFcnnMnist2ParametersShaped RepN widthHidden widthHidden2 r) 1 (mkStdGen 44) Nothing -> error "valsInit: impossible someNatVal error" Nothing -> error "valsInit: impossible someNatVal error" - hVectorInit = dunHVector $ toHVectorOf $ AsHVector valsInit + hVectorInit = dunHVector $ toTarget $ AsHVector valsInit f :: MnistData r -> ADVal RepN TKUntyped -> ADVal target (TKR 0 r) f mnist adinputs = MnistFcnnRanked2.afcnnMnistLoss2 - mnist (unAsHVector $ parseHVector (AsHVector $ fromDValue valsInit) adinputs) + mnist (unAsHVector $ fromTarget (AsHVector $ fromDValue valsInit) adinputs) chunk = take chunkLength testData grad c = tunvector $ fst $ sgd gamma f c (dmkHVector hVectorInit) name = extraPrefix @@ -254,13 +254,13 @@ mnistTestBench2VTA extraPrefix chunkLength testData widthHidden widthHidden2 = d case someNatVal $ toInteger widthHidden2 of Just (SomeNat @widthHidden2 _) -> forgetShape $ fst - $ randomVals + $ randomValue @(MnistFcnnRanked2.ADFcnnMnist2ParametersShaped RepN widthHidden widthHidden2 r) 1 (mkStdGen 44) Nothing -> error "valsInit: impossible someNatVal error" Nothing -> error "valsInit: impossible someNatVal error" - hVectorInit = dunHVector $ toHVectorOf $ AsHVector valsInit + hVectorInit = dunHVector $ toTarget $ AsHVector valsInit ftest :: [MnistData r] -> HVector RepN -> r ftest = MnistFcnnRanked2.afcnnMnistTest2 valsInit chunk = take chunkLength testData @@ -311,13 +311,13 @@ mnistTrainBench2VTO extraPrefix chunkLength testData widthHidden widthHidden2 case someNatVal $ toInteger widthHidden2 of Just (SomeNat @widthHidden2 _) -> forgetShape $ fst - $ randomVals + $ randomValue @(MnistFcnnRanked2.ADFcnnMnist2ParametersShaped RepN widthHidden widthHidden2 r) 1 (mkStdGen 44) Nothing -> error "valsInit: impossible someNatVal error" Nothing -> error "valsInit: impossible someNatVal error" - hVectorInit = dunHVector $ toHVectorOf $ AsHVector valsInit + hVectorInit = dunHVector $ toTarget $ AsHVector valsInit name = extraPrefix ++ unwords [ "v0 m" ++ show (V.length hVectorInit) , " =" ++ show (sizeHVector hVectorInit) ] diff --git a/bench/common/BenchProdTools.hs b/bench/common/BenchProdTools.hs index c51d582c7..7b5fc96f6 100644 --- a/bench/common/BenchProdTools.hs +++ b/bench/common/BenchProdTools.hs @@ -162,10 +162,10 @@ _rankedNoShareVecProd = V.foldl1' multNotShared -- to the existential variables in AstRanked that show up, e.g., when -- pattern matching on that type, dictionaries seen in the datatype -- constructors. -inspect $ hasNoTypeClassesExcept 'crevRankedListProd [''GoodScalar, ''KnownNat, ''KnownShS, ''AstSpan, ''Show, ''Ord, ''Numeric, ''Num, ''RowSum, ''Typeable, ''IfDifferentiable, ''NFData, ''OD.Storable, ''AdaptableHVector, ''OS.Vector] -inspect $ hasNoTypeClassesExcept 'revRankedListProd [''GoodScalar, ''KnownNat, ''KnownShS, ''AstSpan, ''Show, ''Ord, ''Numeric, ''Num, ''RowSum, ''Typeable, ''IfDifferentiable, ''NFData, ''(~), ''PermC, ''OD.Storable, ''AdaptableHVector, ''OS.Vector] -inspect $ hasNoTypeClassesExcept 'crevRankedListProdr [''GoodScalar, ''KnownNat, ''KnownShS, ''AstSpan, ''Show, ''Ord, ''Numeric, ''Num, ''RowSum, ''Typeable, ''IfDifferentiable, ''NFData, ''OD.Storable, ''AdaptableHVector, ''OS.Vector] -inspect $ hasNoTypeClassesExcept 'revRankedListProdr [''GoodScalar, ''KnownNat, ''KnownShS, ''AstSpan, ''Show, ''Ord, ''Numeric, ''Num, ''RowSum, ''Typeable, ''IfDifferentiable, ''NFData, ''(~), ''PermC, ''OD.Storable, ''AdaptableHVector, ''OS.Vector] +inspect $ hasNoTypeClassesExcept 'crevRankedListProd [''GoodScalar, ''KnownNat, ''KnownShS, ''AstSpan, ''Show, ''Ord, ''Numeric, ''Num, ''RowSum, ''Typeable, ''IfDifferentiable, ''NFData, ''OD.Storable, ''AdaptableTarget, ''OS.Vector] +inspect $ hasNoTypeClassesExcept 'revRankedListProd [''GoodScalar, ''KnownNat, ''KnownShS, ''AstSpan, ''Show, ''Ord, ''Numeric, ''Num, ''RowSum, ''Typeable, ''IfDifferentiable, ''NFData, ''(~), ''PermC, ''OD.Storable, ''AdaptableTarget, ''OS.Vector] +inspect $ hasNoTypeClassesExcept 'crevRankedListProdr [''GoodScalar, ''KnownNat, ''KnownShS, ''AstSpan, ''Show, ''Ord, ''Numeric, ''Num, ''RowSum, ''Typeable, ''IfDifferentiable, ''NFData, ''OD.Storable, ''AdaptableTarget, ''OS.Vector] +inspect $ hasNoTypeClassesExcept 'revRankedListProdr [''GoodScalar, ''KnownNat, ''KnownShS, ''AstSpan, ''Show, ''Ord, ''Numeric, ''Num, ''RowSum, ''Typeable, ''IfDifferentiable, ''NFData, ''(~), ''PermC, ''OD.Storable, ''AdaptableTarget, ''OS.Vector] -- OD.Storable is needed, for 9.4, only until new orthotope is released -} diff --git a/src/HordeAd/Core/Adaptor.hs b/src/HordeAd/Core/Adaptor.hs index 6f332468a..8367a0580 100644 --- a/src/HordeAd/Core/Adaptor.hs +++ b/src/HordeAd/Core/Adaptor.hs @@ -11,8 +11,8 @@ -- derivative functions and also to handle multiple arguments -- and results of fold-like operations. module HordeAd.Core.Adaptor - ( AdaptableHVector(..), TermValue(..), DualNumberValue(..) - , ForgetShape(..), RandomHVector(..) + ( AdaptableTarget(..), TermValue(..), DualNumberValue(..) + , ForgetShape(..), RandomValue(..) , stkOfListR ) where @@ -38,16 +38,16 @@ import HordeAd.Core.Types -- * Adaptor classes -- Inspired by adaptors from @tomjaguarpaw's branch. -class AdaptableHVector (target :: Target) vals where +class AdaptableTarget (target :: Target) vals where type X vals :: TensorKindType - toHVectorOf :: vals -> target (X vals) + toTarget :: vals -> target (X vals) -- ^ represent a collection of tensors - parseHVector :: target (X vals) -> vals + fromTarget :: target (X vals) -> vals -- ^ recovers a collection of tensors from its canonical representation, -- using the general shape recorded in another collection of the same type; -- the remaining data may be used in a another structurally recursive -- call working on the same data to build a larger compound collection - parseHVectorAD :: target (ADTensorKind (X vals)) -> vals + fromTargetAD :: target (ADTensorKind (X vals)) -> vals class TermValue vals where type Value vals = result | result -> vals @@ -72,33 +72,33 @@ class ForgetShape vals where forgetShape :: vals -> NoShape vals -- | A helper class for randomly generating initial parameters. -class RandomHVector vals where - randomVals :: SplitGen g => Double -> g -> (vals, g) +class RandomValue vals where + randomValue :: SplitGen g => Double -> g -> (vals, g) --- * Basic Adaptor class instances +-- * Base instances instance (TensorKind y, BaseTensor target) - => AdaptableHVector target (target y) where + => AdaptableTarget target (target y) where {- {-# SPECIALIZE instance (KnownNat n, AstSpan s) - => AdaptableHVector (AstTensor AstMethodLet s) (AstTensor AstMethodLet s (TKR n Double)) #-} + => AdaptableTarget (AstTensor AstMethodLet s) (AstTensor AstMethodLet s (TKR n Double)) #-} TODO: RULE left-hand side too complicated to desugar in GHC 9.6.4 with -O0, but not -O1 {-# SPECIALIZE instance (KnownNat n, ADReadyNoLet Nested.Ranked) - => AdaptableHVector (ADVal Nested.Ranked) + => AdaptableTarget (ADVal Nested.Ranked) (ADVal Nested.Ranked Double n) #-} {-# SPECIALIZE instance (KnownNat n, ADReadyNoLet (AstRanked PrimalSpan)) - => AdaptableHVector (ADVal (AstRanked PrimalSpan)) + => AdaptableTarget (ADVal (AstRanked PrimalSpan)) (ADVal (AstRanked PrimalSpan) Double n) #-} -} type X (target y) = y - toHVectorOf = id - parseHVector t = t - parseHVectorAD t = fromADTensorKindShared (stensorKind @y) t + toTarget = id + fromTarget t = t + fromTargetAD t = fromADTensorKindShared (stensorKind @y) t instance (BaseTensor target, BaseTensor (PrimalOf target), TensorKind y) => DualNumberValue (target y) where @@ -121,8 +121,8 @@ instance ForgetShape (target (TKX sh r)) where instance ( KnownShS sh, GoodScalar r, Fractional r, Random r , BaseTensor target ) - => RandomHVector (target (TKS sh r)) where - randomVals @g range g = + => RandomValue (target (TKS sh r)) where + randomValue @g range g = let createRandomVector :: Int -> g -> target (TKS sh r) createRandomVector n seed = srepl (2 * realToFrac range) @@ -148,19 +148,19 @@ stkOfListR stk SNat = gcastWith (unsafeCoerceRefl :: Tups n t :~: TKProduct t (Tups (n - 1) t)) $ STKProduct stk (stkOfListR stk (SNat @(n - 1))) -instance ( BaseTensor target, KnownNat n, AdaptableHVector target a +instance ( BaseTensor target, KnownNat n, AdaptableTarget target a , TensorKind (X a), TensorKind (ADTensorKind (X a)) ) - => AdaptableHVector target (ListR n a) where + => AdaptableTarget target (ListR n a) where type X (ListR n a) = Tups n (X a) - toHVectorOf ZR = tunit - toHVectorOf ((:::) @n1 a rest) + toTarget ZR = tunit + toTarget ((:::) @n1 a rest) | Dict <- lemTensorKindOfSTK (stkOfListR (stensorKind @(X a)) (SNat @n1)) = gcastWith (unsafeCoerceRefl :: X (ListR n a) :~: TKProduct (X a) (X (ListR n1 a))) $ - let a1 = toHVectorOf a - rest1 = toHVectorOf rest + let a1 = toTarget a + rest1 = toTarget rest in tpair a1 rest1 - parseHVector tups = case SNat @n of + fromTarget tups = case SNat @n of SNat' @0 -> ZR _ -> gcastWith (unsafeCoerceRefl :: (1 <=? n) :~: True) $ @@ -168,10 +168,10 @@ instance ( BaseTensor target, KnownNat n, AdaptableHVector target a :: X (ListR n a) :~: TKProduct (X a) (X (ListR (n - 1) a))) $ withTensorKind (stkOfListR (stensorKind @(X a)) (SNat @(n - 1))) $ let (a1, rest1) = (tproject1 tups, tproject2 tups) - a = parseHVector a1 - rest = parseHVector rest1 + a = fromTarget a1 + rest = fromTarget rest1 in (a ::: rest) - parseHVectorAD tups = case SNat @n of + fromTargetAD tups = case SNat @n of SNat' @0 -> ZR _ -> gcastWith (unsafeCoerceRefl :: (1 <=? n) :~: True) $ @@ -183,8 +183,8 @@ instance ( BaseTensor target, KnownNat n, AdaptableHVector target a withTensorKind (stkOfListR (stensorKind @(ADTensorKind (X a))) (SNat @(n - 1))) $ let (a1, rest1) = (tproject1 tups, tproject2 tups) - a = parseHVectorAD a1 - rest = parseHVectorAD @_ @(ListR (n - 1) a) rest1 + a = fromTargetAD a1 + rest = fromTargetAD @_ @(ListR (n - 1) a) rest1 in (a ::: rest) instance TermValue a => TermValue (ListR n a) where @@ -202,37 +202,37 @@ instance ForgetShape a => ForgetShape (ListR n a) where forgetShape ZR = ZR forgetShape (a ::: rest) = forgetShape a ::: forgetShape rest -instance (RandomHVector a, KnownNat n) => RandomHVector (ListR n a) where - randomVals range g = case cmpNat (Proxy @n) (Proxy @0) of - LTI -> error "randomVals: impossible" +instance (RandomValue a, KnownNat n) => RandomValue (ListR n a) where + randomValue range g = case cmpNat (Proxy @n) (Proxy @0) of + LTI -> error "randomValue: impossible" EQI -> (ZR, g) GTI -> gcastWith (unsafeCoerceRefl :: (1 <=? n) :~: True) $ - let (v, g1) = randomVals range g - (rest, g2) = randomVals @(ListR (n - 1) a) range g1 + let (v, g1) = randomValue range g + (rest, g2) = randomValue @(ListR (n - 1) a) range g1 in (v ::: rest, g2) instance ( BaseTensor target - , AdaptableHVector target a, TensorKind (X a), TensorKind (ADTensorKind (X a)) - , AdaptableHVector target b, TensorKind (X b), TensorKind (ADTensorKind (X b)) ) - => AdaptableHVector target (a, b) where + , AdaptableTarget target a, TensorKind (X a), TensorKind (ADTensorKind (X a)) + , AdaptableTarget target b, TensorKind (X b), TensorKind (ADTensorKind (X b)) ) + => AdaptableTarget target (a, b) where type X (a, b) = TKProduct (X a) (X b) - toHVectorOf (a, b) = - let a1 = toHVectorOf a - b1 = toHVectorOf b + toTarget (a, b) = + let a1 = toTarget a + b1 = toTarget b in tpair a1 b1 - parseHVector ab = + fromTarget ab = let (a1, b1) = ( tproject1 ab , tproject2 ab ) - a = parseHVector a1 - b = parseHVector b1 + a = fromTarget a1 + b = fromTarget b1 in (a, b) - parseHVectorAD ab = + fromTargetAD ab = let (a1, b1) = ( tproject1 ab , tproject2 ab ) - a = parseHVectorAD a1 - b = parseHVectorAD b1 + a = fromTargetAD a1 + b = fromTargetAD b1 in (a, b) instance (TermValue a, TermValue b) => TermValue (a, b) where @@ -248,41 +248,41 @@ instance ( ForgetShape a type NoShape (a, b) = (NoShape a, NoShape b) forgetShape (a, b) = (forgetShape a, forgetShape b) -instance ( RandomHVector a - , RandomHVector b ) => RandomHVector (a, b) where - randomVals range g = - let (v1, g1) = randomVals range g - (v2, g2) = randomVals range g1 +instance ( RandomValue a + , RandomValue b ) => RandomValue (a, b) where + randomValue range g = + let (v1, g1) = randomValue range g + (v2, g2) = randomValue range g1 in ((v1, v2), g2) instance ( BaseTensor target - , AdaptableHVector target a, TensorKind (X a), TensorKind (ADTensorKind (X a)) - , AdaptableHVector target b, TensorKind (X b), TensorKind (ADTensorKind (X b)) - , AdaptableHVector target c, TensorKind (X c), TensorKind (ADTensorKind (X c)) ) - => AdaptableHVector target (a, b, c) where + , AdaptableTarget target a, TensorKind (X a), TensorKind (ADTensorKind (X a)) + , AdaptableTarget target b, TensorKind (X b), TensorKind (ADTensorKind (X b)) + , AdaptableTarget target c, TensorKind (X c), TensorKind (ADTensorKind (X c)) ) + => AdaptableTarget target (a, b, c) where type X (a, b, c) = TKProduct (TKProduct (X a) (X b)) (X c) - toHVectorOf (a, b, c) = - let a1 = toHVectorOf a - b1 = toHVectorOf b - c1 = toHVectorOf c + toTarget (a, b, c) = + let a1 = toTarget a + b1 = toTarget b + c1 = toTarget c in tpair (tpair a1 b1) c1 - parseHVector abc = + fromTarget abc = let (a1, b1, c1) = ( tproject1 (tproject1 abc) , tproject2 (tproject1 abc) , tproject2 abc ) - a = parseHVector a1 - b = parseHVector b1 - c = parseHVector c1 + a = fromTarget a1 + b = fromTarget b1 + c = fromTarget c1 in (a, b, c) - parseHVectorAD abc = + fromTargetAD abc = let (a1, b1, c1) = ( tproject1 (tproject1 abc) , tproject2 (tproject1 abc) , tproject2 abc ) - a = parseHVectorAD a1 - b = parseHVectorAD b1 - c = parseHVectorAD c1 + a = fromTargetAD a1 + b = fromTargetAD b1 + c = fromTargetAD c1 in (a, b, c) instance (TermValue a, TermValue b, TermValue c) @@ -301,50 +301,50 @@ instance ( ForgetShape a type NoShape (a, b, c) = (NoShape a, NoShape b, NoShape c) forgetShape (a, b, c) = (forgetShape a, forgetShape b, forgetShape c) -instance ( RandomHVector a - , RandomHVector b - , RandomHVector c ) => RandomHVector (a, b, c) where - randomVals range g = - let (v1, g1) = randomVals range g - (v2, g2) = randomVals range g1 - (v3, g3) = randomVals range g2 +instance ( RandomValue a + , RandomValue b + , RandomValue c ) => RandomValue (a, b, c) where + randomValue range g = + let (v1, g1) = randomValue range g + (v2, g2) = randomValue range g1 + (v3, g3) = randomValue range g2 in ((v1, v2, v3), g3) instance ( BaseTensor target - , AdaptableHVector target a, TensorKind (X a), TensorKind (ADTensorKind (X a)) - , AdaptableHVector target b, TensorKind (X b), TensorKind (ADTensorKind (X b)) - , AdaptableHVector target c, TensorKind (X c), TensorKind (ADTensorKind (X c)) - , AdaptableHVector target d, TensorKind (X d), TensorKind (ADTensorKind (X d)) ) - => AdaptableHVector target (a, b, c, d) where + , AdaptableTarget target a, TensorKind (X a), TensorKind (ADTensorKind (X a)) + , AdaptableTarget target b, TensorKind (X b), TensorKind (ADTensorKind (X b)) + , AdaptableTarget target c, TensorKind (X c), TensorKind (ADTensorKind (X c)) + , AdaptableTarget target d, TensorKind (X d), TensorKind (ADTensorKind (X d)) ) + => AdaptableTarget target (a, b, c, d) where type X (a, b, c, d) = TKProduct (TKProduct (X a) (X b)) (TKProduct (X c) (X d)) - toHVectorOf (a, b, c, d) = - let a1 = toHVectorOf a - b1 = toHVectorOf b - c1 = toHVectorOf c - d1 = toHVectorOf d + toTarget (a, b, c, d) = + let a1 = toTarget a + b1 = toTarget b + c1 = toTarget c + d1 = toTarget d in tpair (tpair a1 b1) (tpair c1 d1) - parseHVector abcd = + fromTarget abcd = let (a1, b1, c1, d1) = ( tproject1 (tproject1 abcd) , tproject2 (tproject1 abcd) , tproject1 (tproject2 abcd) , tproject2 (tproject2 abcd) ) - a = parseHVector a1 - b = parseHVector b1 - c = parseHVector c1 - d = parseHVector d1 + a = fromTarget a1 + b = fromTarget b1 + c = fromTarget c1 + d = fromTarget d1 in (a, b, c, d) - parseHVectorAD abcd = + fromTargetAD abcd = let (a1, b1, c1, d1) = ( tproject1 (tproject1 abcd) , tproject2 (tproject1 abcd) , tproject1 (tproject2 abcd) , tproject2 (tproject2 abcd) ) - a = parseHVectorAD a1 - b = parseHVectorAD b1 - c = parseHVectorAD c1 - d = parseHVectorAD d1 + a = fromTargetAD a1 + b = fromTargetAD b1 + c = fromTargetAD c1 + d = fromTargetAD d1 in (a, b, c, d) instance (TermValue a, TermValue b, TermValue c, TermValue d) @@ -369,58 +369,58 @@ instance ( ForgetShape a forgetShape (a, b, c, d) = (forgetShape a, forgetShape b, forgetShape c, forgetShape d) -instance ( RandomHVector a - , RandomHVector b - , RandomHVector c - , RandomHVector d ) => RandomHVector (a, b, c, d) where - randomVals range g = - let (v1, g1) = randomVals range g - (v2, g2) = randomVals range g1 - (v3, g3) = randomVals range g2 - (v4, g4) = randomVals range g3 +instance ( RandomValue a + , RandomValue b + , RandomValue c + , RandomValue d ) => RandomValue (a, b, c, d) where + randomValue range g = + let (v1, g1) = randomValue range g + (v2, g2) = randomValue range g1 + (v3, g3) = randomValue range g2 + (v4, g4) = randomValue range g3 in ((v1, v2, v3, v4), g4) instance ( BaseTensor target - , AdaptableHVector target a, TensorKind (X a), TensorKind (ADTensorKind (X a)) - , AdaptableHVector target b, TensorKind (X b), TensorKind (ADTensorKind (X b)) - , AdaptableHVector target c, TensorKind (X c), TensorKind (ADTensorKind (X c)) - , AdaptableHVector target d, TensorKind (X d), TensorKind (ADTensorKind (X d)) - , AdaptableHVector target e, TensorKind (X e), TensorKind (ADTensorKind (X e)) ) - => AdaptableHVector target (a, b, c, d, e) where + , AdaptableTarget target a, TensorKind (X a), TensorKind (ADTensorKind (X a)) + , AdaptableTarget target b, TensorKind (X b), TensorKind (ADTensorKind (X b)) + , AdaptableTarget target c, TensorKind (X c), TensorKind (ADTensorKind (X c)) + , AdaptableTarget target d, TensorKind (X d), TensorKind (ADTensorKind (X d)) + , AdaptableTarget target e, TensorKind (X e), TensorKind (ADTensorKind (X e)) ) + => AdaptableTarget target (a, b, c, d, e) where type X (a, b, c, d, e) = TKProduct (TKProduct (TKProduct (X a) (X b)) (X c)) (TKProduct (X d) (X e)) - toHVectorOf (a, b, c, d, e) = - let a1 = toHVectorOf a - b1 = toHVectorOf b - c1 = toHVectorOf c - d1 = toHVectorOf d - e1 = toHVectorOf e + toTarget (a, b, c, d, e) = + let a1 = toTarget a + b1 = toTarget b + c1 = toTarget c + d1 = toTarget d + e1 = toTarget e in tpair (tpair (tpair a1 b1) c1) (tpair d1 e1) - parseHVector abcde = + fromTarget abcde = let (a1, b1, c1, d1, e1) = ( tproject1 (tproject1 (tproject1 abcde)) , tproject2 (tproject1 (tproject1 abcde)) , tproject2 (tproject1 abcde) , tproject1 (tproject2 abcde) , tproject2 (tproject2 abcde) ) - a = parseHVector a1 - b = parseHVector b1 - c = parseHVector c1 - d = parseHVector d1 - e = parseHVector e1 + a = fromTarget a1 + b = fromTarget b1 + c = fromTarget c1 + d = fromTarget d1 + e = fromTarget e1 in (a, b, c, d, e) - parseHVectorAD abcde = + fromTargetAD abcde = let (a1, b1, c1, d1, e1) = ( tproject1 (tproject1 (tproject1 abcde)) , tproject2 (tproject1 (tproject1 abcde)) , tproject2 (tproject1 abcde) , tproject1 (tproject2 abcde) , tproject2 (tproject2 abcde) ) - a = parseHVectorAD a1 - b = parseHVectorAD b1 - c = parseHVectorAD c1 - d = parseHVectorAD d1 - e = parseHVectorAD e1 + a = fromTargetAD a1 + b = fromTargetAD b1 + c = fromTargetAD c1 + d = fromTargetAD d1 + e = fromTargetAD e1 in (a, b, c, d, e) instance (TermValue a, TermValue b, TermValue c, TermValue d, TermValue e) @@ -447,15 +447,15 @@ instance ( ForgetShape a forgetShape (a, b, c, d, e) = (forgetShape a, forgetShape b, forgetShape c, forgetShape d, forgetShape e) -instance ( RandomHVector a - , RandomHVector b - , RandomHVector c - , RandomHVector d - , RandomHVector e ) => RandomHVector (a, b, c, d, e) where - randomVals range g = - let (v1, g1) = randomVals range g - (v2, g2) = randomVals range g1 - (v3, g3) = randomVals range g2 - (v4, g4) = randomVals range g3 - (v5, g5) = randomVals range g4 +instance ( RandomValue a + , RandomValue b + , RandomValue c + , RandomValue d + , RandomValue e ) => RandomValue (a, b, c, d, e) where + randomValue range g = + let (v1, g1) = randomValue range g + (v2, g2) = randomValue range g1 + (v3, g3) = randomValue range g2 + (v4, g4) = randomValue range g3 + (v5, g5) = randomValue range g4 in ((v1, v2, v3, v4, v5), g5) diff --git a/src/HordeAd/Core/Engine.hs b/src/HordeAd/Core/Engine.hs index 2e6f37033..a2315bd70 100644 --- a/src/HordeAd/Core/Engine.hs +++ b/src/HordeAd/Core/Engine.hs @@ -61,8 +61,8 @@ import HordeAd.Core.Types rev :: forall astvals z. ( X astvals ~ X (Value astvals), TensorKind (X astvals), TensorKind z - , AdaptableHVector (AstTensor AstMethodLet FullSpan) astvals - , AdaptableHVector RepN (Value astvals) ) + , AdaptableTarget (AstTensor AstMethodLet FullSpan) astvals + , AdaptableTarget RepN (Value astvals) ) => (astvals -> AstTensor AstMethodLet FullSpan z) -> Value astvals -> Value astvals @@ -80,8 +80,8 @@ rev f vals = revDtMaybe f vals Nothing revDt :: forall astvals z. ( X astvals ~ X (Value astvals), TensorKind (X astvals), TensorKind z - , AdaptableHVector (AstTensor AstMethodLet FullSpan) astvals - , AdaptableHVector RepN (Value astvals) ) + , AdaptableTarget (AstTensor AstMethodLet FullSpan) astvals + , AdaptableTarget RepN (Value astvals) ) => (astvals -> AstTensor AstMethodLet FullSpan z) -> Value astvals -> RepN (ADTensorKind z) @@ -92,8 +92,8 @@ revDt f vals dt = revDtMaybe f vals (Just dt) revDtMaybe :: forall astvals z. ( X astvals ~ X (Value astvals), TensorKind (X astvals), TensorKind z - , AdaptableHVector (AstTensor AstMethodLet FullSpan) astvals - , AdaptableHVector RepN (Value astvals) ) + , AdaptableTarget (AstTensor AstMethodLet FullSpan) astvals + , AdaptableTarget RepN (Value astvals) ) => (astvals -> AstTensor AstMethodLet FullSpan z) -> Value astvals -> Maybe (RepN (ADTensorKind z)) @@ -103,16 +103,16 @@ revDtMaybe f vals0 mdt | Dict <- lemTensorKindOfAD (stensorKind @(X astvals)) = let g :: AstTensor AstMethodLet FullSpan (X astvals) -> AstTensor AstMethodLet FullSpan z g !hv = tlet hv $ \ !hvShared -> - f $ parseHVector hvShared - valsH = toHVectorOf vals0 + f $ fromTarget hvShared + valsH = toTarget vals0 voidH = tftk stensorKind valsH artifact = fst $ revProduceArtifact (isJust mdt) g emptyEnv voidH - in parseHVectorAD $ fst $ revEvalArtifact artifact valsH mdt + in fromTargetAD $ fst $ revEvalArtifact artifact valsH mdt {- TODO {-# SPECIALIZE revDtMaybe :: ( KnownNat n - , AdaptableHVector (AstTensor AstMethodLet FullSpan) astvals - , AdaptableHVector RepN (Value astvals) + , AdaptableTarget (AstTensor AstMethodLet FullSpan) astvals + , AdaptableTarget RepN (Value astvals) , TermValue astvals ) => (astvals -> AstTensor AstMethodLet FullSpan n Double) -> Value astvals @@ -123,8 +123,8 @@ revDtMaybe f vals0 mdt | Dict <- lemTensorKindOfAD (stensorKind @(X astvals)) = revArtifactAdapt :: forall astvals z. ( X astvals ~ X (Value astvals), TensorKind (X astvals), TensorKind z - , AdaptableHVector (AstTensor AstMethodLet FullSpan) astvals - , AdaptableHVector RepN (Value astvals) ) + , AdaptableTarget (AstTensor AstMethodLet FullSpan) astvals + , AdaptableTarget RepN (Value astvals) ) => Bool -> (astvals -> AstTensor AstMethodLet FullSpan z) -> Value astvals @@ -133,15 +133,15 @@ revArtifactAdapt hasDt f vals0 = let g :: AstTensor AstMethodLet FullSpan (X astvals) -> AstTensor AstMethodLet FullSpan z g !hv = tlet hv $ \ !hvShared -> - f $ parseHVector hvShared - valsH = toHVectorOf @RepN vals0 + f $ fromTarget hvShared + valsH = toTarget @RepN vals0 voidH = tftk stensorKind valsH in revProduceArtifact hasDt g emptyEnv voidH {- TODO {-# SPECIALIZE revArtifactAdapt :: ( KnownNat n - , AdaptableHVector (AstTensor AstMethodLet FullSpan) astvals - , AdaptableHVector RepN (Value astvals) + , AdaptableTarget (AstTensor AstMethodLet FullSpan) astvals + , AdaptableTarget RepN (Value astvals) , TermValue astvals ) => Bool -> (astvals -> AstTensor AstMethodLet FullSpan n Double) -> Value astvals -> (AstArtifactRev TKUntyped (TKR n Double), Delta (AstRaw PrimalSpan) (TKR n Double)) #-} @@ -205,8 +205,8 @@ fwd :: forall astvals z. ( X astvals ~ X (Value astvals), TensorKind (X astvals) , TensorKind z - , AdaptableHVector (AstTensor AstMethodLet FullSpan) astvals - , AdaptableHVector RepN (Value astvals) ) + , AdaptableTarget (AstTensor AstMethodLet FullSpan) astvals + , AdaptableTarget RepN (Value astvals) ) => (astvals -> AstTensor AstMethodLet FullSpan z) -> Value astvals -> Value astvals -- morally (ADTensorKind astvals) @@ -214,11 +214,11 @@ fwd fwd f vals ds = let g :: AstTensor AstMethodLet FullSpan (X astvals) -> AstTensor AstMethodLet FullSpan z g !hv = tlet hv $ \ !hvShared -> - f $ parseHVector hvShared - valsH = toHVectorOf vals + f $ fromTarget hvShared + valsH = toTarget vals voidH = tftk stensorKind valsH artifact = fst $ fwdProduceArtifact g emptyEnv voidH - dsH = toHVectorOf ds + dsH = toTarget ds in fst $ fwdEvalArtifact @_ @z artifact valsH $ toADTensorKindShared stensorKind dsH @@ -253,8 +253,8 @@ fwdEvalArtifact AstArtifactFwd{..} parameters ds crev :: forall advals z. ( X advals ~ X (DValue advals), TensorKind (X advals), TensorKind z - , AdaptableHVector (ADVal RepN) advals - , AdaptableHVector RepN (DValue advals) ) + , AdaptableTarget (ADVal RepN) advals + , AdaptableTarget RepN (DValue advals) ) => (advals -> ADVal RepN z) -> DValue advals -> DValue advals @@ -265,8 +265,8 @@ crev f vals = crevDtMaybe f vals Nothing crevDt :: forall advals z. ( X advals ~ X (DValue advals), TensorKind (X advals), TensorKind z - , AdaptableHVector (ADVal RepN) advals - , AdaptableHVector RepN (DValue advals) ) + , AdaptableTarget (ADVal RepN) advals + , AdaptableTarget RepN (DValue advals) ) => (advals -> ADVal RepN z) -> DValue advals -> RepN (ADTensorKind z) @@ -277,8 +277,8 @@ crevDt f vals dt = crevDtMaybe f vals (Just dt) crevDtMaybe :: forall advals z. ( X advals ~ X (DValue advals), TensorKind (X advals), TensorKind z - , AdaptableHVector (ADVal RepN) advals - , AdaptableHVector RepN (DValue advals) ) + , AdaptableTarget (ADVal RepN) advals + , AdaptableTarget RepN (DValue advals) ) => (advals -> ADVal RepN z) -> DValue advals -> Maybe (RepN (ADTensorKind z)) @@ -286,9 +286,9 @@ crevDtMaybe {-# INLINE crevDtMaybe #-} crevDtMaybe f vals mdt | Dict <- lemTensorKindOfAD (stensorKind @(X advals)) = let g :: ADVal RepN (X advals) -> ADVal RepN z - g = f . parseHVector - valsH = toHVectorOf vals - in parseHVectorAD $ fst $ crevOnHVector mdt g valsH + g = f . fromTarget + valsH = toTarget vals + in fromTargetAD $ fst $ crevOnHVector mdt g valsH {- {-# SPECIALIZE crevOnHVector @@ -305,17 +305,17 @@ crevDtMaybe f vals mdt | Dict <- lemTensorKindOfAD (stensorKind @(X advals)) = cfwd :: forall advals z. ( X advals ~ X (DValue advals), TensorKind (X advals), TensorKind z - , AdaptableHVector (ADVal RepN) advals - , AdaptableHVector RepN (DValue advals) ) + , AdaptableTarget (ADVal RepN) advals + , AdaptableTarget RepN (DValue advals) ) => (advals -> ADVal RepN z) -> DValue advals -> DValue advals -- morally (ADTensorKind advals) -> RepN (ADTensorKind z) cfwd f vals ds = let g :: ADVal RepN (X advals) -> ADVal RepN z - g = f . parseHVector - valsH = toHVectorOf vals - dsH = toHVectorOf ds + g = f . fromTarget + valsH = toTarget vals + dsH = toTarget ds in fst $ cfwdOnHVector valsH g $ toADTensorKindShared stensorKind dsH diff --git a/test/common/TestMnistCNN.hs b/test/common/TestMnistCNN.hs index 86ebff7f9..3bf678888 100644 --- a/test/common/TestMnistCNN.hs +++ b/test/common/TestMnistCNN.hs @@ -399,8 +399,8 @@ convMnistTestCaseCNNT kheight_minus_1@SNat kwidth_minus_1@SNat valsInit :: Value (ADConvMnistParameters kheight_minus_1 kwidth_minus_1 out_channels n_hidden 'ADModeGradient r) - valsInit = fst $ randomVals range seed - parametersInit = toHVectorOf valsInit + valsInit = fst $ randomValue range seed + parametersInit = toTarget valsInit name = prefix ++ ": " ++ unwords [ show epochs, show maxBatches , show (sNatValue n_hidden :: Int) @@ -470,7 +470,7 @@ convMnistTestCaseCNNT kheight_minus_1@SNat kwidth_minus_1@SNat -- * An old version of the variant of @convMnistCNN@ with shaped tensors -- This one depends on convMnistLenS (flen) for random generation --- of the initial parameters instead of on randomVals. +-- of the initial parameters instead of on randomValue. convMnistTestCaseCNNO :: forall kheight_minus_1 kwidth_minus_1 n_hidden out_channels @@ -799,7 +799,7 @@ comparisonTests volume = let valsInit :: Value (ADConvMnistParameters 4 4 c_out n_hidden 'ADModeGradient r) - valsInit = fst $ randomVals (1 :: Double) (mkStdGen 1) + valsInit = fst $ randomValue (1 :: Double) (mkStdGen 1) in convMnistLossFusedS (SNat @4) (SNat @4) c_out n_hidden diff --git a/test/common/TestMnistFCNN.hs b/test/common/TestMnistFCNN.hs index 94856ac8d..b1a12f6e5 100644 --- a/test/common/TestMnistFCNN.hs +++ b/test/common/TestMnistFCNN.hs @@ -520,8 +520,8 @@ mnistTestCase2S widthHidden@SNat widthHidden2@SNat valsInit :: Value (ADFcnnMnistParameters widthHidden widthHidden2 'ADModeGradient Double) - valsInit = fst $ randomVals range seed - parametersInit = toHVectorOf valsInit + valsInit = fst $ randomValue range seed + parametersInit = toTarget valsInit name = prefix ++ ": " ++ unwords [ show epochs, show maxBatches , show (sNatValue widthHidden :: Int) diff --git a/test/simplified/TestMnistCNNR.hs b/test/simplified/TestMnistCNNR.hs index 9a2188a07..867cdaaa8 100644 --- a/test/simplified/TestMnistCNNR.hs +++ b/test/simplified/TestMnistCNNR.hs @@ -56,12 +56,12 @@ mnistTestCaseCNNA prefix epochs maxBatches khInt kwInt c_outInt n_hiddenInt let valsInit :: MnistCnnRanked2.ADCnnMnistParameters RepN r valsInit = forgetShape $ fst - $ randomVals @(MnistCnnRanked2.ADCnnMnistParametersShaped + $ randomValue @(MnistCnnRanked2.ADCnnMnistParametersShaped RepN SizeMnistHeight SizeMnistWidth kh kw c_out n_hidden r) 0.4 (mkStdGen 44) hVectorInit :: RepN (XParams r) - hVectorInit = toHVectorOf @RepN valsInit + hVectorInit = toTarget @RepN valsInit ftk = tftk @RepN (stensorKind @(XParams r)) hVectorInit name = prefix ++ ": " @@ -75,7 +75,7 @@ mnistTestCaseCNNA prefix epochs maxBatches khInt kwInt c_outInt n_hiddenInt -> r ftest batch_size mnistData pars = MnistCnnRanked2.convMnistTestR - batch_size mnistData (parseHVector @RepN pars) + batch_size mnistData (fromTarget @RepN pars) in testCase name $ do hPutStrLn stderr $ printf "\n%s: Epochs to run/max batches per epoch: %d/%d" @@ -97,7 +97,7 @@ mnistTestCaseCNNA prefix epochs maxBatches khInt kwInt c_outInt n_hiddenInt f (glyphR, labelR) adinputs = MnistCnnRanked2.convMnistLossFusedR miniBatchSize (rconcrete glyphR, rconcrete labelR) - (parseHVector adinputs) + (fromTarget adinputs) chunkR = map packBatchR $ filter (\ch -> length ch == miniBatchSize) $ chunksOf miniBatchSize chunk @@ -166,12 +166,12 @@ mnistTestCaseCNNI prefix epochs maxBatches khInt kwInt c_outInt n_hiddenInt let valsInit :: MnistCnnRanked2.ADCnnMnistParameters RepN r valsInit = forgetShape $ fst - $ randomVals @(MnistCnnRanked2.ADCnnMnistParametersShaped + $ randomValue @(MnistCnnRanked2.ADCnnMnistParametersShaped RepN SizeMnistHeight SizeMnistWidth kh kw c_out n_hidden r) 0.4 (mkStdGen 44) hVectorInit :: RepN (XParams r) - hVectorInit = toHVectorOf @RepN valsInit + hVectorInit = toTarget @RepN valsInit ftk = tftk @RepN (stensorKind @(XParams r)) hVectorInit name = prefix ++ ": " @@ -185,7 +185,7 @@ mnistTestCaseCNNI prefix epochs maxBatches khInt kwInt c_outInt n_hiddenInt -> r ftest batch_size mnistData pars = MnistCnnRanked2.convMnistTestR - batch_size mnistData (parseHVector @RepN pars) + batch_size mnistData (fromTarget @RepN pars) in testCase name $ do hPutStrLn stderr $ printf "\n%s: Epochs to run/max batches per epoch: %d/%d" @@ -205,7 +205,7 @@ mnistTestCaseCNNI prefix epochs maxBatches khInt kwInt c_outInt n_hiddenInt let ast :: AstTensor AstMethodLet FullSpan (TKR 0 r) ast = MnistCnnRanked2.convMnistLossFusedR miniBatchSize (astGlyph, astLabel) - (parseHVector hVector2) + (fromTarget hVector2) runBatch :: ( RepN (XParams r) , StateAdamDeep (XParams r) ) -> (Int, [MnistDataR r]) @@ -289,12 +289,12 @@ mnistTestCaseCNNO prefix epochs maxBatches khInt kwInt c_outInt n_hiddenInt let valsInit :: MnistCnnRanked2.ADCnnMnistParameters RepN r valsInit = forgetShape $ fst - $ randomVals @(MnistCnnRanked2.ADCnnMnistParametersShaped + $ randomValue @(MnistCnnRanked2.ADCnnMnistParametersShaped RepN SizeMnistHeight SizeMnistWidth kh kw c_out n_hidden r) 0.4 (mkStdGen 44) hVectorInit :: RepN (XParams r) - hVectorInit = toHVectorOf @RepN valsInit + hVectorInit = toTarget @RepN valsInit ftk = tftk @RepN (stensorKind @(XParams r)) hVectorInit name = prefix ++ ": " @@ -307,7 +307,7 @@ mnistTestCaseCNNO prefix epochs maxBatches khInt kwInt c_outInt n_hiddenInt -> r ftest batch_size mnistData pars = MnistCnnRanked2.convMnistTestR - batch_size mnistData (parseHVector @RepN pars) + batch_size mnistData (fromTarget @RepN pars) in testCase name $ do hPutStrLn stderr $ printf "\n%s: Epochs to run/max batches per epoch: %d/%d" @@ -425,7 +425,7 @@ testCNNOPP = do valsInit :: MnistCnnRanked2.ADCnnMnistParameters RepN Double valsInit = forgetShape $ fst - $ randomVals @(MnistCnnRanked2.ADCnnMnistParametersShaped + $ randomValue @(MnistCnnRanked2.ADCnnMnistParametersShaped RepN 4 4 -- see sizeMnistWidthI, etc. 1 1 1 1 Double) 0.4 (mkStdGen 44) diff --git a/test/simplified/TestMnistFCNNR.hs b/test/simplified/TestMnistFCNNR.hs index 480a84ded..c544df98a 100644 --- a/test/simplified/TestMnistFCNNR.hs +++ b/test/simplified/TestMnistFCNNR.hs @@ -63,7 +63,7 @@ mnistTestCase1VTA prefix epochs maxBatches widthHiddenInt widthHidden2Int withSNat widthHidden2Int $ \(widthHidden2SNat :: SNat widthHidden2) -> let valsInit :: MnistFcnnRanked1.ADFcnnMnist1Parameters RepN widthHidden widthHidden2 r - valsInit = fst $ randomVals 1 (mkStdGen 44) + valsInit = fst $ randomValue 1 (mkStdGen 44) name = prefix ++ ": " ++ unwords [ show epochs, show maxBatches , show widthHiddenInt, show widthHidden2Int @@ -104,10 +104,10 @@ mnistTestCase1VTA prefix epochs maxBatches widthHiddenInt widthHidden2Int f mnist adinputs = MnistFcnnRanked1.afcnnMnistLoss1 widthHiddenSNat widthHidden2SNat - mnist (parseHVector adinputs) + mnist (fromTarget adinputs) res = fst $ sgd gamma f chunk hVector - trainScore = ftest chunk (parseHVector res) - testScore = ftest testData (parseHVector res) + trainScore = ftest chunk (fromTarget res) + testScore = ftest testData (fromTarget res) lenChunk = length chunk unless (widthHiddenInt < 10) $ do hPutStrLn stderr $ printf "\n%s: (Batch %d with %d points)" prefix k lenChunk @@ -126,8 +126,8 @@ mnistTestCase1VTA prefix epochs maxBatches widthHiddenInt widthHidden2Int $ zip [1 ..] $ chunksOf batchSize trainDataShuffled res <- foldM runBatch params chunks runEpoch (succ n) res - res <- runEpoch 1 $ toHVectorOf valsInit - let testErrorFinal = 1 - ftest testData (parseHVector res) + res <- runEpoch 1 $ toTarget valsInit + let testErrorFinal = 1 - ftest testData (fromTarget res) testErrorFinal @?~ expected {-# SPECIALIZE mnistTestCase1VTA @@ -160,7 +160,7 @@ mnistTestCase1VTI prefix epochs maxBatches widthHiddenInt widthHidden2Int withSNat widthHidden2Int $ \(widthHidden2SNat :: SNat widthHidden2) -> let valsInit :: MnistFcnnRanked1.ADFcnnMnist1Parameters RepN widthHidden widthHidden2 r - valsInit = fst $ randomVals 1 (mkStdGen 44) + valsInit = fst $ randomValue 1 (mkStdGen 44) name = prefix ++ ": " ++ unwords [ show epochs, show maxBatches , show widthHiddenInt, show widthHidden2Int @@ -181,7 +181,7 @@ mnistTestCase1VTI prefix epochs maxBatches widthHiddenInt widthHidden2Int (aDSTK $ stkOfListR (stensorKind @(TKS '[widthHidden2] r)) (SNat @SizeMnistLabel)) $ testCase name $ do let hVectorInit :: RepN (XParams widthHidden widthHidden2 r) - hVectorInit = toHVectorOf @RepN valsInit + hVectorInit = toTarget @RepN valsInit ftk = tftk @RepN (stensorKind @(XParams widthHidden widthHidden2 r)) hVectorInit ftest :: [MnistData r] -> MnistFcnnRanked1.ADFcnnMnist1Parameters @@ -202,7 +202,7 @@ mnistTestCase1VTI prefix epochs maxBatches widthHiddenInt widthHidden2Int let ast :: AstTensor AstMethodLet FullSpan (TKR 0 r) ast = MnistFcnnRanked1.afcnnMnistLoss1TensorData widthHiddenSNat widthHidden2SNat (astGlyph, astLabel) - (parseHVector hVector2) + (fromTarget hVector2) -- Mimic how backprop tests and display it, even though tests -- should not print, in principle. let runBatch :: RepN (XParams widthHidden widthHidden2 r) @@ -222,8 +222,8 @@ mnistTestCase1VTI prefix epochs maxBatches widthHiddenInt widthHidden2Int env in interpretAst envMnist ast res = fst $ sgd gamma f chunk hVector - trainScore = ftest chunk (parseHVector res) - testScore = ftest testData (parseHVector res) + trainScore = ftest chunk (fromTarget res) + testScore = ftest testData (fromTarget res) lenChunk = length chunk unless (widthHiddenInt < 10) $ do hPutStrLn stderr $ printf "\n%s: (Batch %d with %d points)" prefix k lenChunk @@ -242,8 +242,8 @@ mnistTestCase1VTI prefix epochs maxBatches widthHiddenInt widthHidden2Int $ zip [1 ..] $ chunksOf batchSize trainDataShuffled res <- foldM runBatch params chunks runEpoch (succ n) res - res <- runEpoch 1 $ toHVectorOf valsInit - let testErrorFinal = 1 - ftest testData (parseHVector res) + res <- runEpoch 1 $ toTarget valsInit + let testErrorFinal = 1 - ftest testData (fromTarget res) testErrorFinal @?~ expected {-# SPECIALIZE mnistTestCase1VTI @@ -277,7 +277,7 @@ mnistTestCase1VTO prefix epochs maxBatches widthHiddenInt widthHidden2Int withSNat widthHidden2Int $ \(widthHidden2SNat :: SNat widthHidden2) -> let valsInit :: MnistFcnnRanked1.ADFcnnMnist1Parameters RepN widthHidden widthHidden2 r - valsInit = fst $ randomVals 1 (mkStdGen 44) + valsInit = fst $ randomValue 1 (mkStdGen 44) name = prefix ++ ": " ++ unwords [ show epochs, show maxBatches , show widthHiddenInt, show widthHidden2Int @@ -344,8 +344,8 @@ mnistTestCase1VTO prefix epochs maxBatches widthHiddenInt widthHidden2Int -> IO (RepN (XParams widthHidden widthHidden2 r)) runBatch !hVector (k, chunk) = do let res = go chunk hVector - trainScore = ftest chunk (parseHVector res) - testScore = ftest testData (parseHVector res) + trainScore = ftest chunk (fromTarget res) + testScore = ftest testData (fromTarget res) lenChunk = length chunk unless (widthHiddenInt < 10) $ do hPutStrLn stderr $ printf "\n%s: (Batch %d with %d points)" prefix k lenChunk @@ -364,8 +364,8 @@ mnistTestCase1VTO prefix epochs maxBatches widthHiddenInt widthHidden2Int $ zip [1 ..] $ chunksOf batchSize trainDataShuffled res <- foldM runBatch params chunks runEpoch (succ n) res - res <- runEpoch 1 $ toHVectorOf valsInit - let testErrorFinal = 1 - ftest testData (parseHVector res) + res <- runEpoch 1 $ toTarget valsInit + let testErrorFinal = 1 - ftest testData (fromTarget res) testErrorFinal @?~ expected {-# SPECIALIZE mnistTestCase1VTO @@ -407,14 +407,14 @@ mnistTestCase2VTA prefix epochs maxBatches widthHidden widthHidden2 case someNatVal $ toInteger widthHidden2 of Just (SomeNat @widthHidden2 _) -> forgetShape $ fst - $ randomVals + $ randomValue @(MnistFcnnRanked2.ADFcnnMnist2ParametersShaped RepN widthHidden widthHidden2 r) 1 (mkStdGen 44) Nothing -> error "valsInit: impossible someNatVal error" Nothing -> error "valsInit: impossible someNatVal error" hVectorInit :: RepN (XParams2 r) - hVectorInit = toHVectorOf @RepN valsInit + hVectorInit = toTarget @RepN valsInit name = prefix ++ ": " ++ unwords [ show epochs, show maxBatches , show widthHidden, show widthHidden2 @@ -424,7 +424,7 @@ mnistTestCase2VTA prefix epochs maxBatches widthHidden widthHidden2 ftest :: [MnistData r] -> RepN (XParams2 r) -> r ftest mnistData pars = MnistFcnnRanked2.afcnnMnistTest2 - mnistData (parseHVector @RepN pars) + mnistData (fromTarget @RepN pars) in testCase name $ do hPutStrLn stderr $ printf "\n%s: Epochs to run/max batches per epoch: %d/%d" @@ -443,7 +443,7 @@ mnistTestCase2VTA prefix epochs maxBatches widthHidden widthHidden2 -> ADVal RepN (TKR 0 r) f mnist adinputs = MnistFcnnRanked2.afcnnMnistLoss2 - mnist (parseHVector adinputs) + mnist (fromTarget adinputs) res = fst $ sgd gamma f chunk hVector trainScore = ftest chunk res testScore = ftest testData res @@ -504,12 +504,12 @@ mnistTestCase2VTI prefix epochs maxBatches widthHidden widthHidden2 Nothing -> error "impossible someNatVal error" Just (SomeNat @widthHidden2 _) -> forgetShape $ fst - $ randomVals + $ randomValue @(MnistFcnnRanked2.ADFcnnMnist2ParametersShaped RepN widthHidden widthHidden2 r) 1 (mkStdGen 44) hVectorInit :: RepN (XParams2 r) - hVectorInit = toHVectorOf @RepN valsInit + hVectorInit = toTarget @RepN valsInit ftk = tftk @RepN (stensorKind @(XParams2 r)) hVectorInit name = prefix ++ ": " @@ -521,7 +521,7 @@ mnistTestCase2VTI prefix epochs maxBatches widthHidden widthHidden2 ftest :: [MnistData r] -> RepN (XParams2 r) -> r ftest mnistData pars = MnistFcnnRanked2.afcnnMnistTest2 - mnistData (parseHVector @RepN pars) + mnistData (fromTarget @RepN pars) in testCase name $ do hPutStrLn stderr $ printf "\n%s: Epochs to run/max batches per epoch: %d/%d" @@ -537,7 +537,7 @@ mnistTestCase2VTI prefix epochs maxBatches widthHidden widthHidden2 let ast :: AstTensor AstMethodLet FullSpan (TKR 0 r) ast = MnistFcnnRanked2.afcnnMnistLoss2TensorData (astGlyph, astLabel) - (parseHVector hVector2) + (fromTarget hVector2) -- Mimic how backprop tests and display it, even though tests -- should not print, in principle. let runBatch :: RepN (XParams2 r) @@ -619,15 +619,15 @@ mnistTestCase2VTO prefix epochs maxBatches widthHidden widthHidden2 let valsInitShaped :: MnistFcnnRanked2.ADFcnnMnist2ParametersShaped RepN widthHidden widthHidden2 r - valsInitShaped = fst $ randomVals 1 (mkStdGen 44) + valsInitShaped = fst $ randomValue 1 (mkStdGen 44) valsInit :: MnistFcnnRanked2.ADFcnnMnist2Parameters RepN r valsInit = -- This almost works and I wouldn't need forgetShape, -- but there is nowhere to get aInit from. - -- parseHVector hVectorInit + -- fromTarget hVectorInit forgetShape valsInitShaped hVectorInit :: RepN (XParams2 r) - hVectorInit = toHVectorOf @RepN valsInit + hVectorInit = toTarget @RepN valsInit name = prefix ++ ": " ++ unwords [ show epochs, show maxBatches , show widthHidden, show widthHidden2 @@ -637,7 +637,7 @@ mnistTestCase2VTO prefix epochs maxBatches widthHidden widthHidden2 ftest :: [MnistData r] -> RepN (XParams2 r) -> r ftest mnistData pars = MnistFcnnRanked2.afcnnMnistTest2 - mnistData (parseHVector @RepN pars) + mnistData (fromTarget @RepN pars) in testCase name $ do hPutStrLn stderr $ printf "\n%s: Epochs to run/max batches per epoch: %d/%d" diff --git a/test/simplified/TestMnistRNNR.hs b/test/simplified/TestMnistRNNR.hs index b2caa88ba..aa9de2e9c 100644 --- a/test/simplified/TestMnistRNNR.hs +++ b/test/simplified/TestMnistRNNR.hs @@ -64,11 +64,11 @@ mnistTestCaseRNNA prefix epochs maxBatches width miniBatchSize totalBatchSize Nothing -> error "impossible someNatVal error" Just (SomeNat @width _) -> forgetShape $ fst - $ randomVals @(ADRnnMnistParametersShaped + $ randomValue @(ADRnnMnistParametersShaped RepN width r) 0.4 (mkStdGen 44) hVectorInit :: RepN (X (ADRnnMnistParameters RepN r)) - hVectorInit = toHVectorOf @RepN valsInit + hVectorInit = toTarget @RepN valsInit ftk = tftk @RepN (stensorKind @(X (ADRnnMnistParameters RepN r))) hVectorInit name = prefix ++ ": " @@ -81,7 +81,7 @@ mnistTestCaseRNNA prefix epochs maxBatches width miniBatchSize totalBatchSize -> r ftest batch_size mnistData pars = MnistRnnRanked2.rnnMnistTestR - batch_size mnistData (parseHVector @RepN pars) + batch_size mnistData (fromTarget @RepN pars) in testCase name $ do hPutStrLn stderr $ printf "\n%s: Epochs to run/max batches per epoch: %d/%d" @@ -103,7 +103,7 @@ mnistTestCaseRNNA prefix epochs maxBatches width miniBatchSize totalBatchSize f (glyphR, labelR) adinputs = MnistRnnRanked2.rnnMnistLossFusedR miniBatchSize (rconcrete glyphR, rconcrete labelR) - (parseHVector @(ADVal RepN) adinputs) + (fromTarget @(ADVal RepN) adinputs) chunkR = map packBatchR $ filter (\ch -> length ch == miniBatchSize) $ chunksOf miniBatchSize chunk @@ -171,11 +171,11 @@ mnistTestCaseRNNI prefix epochs maxBatches width miniBatchSize totalBatchSize Nothing -> error "impossible someNatVal error" Just (SomeNat @width _) -> forgetShape $ fst - $ randomVals @(ADRnnMnistParametersShaped + $ randomValue @(ADRnnMnistParametersShaped RepN width r) 0.4 (mkStdGen 44) hVectorInit :: RepN (X (ADRnnMnistParameters RepN r)) - hVectorInit = toHVectorOf @RepN valsInit + hVectorInit = toTarget @RepN valsInit ftk = tftk @RepN (stensorKind @(X (ADRnnMnistParameters RepN r))) hVectorInit name = prefix ++ ": " @@ -188,7 +188,7 @@ mnistTestCaseRNNI prefix epochs maxBatches width miniBatchSize totalBatchSize -> r ftest batch_size mnistData pars = MnistRnnRanked2.rnnMnistTestR - batch_size mnistData (parseHVector @RepN pars) + batch_size mnistData (fromTarget @RepN pars) in testCase name $ do hPutStrLn stderr $ printf "\n%s: Epochs to run/max batches per epoch: %d/%d" @@ -208,7 +208,7 @@ mnistTestCaseRNNI prefix epochs maxBatches width miniBatchSize totalBatchSize let ast :: AstTensor AstMethodLet FullSpan (TKR 0 r) ast = MnistRnnRanked2.rnnMnistLossFusedR miniBatchSize (astGlyph, astLabel) - (parseHVector hVector) + (fromTarget hVector) runBatch :: ( RepN (X (ADRnnMnistParameters RepN r)) , StateAdamDeep (X (ADRnnMnistParameters RepN r)) ) -> (Int, [MnistDataR r]) @@ -291,11 +291,11 @@ mnistTestCaseRNNO prefix epochs maxBatches width miniBatchSize totalBatchSize Just (SomeNat @width _) -> let valsInitShaped :: ADRnnMnistParametersShaped RepN width r - valsInitShaped = fst $ randomVals 0.4 (mkStdGen 44) + valsInitShaped = fst $ randomValue 0.4 (mkStdGen 44) valsInit :: ADRnnMnistParameters target r valsInit = forgetShape valsInitShaped hVectorInit :: RepN (X (ADRnnMnistParameters RepN r)) - hVectorInit = toHVectorOf @RepN valsInit + hVectorInit = toTarget @RepN valsInit ftk = tftk @RepN (stensorKind @(X (ADRnnMnistParameters RepN r))) hVectorInit name = prefix ++ ": " @@ -308,7 +308,7 @@ mnistTestCaseRNNO prefix epochs maxBatches width miniBatchSize totalBatchSize -> r ftest batch_size mnistData pars = MnistRnnRanked2.rnnMnistTestR - batch_size mnistData (parseHVector @RepN pars) + batch_size mnistData (fromTarget @RepN pars) in testCase name $ do hPutStrLn stderr $ printf "\n%s: Epochs to run/max batches per epoch: %d/%d" diff --git a/test/simplified/TestMnistRNNS.hs b/test/simplified/TestMnistRNNS.hs index 54cd9e866..7ad62489d 100644 --- a/test/simplified/TestMnistRNNS.hs +++ b/test/simplified/TestMnistRNNS.hs @@ -53,9 +53,9 @@ mnistTestCaseRNNSA prefix epochs maxBatches width@SNat batch_size@SNat expected = let valsInit :: ADRnnMnistParametersShaped RepN SizeMnistHeight width r - valsInit = fst $ randomVals 0.4 (mkStdGen 44) + valsInit = fst $ randomValue 0.4 (mkStdGen 44) hVectorInit :: RepN (XParams width r) - hVectorInit = toHVectorOf @RepN valsInit + hVectorInit = toTarget @RepN valsInit ftk = tftk @RepN (stensorKind @(XParams width r)) hVectorInit @@ -75,7 +75,7 @@ mnistTestCaseRNNSA prefix epochs maxBatches width@SNat batch_size@SNat let mnist = ( Nested.rcastToShaped glyphs knownShS , Nested.rcastToShaped labels knownShS ) in MnistRnnShaped2.rnnMnistTestS - width bs mnist (parseHVector @RepN testParams) + width bs mnist (fromTarget @RepN testParams) in testCase name $ do hPutStrLn stderr $ printf "\n%s: Epochs to run/max batches per epoch: %d/%d" @@ -97,7 +97,7 @@ mnistTestCaseRNNSA prefix epochs maxBatches width@SNat batch_size@SNat f (glyphS, labelS) adinputs = MnistRnnShaped2.rnnMnistLossFusedS width batch_size (sconcrete glyphS, sconcrete labelS) - (parseHVector @(ADVal RepN) adinputs) + (fromTarget @(ADVal RepN) adinputs) chunkS = map packBatch $ filter (\ch -> length ch == miniBatchSize) $ chunksOf miniBatchSize chunk @@ -165,9 +165,9 @@ mnistTestCaseRNNSI prefix epochs maxBatches width@SNat batch_size@SNat totalBatchSize expected = let valsInit :: ADRnnMnistParametersShaped RepN SizeMnistHeight width r - valsInit = fst $ randomVals 0.4 (mkStdGen 44) + valsInit = fst $ randomValue 0.4 (mkStdGen 44) hVectorInit :: RepN (XParams width r) - hVectorInit = toHVectorOf @RepN valsInit + hVectorInit = toTarget @RepN valsInit ftk = tftk @RepN (stensorKind @(XParams width r)) hVectorInit miniBatchSize = sNatValue batch_size @@ -187,7 +187,7 @@ mnistTestCaseRNNSI prefix epochs maxBatches width@SNat batch_size@SNat let mnist = ( Nested.rcastToShaped glyphs knownShS , Nested.rcastToShaped labels knownShS ) in MnistRnnShaped2.rnnMnistTestS - width bs mnist (parseHVector @RepN testParams) + width bs mnist (fromTarget @RepN testParams) in testCase name $ do hPutStrLn stderr $ printf "\n%s: Epochs to run/max batches per epoch: %d/%d" @@ -205,7 +205,7 @@ mnistTestCaseRNNSI prefix epochs maxBatches width@SNat batch_size@SNat let ast :: AstTensor AstMethodLet FullSpan (TKS '[] r) ast = MnistRnnShaped2.rnnMnistLossFusedS width batch_size (astGlyph, astLabel) - (parseHVector hVector) + (fromTarget hVector) runBatch :: ( RepN (XParams width r) , StateAdamDeep (XParams width r) ) -> (Int, [MnistDataS r]) @@ -291,9 +291,9 @@ mnistTestCaseRNNSO prefix epochs maxBatches width@SNat batch_size@SNat expected = let valsInit :: ADRnnMnistParametersShaped RepN SizeMnistHeight width r - valsInit = fst $ randomVals 0.4 (mkStdGen 44) + valsInit = fst $ randomValue 0.4 (mkStdGen 44) hVectorInit :: RepN (XParams width r) - hVectorInit = toHVectorOf @RepN valsInit + hVectorInit = toTarget @RepN valsInit ftk = tftk @RepN (stensorKind @(XParams width r)) hVectorInit miniBatchSize = sNatValue batch_size @@ -313,7 +313,7 @@ mnistTestCaseRNNSO prefix epochs maxBatches width@SNat batch_size@SNat , Nested.rcastToShaped labels knownShS ) in MnistRnnShaped2.rnnMnistTestS width bs mnist - (parseHVector @RepN testParams) + (fromTarget @RepN testParams) in testCase name $ do hPutStrLn stderr $ printf "\n%s: Epochs to run/max batches per epoch: %d/%d" diff --git a/test/tool/CrossTesting.hs b/test/tool/CrossTesting.hs index 81478a127..1bea89f8b 100644 --- a/test/tool/CrossTesting.hs +++ b/test/tool/CrossTesting.hs @@ -36,17 +36,17 @@ crevDtMaybeBoth :: forall r y f advals. ( f ~ RepN, X advals ~ X (DValue advals), TensorKind (X advals) , GoodScalar r, KnownNat y - , AdaptableHVector (ADVal RepN) advals - , AdaptableHVector (ADVal RepN) (ADVal f (TKR y r)) - , AdaptableHVector RepN (DValue advals) ) + , AdaptableTarget (ADVal RepN) advals + , AdaptableTarget (ADVal RepN) (ADVal f (TKR y r)) + , AdaptableTarget RepN (DValue advals) ) => Maybe (f (ADTensorKind (TKR y r))) -> (advals -> ADVal f (TKR y r)) -> DValue advals -> (f (ADTensorKind (X advals)), f (TKR y r)) {-# INLINE crevDtMaybeBoth #-} crevDtMaybeBoth mdt f vals = let g :: ADVal RepN (X advals) -> ADVal RepN (TKR y r) - g = toHVectorOf . f . parseHVector - valsH = toHVectorOf vals + g = toTarget . f . fromTarget + valsH = toTarget vals in crevOnHVector mdt g valsH rev' :: forall r m n v a w. @@ -67,13 +67,13 @@ rev' f vals = dt = Nothing g :: ADVal RepN (TKR n r) -> ADVal RepN (TKR m r) - g inputs = f $ parseHVector inputs + g inputs = f $ fromTarget inputs (gradient1, value1) = crevDtMaybeBoth dt g vals gradientRrev1 = rrev1 @RepN @r @n @m f vals g9 :: ADVal (AstRaw PrimalSpan) (TKR n r) -> ADVal (AstRaw PrimalSpan) (TKR m r) g9 inputs = f @(ADVal (AstRaw PrimalSpan)) - $ parseHVector inputs + $ fromTarget inputs artifactsGradAst9 = fst $ revProduceArtifactWithoutInterpretation False g9 ftk @@ -101,7 +101,7 @@ rev' f vals = -> ADVal RepN (TKR m r) h fx1 fx2 gx inputs = hGeneral @(ADVal RepN) fx1 fx2 gx - (parseHVector inputs) + (fromTarget inputs) (gradient2, value2) = crevDtMaybeBoth dt (h id id id) vals (gradient3, value3) = @@ -144,7 +144,7 @@ rev' f vals = -> ADVal (AstRaw PrimalSpan) (TKR m r) hAst fx1 fx2 gx inputs = hGeneral @(ADVal (AstRaw PrimalSpan)) - fx1 fx2 gx (parseHVector inputs) + fx1 fx2 gx (fromTarget inputs) artifactsGradAst = fst $ revProduceArtifactWithoutInterpretation False (hAst id id id) ftk