aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--bench/Main.hs17
-rw-r--r--examples/Numeric/ADDual/Examples.hs37
-rw-r--r--src/Numeric/ADDual/Internal.hs6
-rw-r--r--test/Main.hs36
4 files changed, 63 insertions, 33 deletions
diff --git a/bench/Main.hs b/bench/Main.hs
index a11f4e8..99c3f1d 100644
--- a/bench/Main.hs
+++ b/bench/Main.hs
@@ -4,11 +4,24 @@ module Main where
import Criterion
import Criterion.Main
+import qualified Numeric.AD as AD
+
import qualified Numeric.ADDual as ADD
import Numeric.ADDual.Examples
main :: IO ()
main = defaultMain
- [env (pure makeNeuralInput) $ \input ->
- bench "neural" $ nf (\inp -> ADD.gradient' @Double fneural inp 1.0) input]
+ [env (pure (makeNeuralInput 100)) $ \input ->
+ bgroup "neural-100"
+ [bench "dual" $ nf (\inp -> ADD.gradient' @Double fneural inp 1.0) input
+ ,bench "ad" $ nf (\inp -> AD.grad fneural inp) input]
+ ,env (pure (makeNeuralInput 500)) $ \input ->
+ bgroup "neural-500"
+ [bench "dual" $ nf (\inp -> ADD.gradient' @Double fneural inp 1.0) input
+ ,bench "ad" $ nf (\inp -> AD.grad fneural inp) input]
+ ,env (pure (makeNeuralInput 2000)) $ \input ->
+ bgroup "neural-2000"
+ [bench "dual" $ nf (\inp -> ADD.gradient' @Double fneural inp 1.0) input
+ ,bench "ad" $ nf (\inp -> AD.grad fneural inp) input]
+ ]
diff --git a/examples/Numeric/ADDual/Examples.hs b/examples/Numeric/ADDual/Examples.hs
index d6aa6d2..819aec4 100644
--- a/examples/Numeric/ADDual/Examples.hs
+++ b/examples/Numeric/ADDual/Examples.hs
@@ -5,17 +5,21 @@ module Numeric.ADDual.Examples where
import Control.DeepSeq
import Control.Monad (replicateM)
+import Data.Maybe (catMaybes)
import qualified Data.Vector as V
import GHC.Generics (Generic)
-import Hedgehog (Gen)
+import Hedgehog (Gen, Size)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
+import qualified Hedgehog.Internal.Gen as HI.Gen
+import qualified Hedgehog.Internal.Seed as HI.Seed
+import qualified Hedgehog.Internal.Tree as HI.Tree
type Matrix s = V.Vector s
data FNeural a = FNeural [(Matrix a, V.Vector a)] (V.Vector a)
- deriving (Show, Functor, Foldable, Traversable, Generic)
+ deriving (Show, Eq, Functor, Foldable, Traversable, Generic)
instance NFData a => NFData (FNeural a)
@@ -39,27 +43,24 @@ fneural (FNeural layers input) =
in forward lys x'
in V.sum $ forward layers input
-makeNeuralInput :: FNeural Double
-makeNeuralInput =
- let genMatrix nin nout =
- V.fromListN (nin*nout) [sin (fromIntegral @Int (i+j))
- | i <- [0..nout-1], j <- [0..nin-1]]
- genVector nout = V.fromListN nout [sin (0.41 * fromIntegral @Int i) | i <- [0..nout-1]]
- -- 50 inputs; 2 hidden layers (100; 50); final softmax, then sum the outputs.
- nIn = 50; n1 = 100; n2 = 50
- in FNeural [(genMatrix nIn n1, genVector n1)
- ,(genMatrix n1 n2, genVector n2)]
- (genVector nIn)
+makeNeuralInput :: Int -> FNeural Double
+makeNeuralInput scale = sampleGenPure 100 (genNeuralInput scale)
-genNeuralInput :: Gen (FNeural Double)
-genNeuralInput = do
+genNeuralInput :: Int -> Gen (FNeural Double)
+genNeuralInput scale = do
let genScalar = Gen.double (Range.linearFracFrom 0 (-1) 1)
genMatrix nin nout = V.fromListN (nin*nout) <$> replicateM (nin*nout) genScalar
genVector nout = V.fromListN nout <$> replicateM nout genScalar
- nIn <- Gen.integral (Range.linear 1 80)
- n1 <- Gen.integral (Range.linear 1 100)
- n2 <- Gen.integral (Range.linear 1 80)
+ nIn <- Gen.integral (Range.linear 1 scale)
+ n1 <- Gen.integral (Range.linear 1 scale)
+ n2 <- Gen.integral (Range.linear 1 scale)
m1 <- genMatrix nIn n1; v1 <- genVector n1
m2 <- genMatrix n1 n2; v2 <- genVector n2
inp <- genVector nIn
pure $ FNeural [(m1, v1), (m2, v2)] inp
+
+
+sampleGenPure :: Size -> Gen a -> a
+sampleGenPure size gen =
+ HI.Tree.treeValue $ head $ catMaybes
+ [HI.Gen.evalGen size (HI.Seed.from n) gen | n <- [42..]]
diff --git a/src/Numeric/ADDual/Internal.hs b/src/Numeric/ADDual/Internal.hs
index 5955fae..1ea3132 100644
--- a/src/Numeric/ADDual/Internal.hs
+++ b/src/Numeric/ADDual/Internal.hs
@@ -159,9 +159,9 @@ instance (Fractional a, Storable a, Taping s a) => Fractional (Dual s a) where
instance (Floating a, Storable a, Taping s a) => Floating (Dual s a) where
pi = Dual pi (-1)
- exp (Dual x i1) = mkDual (exp x) i1 (exp x) (-1) 0
- log (Dual x i1) = mkDual (log x) i1 (recip x) (-1) 0
- sqrt (Dual x i1) = mkDual (sqrt x) i1 (recip (2*sqrt x)) (-1) 0
+ exp (Dual x i1) = mkDual (exp x) i1 (exp x) (-1) 0
+ log (Dual x i1) = mkDual (log x) i1 (recip x) (-1) 0
+ sqrt (Dual x i1) = mkDual (sqrt x) i1 (recip (2*sqrt x)) (-1) 0
-- d/dx (x ^ y) = d/dx (e ^ (y ln x)) = e ^ (y ln x) * d/dx (y ln x) = e ^ (y ln x) * y/x
-- d/dy (x ^ y) = d/dy (e ^ (y ln x)) = e ^ (y ln x) * d/dy (y ln x) = e ^ (y ln x) * ln x
Dual x i1 ** Dual y i2 =
diff --git a/test/Main.hs b/test/Main.hs
index 04a8923..a04533f 100644
--- a/test/Main.hs
+++ b/test/Main.hs
@@ -1,26 +1,42 @@
{-# LANGUAGE TypeApplications #-}
module Main where
-import qualified Data.Vector as V
+import Data.Foldable (toList)
import Hedgehog
import Test.Tasty
import Test.Tasty.Hedgehog
import Test.Tasty.HUnit
+import qualified Numeric.AD as AD
+
import Numeric.ADDual
import Numeric.ADDual.Examples
+(~==) :: (Foldable t, Fractional a, Ord a, Show (t a)) => t a -> t a -> PropertyT IO ()
+a ~== b
+ | length (toList a) == length (toList b)
+ , and (zipWith close (toList a) (toList b))
+ = return ()
+ | otherwise
+ = diff a (\_ _ -> False) b
+ where
+ close x y = abs (x - y) < 1e-5 ||
+ (let m = max (abs x) (abs y) in m > 1e-5 && abs (x - y) / m < 1e-5)
+
+
main :: IO ()
main = defaultMain $ testGroup "Tests"
[testCase "product [1..5]" $
gradient' @Double product [1..5] 1 @?= (120, [120, 60, 40, 30, 24])
- ,testCase "neural one" $
- let problem = FNeural
- [(V.replicate 6 0.0, V.replicate 6 0.0), (V.replicate 24 0.0, V.replicate 4 0.0)]
- (V.replicate 1 0.0)
- in fst (gradient' @Double fneural problem 1) @?= fneural problem
- ,testProperty "neural run" $ property $ do
- input <- forAll genNeuralInput
- let (res, _grad) = gradient' fneural input 1
- res === fneural input]
+ ,testProperty "neural 80" $ property $ do
+ input <- forAll (genNeuralInput 80)
+ let (res, grad) = gradient' fneural input 1
+ res === fneural input
+ grad ~== AD.grad fneural input
+ ,testProperty "neural 150" $ property $ do
+ input <- forAll (genNeuralInput 150)
+ let (res, grad) = gradient' fneural input 1
+ res === fneural input
+ grad ~== AD.grad fneural input
+ ]
generated by cgit v1.2.3-70-g09d2 (git 2.48.1) at 2025-02-25 22:36:26 +0100