diff options
Diffstat (limited to 'examples/Numeric')
| -rw-r--r-- | examples/Numeric/ADDual/Examples.hs | 61 |
1 files changed, 55 insertions, 6 deletions
diff --git a/examples/Numeric/ADDual/Examples.hs b/examples/Numeric/ADDual/Examples.hs index 819aec4..3835daa 100644 --- a/examples/Numeric/ADDual/Examples.hs +++ b/examples/Numeric/ADDual/Examples.hs @@ -1,12 +1,15 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} module Numeric.ADDual.Examples where import Control.DeepSeq import Control.Monad (replicateM) +import Data.Bifunctor (bimap) import Data.Maybe (catMaybes) import qualified Data.Vector as V +import qualified Data.Vector.Storable as VS import GHC.Generics (Generic) import Hedgehog (Gen, Size) import qualified Hedgehog.Gen as Gen @@ -15,14 +18,21 @@ import qualified Hedgehog.Internal.Gen as HI.Gen import qualified Hedgehog.Internal.Seed as HI.Seed import qualified Hedgehog.Internal.Tree as HI.Tree +import Numeric.ADDual.VectorOps + type Matrix s = V.Vector s data FNeural a = FNeural [(Matrix a, V.Vector a)] (V.Vector a) deriving (Show, Eq, Functor, Foldable, Traversable, Generic) - instance NFData a => NFData (FNeural a) +type SMatrix s = VS.Vector s + +data FNeuralA v = FNeuralA [(V.Vector v, v)] v + deriving (Show, Eq, Functor, Foldable, Traversable, Generic) +instance NFData v => NFData (FNeuralA v) + fneural :: (Floating a, Ord a) => FNeural a -> a fneural (FNeural layers input) = let dotp v1 v2 = V.sum (V.zipWith (*) v1 v2) @@ -44,20 +54,59 @@ fneural (FNeural layers input) = in V.sum $ forward layers input makeNeuralInput :: Int -> FNeural Double -makeNeuralInput scale = sampleGenPure 100 (genNeuralInput scale) +makeNeuralInput scale = cvtFNeuralAtoFNeural $ makeNeuralInput_A scale genNeuralInput :: Int -> Gen (FNeural Double) -genNeuralInput scale = do +genNeuralInput scale = cvtFNeuralAtoFNeural <$> genNeuralInput_A scale + +cvtFNeuralAtoFNeural :: FNeuralA (VS.Vector Double) -> FNeural Double +cvtFNeuralAtoFNeural (FNeuralA layers input) = + FNeural (map (bimap (\m -> let nin = V.length m + nout = VS.length (m V.! 0) + in V.fromListN (nin*nout) $ concatMap VS.toList $ V.toList m) + (\v -> let n = VS.length v in V.fromListN n (VS.toList v))) + layers) + (let n = VS.length input in V.fromListN n (VS.toList input)) + +fneural_A :: forall v. (VectorOpsFloating v, VectorOpsOrd v) + => FNeuralA v -> VectorOpsScalar v +fneural_A (FNeuralA layers input) = + let dotp v1 v2 = vsum (vmul v1 v2) + + (@.) :: V.Vector v -> v -> v + mat @. vec = + let n = vlength vec + m = V.length mat `div` n + in vfromListN m $ map (\row -> dotp row vec) (V.toList mat) + (+.) = vadd + + batchrelu :: v -> v + batchrelu x = vselect (vcmpGE x (vreplicate (vlength x) 0.0)) x (vreplicate (vlength x) 0.0) + safeSoftmax vec = let m = vmaximum vec + exps = vexp (vsub vec (vreplicate (vlength vec) m)) + factor = vsum exps + in vmul exps (vreplicate (vlength vec) (recip factor)) + forward [] x = safeSoftmax x + forward ((weights, bias) : lys) x = + let x' = batchrelu ((weights @. x) +. bias) + in forward lys x' + in vsum $ forward layers input + +makeNeuralInput_A :: Int -> FNeuralA (VS.Vector Double) +makeNeuralInput_A scale = sampleGenPure 100 (genNeuralInput_A scale) + +genNeuralInput_A :: Int -> Gen (FNeuralA (VS.Vector Double)) +genNeuralInput_A 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 + genVector nout = VS.fromListN nout <$> replicateM nout genScalar + genMatrix nin nout = V.fromListN nin <$> replicateM nin (genVector nout) 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 + pure $ FNeuralA [(m1, v1), (m2, v2)] inp sampleGenPure :: Size -> Gen a -> a |