From b48470a2c03b3d8b879baad3155bc5623a9f9a21 Mon Sep 17 00:00:00 2001 From: timpierson Date: Thu, 15 Feb 2018 23:57:16 +0000 Subject: [PATCH] refactoring unitals and fundeps --- diffhask.cabal | 27 +- src/Core.hs | 276 ++++++------ src/Internal/Internal.hs | 42 +- src/Internal/NumHask/Algebra.hs | 8 +- src/Internal/NumHask/Algebra/.#Additive.hs | 2 +- src/Internal/NumHask/Algebra/Additive.hs | 386 ++++++++++++++--- src/Internal/NumHask/Algebra/Basis.hs | 28 -- src/Internal/NumHask/Algebra/Diff.hs | 38 -- src/Internal/NumHask/Algebra/Distribution.hs | 19 +- src/Internal/NumHask/Algebra/Field.hs | 88 ++-- src/Internal/NumHask/Algebra/Metric.hs | 59 ++- src/Internal/NumHask/Algebra/Module.hs | 13 +- .../NumHask/Algebra/Multiplicative.hs | 406 +++++++++++++++--- src/Internal/NumHask/Algebra/Ring.hs | 50 +-- src/Internal/NumHask/Prelude.hs | 8 +- src/Num.hs | 2 - stack.yaml | 2 +- test/.#Spec.hs | 1 + test/Spec.hs | 87 +++- 19 files changed, 1055 insertions(+), 487 deletions(-) delete mode 100644 src/Internal/NumHask/Algebra/Basis.hs delete mode 100644 src/Internal/NumHask/Algebra/Diff.hs create mode 120000 test/.#Spec.hs diff --git a/diffhask.cabal b/diffhask.cabal index c7766c2..6ad40f9 100644 --- a/diffhask.cabal +++ b/diffhask.cabal @@ -16,11 +16,10 @@ tested-with: GHC == 8.2.2 library hs-source-dirs: src - exposed-modules: Core, Num - other-modules: Internal.Internal - , Internal.NumHask.Algebra + exposed-modules: Core, Num, Internal.NumHask.Prelude, Internal.Internal + other-modules: + Internal.NumHask.Algebra , Internal.NumHask.Algebra.Additive - , Internal.NumHask.Algebra.Basis , Internal.NumHask.Algebra.Distribution , Internal.NumHask.Algebra.Field , Internal.NumHask.Algebra.Multiplicative @@ -29,14 +28,13 @@ library , Internal.NumHask.Algebra.Module , Internal.NumHask.Algebra.Metric , Internal.NumHask.Algebra.Singleton - , Internal.NumHask.Algebra.Diff - , Internal.NumHask.Prelude + - ghc-options: -Wall -fllvm -O2 - default-extensions: NegativeLiterals OverloadedStrings UnicodeSyntax ScopedTypeVariables + ghc-options: -Wall + default-extensions: NegativeLiterals UnicodeSyntax ScopedTypeVariables FlexibleContexts build-depends: base , value-supply , containers @@ -66,7 +64,7 @@ test-suite diffhask-test type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs - default-extensions: NegativeLiterals OverloadedStrings UnicodeSyntax ScopedTypeVariables + default-extensions: NegativeLiterals OverloadedStrings UnicodeSyntax ScopedTypeVariables FlexibleContexts NoImplicitPrelude build-depends: base , diffhask , text @@ -75,19 +73,26 @@ test-suite diffhask-test , doctest , tasty , tasty-quickcheck + , tasty-hunit + , numhask + , numhask-array + - ghc-options: -Wall -Werror -threaded -fllvm -O2 -rtsopts -with-rtsopts=-N + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 benchmark diffhask-benchmark type: exitcode-stdio-1.0 default-language: Haskell2010 - ghc-options: -Wall -Werror -O2 -fllvm -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall -O2 -fllvm -threaded -rtsopts -with-rtsopts=-N hs-source-dirs: benchmark main-is: Main.hs build-depends: base , criterion , diffhask + , numhask + , numhask-array + source-repository head type: git diff --git a/src/Core.hs b/src/Core.hs index c2f3bc6..8d3513f 100644 --- a/src/Core.hs +++ b/src/Core.hs @@ -24,147 +24,147 @@ import Internal.NumHask.Prelude hiding (State, diff, evalState, runState) import Lens.Micro ((%~), (&), (.~), (^.)) import Prelude (error) -import qualified Protolude as P +import qualified NumHask.Prelude as P --FIXME: prune redundancy -type AdditiveDifferentiable t r - = ( - AdditiveMagma (D r t) (D r t) r t - , AdditiveMagma (Computation r t (D r t)) (D r t) r t - , AdditiveMagma (Computation r t (D r t)) (Computation r t (D r t)) r t - , AdditiveMagma (D r t) (Computation r t (D r t)) r t - - , AdditiveAssociative (D r t) r t - , AdditiveAssociative (Computation r t (D r t)) r t - - , AdditiveCommutative (D r t) r t - , AdditiveCommutative (Computation r t (D r t)) r t - - , AdditiveInvertible (D r t) r t - , AdditiveInvertible (Computation r t (D r t)) r t - - , AdditiveIdempotent (D r t) (D r t) r t - , AdditiveIdempotent (Computation r t (D r t)) (D r t) r t - , AdditiveIdempotent (Computation r t (D r t)) (Computation r t (D r t)) r t - , AdditiveIdempotent (D r t) (Computation r t (D r t)) r t - - , Additive (D r t) (D r t) r t - , Additive (Computation r t (D r t)) (D r t) r t - , Additive (Computation r t (D r t)) (Computation r t (D r t)) r t - , Additive (D r t) (Computation r t (D r t)) r t - - , AdditiveLeftCancellative (D r t) (D r t) r t - , AdditiveLeftCancellative (Computation r t (D r t)) (D r t) r t - , AdditiveLeftCancellative (Computation r t (D r t)) (Computation r t (D r t)) r t - , AdditiveLeftCancellative (D r t) (Computation r t (D r t)) r t - - , AdditiveGroup (D r t) (D r t) r t - , AdditiveGroup (Computation r t (D r t)) (D r t) r t - , AdditiveGroup (Computation r t (D r t)) (Computation r t (D r t)) r t - , AdditiveGroup (D r t) (Computation r t (D r t)) r t - ) +-- type AdditiveDifferentiable t r +-- = ( +-- AdditiveMagma (D r t) (D r t) r t +-- , AdditiveMagma (Computation r t (D r t)) (D r t) r t +-- , AdditiveMagma (Computation r t (D r t)) (Computation r t (D r t)) r t +-- , AdditiveMagma (D r t) (Computation r t (D r t)) r t + +-- , AdditiveAssociative (D r t) r t +-- , AdditiveAssociative (Computation r t (D r t)) r t + +-- , AdditiveCommutative (D r t) r t +-- , AdditiveCommutative (Computation r t (D r t)) r t + +-- , AdditiveInvertible (D r t) r t +-- , AdditiveInvertible (Computation r t (D r t)) r t + +-- , AdditiveIdempotent (D r t) (D r t) r t +-- , AdditiveIdempotent (Computation r t (D r t)) (D r t) r t +-- , AdditiveIdempotent (Computation r t (D r t)) (Computation r t (D r t)) r t +-- , AdditiveIdempotent (D r t) (Computation r t (D r t)) r t + +-- , Additive (D r t) (D r t) r t +-- , Additive (Computation r t (D r t)) (D r t) r t +-- , Additive (Computation r t (D r t)) (Computation r t (D r t)) r t +-- , Additive (D r t) (Computation r t (D r t)) r t + +-- , AdditiveLeftCancellative (D r t) (D r t) r t +-- , AdditiveLeftCancellative (Computation r t (D r t)) (D r t) r t +-- , AdditiveLeftCancellative (Computation r t (D r t)) (Computation r t (D r t)) r t +-- , AdditiveLeftCancellative (D r t) (Computation r t (D r t)) r t + +-- , AdditiveGroup (D r t) (D r t) r t +-- , AdditiveGroup (Computation r t (D r t)) (D r t) r t +-- , AdditiveGroup (Computation r t (D r t)) (Computation r t (D r t)) r t +-- , AdditiveGroup (D r t) (Computation r t (D r t)) r t +-- ) + +-- type MultiplicativeDifferential t r +-- = (MultiplicativeMagma (D r t) (D r t) r t +-- , MultiplicativeMagma (Computation r t (D r t)) (D r t) r t +-- , MultiplicativeMagma (Computation r t (D r t)) (Computation r t (D r t)) r t +-- , MultiplicativeMagma (D r t) (Computation r t (D r t)) r t -type MultiplicativeDifferential t r - = (MultiplicativeMagma (D r t) (D r t) r t - , MultiplicativeMagma (Computation r t (D r t)) (D r t) r t - , MultiplicativeMagma (Computation r t (D r t)) (Computation r t (D r t)) r t - , MultiplicativeMagma (D r t) (Computation r t (D r t)) r t - - , MultiplicativeUnital (D r t) r t - , MultiplicativeUnital (Computation r t (D r t)) r t - - , MultiplicativeAssociative (D r t) r t - , MultiplicativeAssociative (Computation r t (D r t)) r t - - , MultiplicativeCommutative (D r t) r t - , MultiplicativeCommutative (Computation r t (D r t)) r t - - , MultiplicativeInvertible (D r t) r t - , MultiplicativeInvertible (Computation r t (D r t)) r t - - , Multiplicative (D r t) (D r t) r t - , Multiplicative (Computation r t (D r t)) (D r t) r t - , Multiplicative (Computation r t (D r t)) (Computation r t (D r t)) r t - , Multiplicative (D r t) (Computation r t (D r t)) r t - - , MultiplicativeLeftCancellative (D r t) (D r t) r t - , MultiplicativeLeftCancellative (Computation r t (D r t)) (D r t) r t - , MultiplicativeLeftCancellative (Computation r t (D r t)) (Computation r t (D r t)) r t - , MultiplicativeLeftCancellative (D r t) (Computation r t (D r t)) r t - - , MultiplicativeRightCancellative (D r t) (D r t) r t - , MultiplicativeRightCancellative (Computation r t (D r t)) (D r t) r t - , MultiplicativeRightCancellative (Computation r t (D r t)) (Computation r t (D r t)) r t - , MultiplicativeRightCancellative (D r t) (Computation r t (D r t)) r t - - , MultiplicativeGroup (D r t) (D r t) r t - , MultiplicativeGroup (Computation r t (D r t)) (D r t) r t - , MultiplicativeGroup (Computation r t (D r t)) (Computation r t (D r t)) r t - , MultiplicativeGroup (D r t) (Computation r t (D r t)) r t) - -type Differentiable t r - = ( MultiplicativeDifferential t r - , AdditiveDifferentiable t r - , Distribution (D r t) (D r t) r t - , Distribution (Computation r t (D r t)) (D r t) r t - , Distribution (Computation r t (D r t)) (Computation r t (D r t)) r t - , Distribution (D r t) (Computation r t (D r t)) r t - - , Semifield (D r t) (D r t) r t - , Semifield (Computation r t (D r t)) (D r t) r t - , Semifield (Computation r t (D r t)) (Computation r t (D r t)) r t - , Semifield (D r t) (Computation r t (D r t)) r t - - , Field (D r t) (D r t) r t - , Field (Computation r t (D r t)) (D r t) r t - , Field (Computation r t (D r t)) (Computation r t (D r t)) r t - , Field (D r t) (Computation r t (D r t)) r t - - , ExpField (D r t) r t - , ExpField (Computation r t (D r t)) r t - - , BoundedField (D r t) r t - , BoundedField (Computation r t (D r t)) r t - - , TrigField (D r t) r t - , TrigField (Computation r t (D r t)) r t - - , Signed (D r t) r t - , Signed (Computation r t (D r t)) r t - - , Normed (D r t) r t - , Normed (Computation r t (D r t)) r t - - , Metric (D r t) (D r t) r t - , Metric (Computation r t (D r t)) (D r t) r t - , Metric (Computation r t (D r t)) (Computation r t (D r t)) r t - , Metric (D r t) (Computation r t (D r t)) r t - - , Epsilon (D r t) (D r t) r t - , Epsilon (Computation r t (D r t)) (D r t) r t - , Epsilon (Computation r t (D r t)) (Computation r t (D r t)) r t - , Epsilon (D r t) (Computation r t (D r t)) r t - - , Ring (D r t) (D r t) r t - , Ring (Computation r t (D r t)) (D r t) r t - , Ring (Computation r t (D r t)) (Computation r t (D r t)) r t - , Ring (D r t) (Computation r t (D r t)) r t - - , CRing (D r t) (D r t) r t - , CRing (Computation r t (D r t)) (D r t) r t - , CRing (Computation r t (D r t)) (Computation r t (D r t)) r t - , CRing (D r t) (Computation r t (D r t)) r t - - , StarSemiring (D r t) r t - , StarSemiring (Computation r t (D r t)) r t - - , KleeneAlgebra (D r t) (D r t) r t - , KleeneAlgebra (Computation r t (D r t)) (D r t) r t - , KleeneAlgebra (Computation r t (D r t)) (Computation r t (D r t)) r t - , KleeneAlgebra (D r t) (Computation r t (D r t)) r t +-- , MultiplicativeUnital (D r t) r t +-- , MultiplicativeUnital (Computation r t (D r t)) r t - ) +-- , MultiplicativeAssociative (D r t) r t +-- , MultiplicativeAssociative (Computation r t (D r t)) r t + +-- , MultiplicativeCommutative (D r t) r t +-- , MultiplicativeCommutative (Computation r t (D r t)) r t + +-- , MultiplicativeInvertible (D r t) r t +-- , MultiplicativeInvertible (Computation r t (D r t)) r t + +-- , Multiplicative (D r t) (D r t) r t +-- , Multiplicative (Computation r t (D r t)) (D r t) r t +-- , Multiplicative (Computation r t (D r t)) (Computation r t (D r t)) r t +-- , Multiplicative (D r t) (Computation r t (D r t)) r t + +-- , MultiplicativeLeftCancellative (D r t) (D r t) r t +-- , MultiplicativeLeftCancellative (Computation r t (D r t)) (D r t) r t +-- , MultiplicativeLeftCancellative (Computation r t (D r t)) (Computation r t (D r t)) r t +-- , MultiplicativeLeftCancellative (D r t) (Computation r t (D r t)) r t + +-- , MultiplicativeRightCancellative (D r t) (D r t) r t +-- , MultiplicativeRightCancellative (Computation r t (D r t)) (D r t) r t +-- , MultiplicativeRightCancellative (Computation r t (D r t)) (Computation r t (D r t)) r t +-- , MultiplicativeRightCancellative (D r t) (Computation r t (D r t)) r t + +-- , MultiplicativeGroup (D r t) (D r t) r t +-- , MultiplicativeGroup (Computation r t (D r t)) (D r t) r t +-- , MultiplicativeGroup (Computation r t (D r t)) (Computation r t (D r t)) r t +-- , MultiplicativeGroup (D r t) (Computation r t (D r t)) r t) + +-- type Differentiable t r +-- = ( MultiplicativeDifferential t r +-- , AdditiveDifferentiable t r +-- , Distribution (D r t) (D r t) r t +-- , Distribution (Computation r t (D r t)) (D r t) r t +-- , Distribution (Computation r t (D r t)) (Computation r t (D r t)) r t +-- , Distribution (D r t) (Computation r t (D r t)) r t + +-- , Semifield (D r t) (D r t) r t +-- , Semifield (Computation r t (D r t)) (D r t) r t +-- , Semifield (Computation r t (D r t)) (Computation r t (D r t)) r t +-- , Semifield (D r t) (Computation r t (D r t)) r t + +-- , Field (D r t) (D r t) r t +-- , Field (Computation r t (D r t)) (D r t) r t +-- , Field (Computation r t (D r t)) (Computation r t (D r t)) r t +-- , Field (D r t) (Computation r t (D r t)) r t + +-- , ExpField (D r t) r t +-- , ExpField (Computation r t (D r t)) r t + +-- , BoundedField (D r t) r t +-- , BoundedField (Computation r t (D r t)) r t + +-- , TrigField (D r t) r t +-- , TrigField (Computation r t (D r t)) r t + +-- , Signed (D r t) r t +-- , Signed (Computation r t (D r t)) r t + +-- , Normed (D r t) r t +-- , Normed (Computation r t (D r t)) r t + + -- , Metric (D r t) (D r t) r t + -- , Metric (Computation r t (D r t)) (D r t) r t + -- , Metric (Computation r t (D r t)) (Computation r t (D r t)) r t + -- , Metric (D r t) (Computation r t (D r t)) r t + + -- , Epsilon (D r t) (D r t) r t + -- , Epsilon (Computation r t (D r t)) (D r t) r t + -- , Epsilon (Computation r t (D r t)) (Computation r t (D r t)) r t + -- , Epsilon (D r t) (Computation r t (D r t)) r t + + -- , Ring (D r t) (D r t) r t + -- , Ring (Computation r t (D r t)) (D r t) r t + -- , Ring (Computation r t (D r t)) (Computation r t (D r t)) r t + -- , Ring (D r t) (Computation r t (D r t)) r t + + -- , CRing (D r t) (D r t) r t + -- , CRing (Computation r t (D r t)) (D r t) r t + -- , CRing (Computation r t (D r t)) (Computation r t (D r t)) r t + -- , CRing (D r t) (Computation r t (D r t)) r t + + -- , StarSemiring (D r t) r t + -- , StarSemiring (Computation r t (D r t)) r t + + -- , KleeneAlgebra (D r t) (D r t) r t + -- , KleeneAlgebra (Computation r t (D r t)) (D r t) r t + -- , KleeneAlgebra (Computation r t (D r t)) (Computation r t (D r t)) r t + -- , KleeneAlgebra (D r t) (Computation r t (D r t)) r t + + -- ) @@ -179,8 +179,8 @@ t = DR {} -> error "Can't get tangent of a reverse node" -initComp :: (P.RealFrac a)=> ComputationState r a -initComp = ComputationState (Tag 0) (UID 0) M.empty M.empty (1e-6) 1000 +initComp :: forall a r. (P.Fractional a) => ComputationState r a +initComp = ComputationState (Tag 0) (UID 0) M.empty M.empty (1e-6 :: a) 1000 mkForward :: () => Tag -> Tangent r a -> Primal r a -> D r a diff --git a/src/Internal/Internal.hs b/src/Internal/Internal.hs index d33c7d0..e8add2e 100644 --- a/src/Internal/Internal.hs +++ b/src/Internal/Internal.hs @@ -25,17 +25,19 @@ import qualified Data.Map as M (Map, empty, insert, lookup, update, updateLookupWithKey) import Lens.Micro ((%~), (&), (.~), (^.)) import Lens.Micro.TH (makeLenses) -import Prelude hiding (abs, negate, signum, (*), - (+), (-), (/)) -import qualified Protolude as P -import qualified NumHask.Prelude as E - -import Data.Dependent.Sum -import Data.Functor.Identity -import Data.GADT.Compare -import Data.GADT.Compare.TH -import Data.GADT.Show -import Data.GADT.Show.TH +import NumHask.Prelude hiding (State, abs, negate, signum, + (*), (+), (-), (/), Show, show) +import Protolude.Error +import qualified NumHask.Prelude as E +import qualified NumHask.Prelude as P +import GHC.Show +import GHC.Err +-- import Data.Dependent.Sum +-- import Data.Functor.Identity +-- import Data.GADT.Compare +-- import Data.GADT.Compare.TH +-- import Data.GADT.Show +-- import Data.GADT.Show.TH data ComputationState r a = ComputationState @@ -56,10 +58,10 @@ data D r a where DR :: (Show op, Trace op r a) => D r a -> DualTrace op r a -> Tag -> UID -> D r a instance (Show a, Show Tag, Show UID, Show (r a)) => Show (D r a) where - show (D a) = "D " ++ show a - show (Dm a) = "D " ++ show (a) - show (DF p t ti) = "DF " ++ show p ++ show t ++ show ti - show (DR p dt ti uid) = "DR " ++ show p ++ show dt ++ show ti ++ show uid + show (D a) = "D " ++ GHC.Show.show a + show (Dm a) = "D " ++ GHC.Show.show (a) + show (DF p t ti) = "DF " ++ GHC.Show.show p ++ GHC.Show.show t ++ GHC.Show.show ti + show (DR p dt ti uid) = "DR " ++ GHC.Show.show p ++ GHC.Show.show dt ++ GHC.Show.show ti ++ GHC.Show.show uid type Primal r a = D r a type Tangent r a = D r a @@ -195,11 +197,11 @@ class DfDbBin op r a c | a -> c where class (Show op, E.AdditiveBasis r a, E.AdditiveModule r a) => FfBin op a r where rff_bin :: op -> r a -> r a -> r a -- Forward mode function for arrays - rff_bin op _ _ = error $ "array x array operation is not defined for " ++ (show op) + rff_bin op _ _ = GHC.Err.error $ "array x array operation is not defined for " ++ ( GHC.Show.show op) r_ff_bin :: op -> r a -> a -> r a -- For scalar x arrays - r_ff_bin op _ _ = error $ "array x scalar operation is not defined for " ++ (show op) + r_ff_bin op _ _ = GHC.Err.error $ "array x scalar operation is not defined for " ++ ( GHC.Show.show op) _ff_bin :: op -> a -> r a -> r a -- For scalar x arrays - _ff_bin op _ _ = error $ "scalar x array operation is not defined for " ++ (show op) + _ff_bin op _ _ = GHC.Err.error $ "scalar x array operation is not defined for " ++ ( GHC.Show.show op) @@ -295,7 +297,7 @@ class (Show op) => cdf <- df_da op b cp ap at return $ DF cp (cdf) ai EQ -> - error "Forward and reverse AD r cannot run on the same level." + GHC.Err.error "Forward and reverse AD r cannot run on the same level." DR ap _ ai _ -> case b of D _ -> do @@ -306,7 +308,7 @@ class (Show op) => r (fda) (B op a b) ai DF bp bt bi -> case compare ai bi of - EQ -> error "Forward and reverse AD cannot run on the same level." + EQ -> GHC.Err.error "Forward and reverse AD cannot run on the same level." LT -> do cp <- fd_bin op a bp cdf <- df_db op a cp bp bt diff --git a/src/Internal/NumHask/Algebra.hs b/src/Internal/NumHask/Algebra.hs index 635a88b..7dbf8ba 100644 --- a/src/Internal/NumHask/Algebra.hs +++ b/src/Internal/NumHask/Algebra.hs @@ -3,7 +3,7 @@ -- | Algebraic structure module Internal.NumHask.Algebra ( module Internal.NumHask.Algebra.Additive - , module Internal.NumHask.Algebra.Basis + -- , module Internal.NumHask.Algebra.Basis , module Internal.NumHask.Algebra.Distribution , module Internal.NumHask.Algebra.Field -- , module NumHask.Algebra.Integral @@ -12,11 +12,11 @@ module Internal.NumHask.Algebra , module Internal.NumHask.Algebra.Module , module Internal.NumHask.Algebra.Multiplicative , module Internal.NumHask.Algebra.Ring - , module Internal.NumHask.Algebra.Diff + ) where import Internal.NumHask.Algebra.Additive -import Internal.NumHask.Algebra.Basis +-- import Internal.NumHask.Algebra.Basis import Internal.NumHask.Algebra.Distribution import Internal.NumHask.Algebra.Field -- import NumHask.Algebra.Integral @@ -25,4 +25,4 @@ import Internal.NumHask.Algebra.Metric import Internal.NumHask.Algebra.Module import Internal.NumHask.Algebra.Multiplicative import Internal.NumHask.Algebra.Ring -import Internal.NumHask.Algebra.Diff + diff --git a/src/Internal/NumHask/Algebra/.#Additive.hs b/src/Internal/NumHask/Algebra/.#Additive.hs index b228ab5..f858ff5 120000 --- a/src/Internal/NumHask/Algebra/.#Additive.hs +++ b/src/Internal/NumHask/Algebra/.#Additive.hs @@ -1 +1 @@ -timpierson@Tims-MBP-2.lan.48021 \ No newline at end of file +timpierson@Tims-MBP-2.lan.16551 \ No newline at end of file diff --git a/src/Internal/NumHask/Algebra/Additive.hs b/src/Internal/NumHask/Algebra/Additive.hs index 12520b8..13e08d4 100644 --- a/src/Internal/NumHask/Algebra/Additive.hs +++ b/src/Internal/NumHask/Algebra/Additive.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -23,20 +24,35 @@ module Internal.NumHask.Algebra.Additive , AdditiveRightCancellative(..) , AdditiveLeftCancellative(..) , AdditiveGroup(..) + , AdditiveGroupModule(..) + , AdditiveBasis(..) + , AdditiveModule(..) + , Add(..) + , Negate(..) + , AdditiveBasisConstraints ) where import Internal.Internal -import Protolude (Bool (..), Double, Float, Int, Integer, +import NumHask.Prelude (Bool (..), Double, Float, Int, Integer, Show, pure, ($)) -import qualified Protolude as P - -import qualified NumHask.Prelude as E - +import qualified NumHask.Prelude as P +import qualified NumHask.Array as A +import qualified NumHask.Prelude as E + +type AdditiveBasisConstraints r t + = ( E.Num t + , E.AdditiveBasis r t + , E.AdditiveGroupBasis r t + , E.AdditiveGroupModule r t + , E.AdditiveModule r t) -- | 'plus' is used as the operator for the additive magma to distinguish from '+' which, by convention, implies commutativity -- -- > ∀ a,b ∈ A: a `plus` b ∈ A -- -- law is true by construction in Haskell -class AdditiveMagma a b r t | a b -> t, a -> t, b -> t, a -> r, b -> r, a b -> r where -- Fundep: r and t can be determined by a, b, or a and b: scalar ops don't change shape and must have the same representation. +class AdditiveMagma a b r t | a b -> t, a -> t, b -> t + --, a -> r, b -> r + , a b -> r + where -- Fundep: r and t can be determined by a, b, or a and b: scalar ops don't change shape and must have the same representation. plus :: a -> b -> Computation r t (D r t) @@ -164,49 +180,49 @@ data Negate = Negate deriving Show -instance AdditiveMagma (Computation r Float (D r Float)) (Computation r Float (D r Float)) r Float where +instance (AdditiveBasisConstraints r Float) => AdditiveMagma (Computation r Float (D r Float)) (Computation r Float (D r Float)) r Float where plus a b = do aa <- a bb <- b binOp Add aa bb -instance AdditiveMagma (Computation r Float (D r Float)) (D r Float) r Float where +instance (AdditiveBasisConstraints r Float) => AdditiveMagma (Computation r Float (D r Float)) (D r Float) r Float where plus a b = do aa <- a binOp Add aa b -instance AdditiveMagma (D r Float) (Computation r Float (D r Float)) r Float where +instance (AdditiveBasisConstraints r Float) => AdditiveMagma (D r Float) (Computation r Float (D r Float)) r Float where plus a b = do bb <- b binOp Add a bb -instance AdditiveMagma (D r Float) (D r Float) r Float where +instance (AdditiveBasisConstraints r Float) => AdditiveMagma (D r Float) (D r Float) r Float where plus= binOp Add -instance AdditiveMagma (Computation r Double (D r Double)) (Computation r Double (D r Double)) r Double where +instance (AdditiveBasisConstraints r Double) => AdditiveMagma (Computation r Double (D r Double)) (Computation r Double (D r Double)) r Double where plus a b = do aa <- a bb <- b binOp Add aa bb -instance AdditiveMagma (Computation r Double (D r Double)) (D r Double) r Double where +instance (AdditiveBasisConstraints r Double) => AdditiveMagma (Computation r Double (D r Double)) (D r Double) r Double where plus a b = do aa <- a binOp Add aa b -instance AdditiveMagma (D r Double) (Computation r Double (D r Double)) r Double where +instance (AdditiveBasisConstraints r Double) => AdditiveMagma (D r Double) (Computation r Double (D r Double)) r Double where plus a b = do bb <- b binOp Add a bb -instance AdditiveMagma (D r Double) (D r Double) r Double where +instance (AdditiveBasisConstraints r Double) => AdditiveMagma (D r Double) (D r Double) r Double where plus = binOp Add -instance (P.Num a) => BinOp Add a where +instance (E.Additive a) => BinOp Add a where {-# INLINE ff_bin #-} ff_bin _ a b = b P.+ a -instance FfBin Add a r where +instance (E.AdditiveBasis r a, E.AdditiveModule r a) => FfBin Add a r where {-# INLINE rff_bin #-} rff_bin _ a b = a E..+. b {-# INLINE r_ff_bin #-} @@ -223,7 +239,7 @@ instance DfDbBin Add r (D r a) a where {-# INLINE df_db #-} df_db _ _ _ _ bt = pure bt -instance (P.Num a) => DfBin Add r (D r a) (D r a) a where +instance (E.AdditiveBasis r a, E.AdditiveModule r a, E.Num a) => DfBin Add r (D r a) (D r a) a where {-# INLINE fd_bin #-} fd_bin _ a b = binOp Add a b {-# INLINE df_dab #-} @@ -234,101 +250,102 @@ instance Trace Add r a where resetEl (B _ a b) = pure [a, b, a, b] -instance AdditiveUnital (D r Double) r Double where +instance (AdditiveBasisConstraints r Double) => + AdditiveUnital (D r Double) r Double where zero = D 0 -instance AdditiveUnital (D r Float) r Float where +instance (AdditiveBasisConstraints r Float) => AdditiveUnital (D r Float) r Float where zero = D 0 -instance AdditiveUnital (Computation r Double (D r Double)) r Double where +instance (AdditiveBasisConstraints r Double) => AdditiveUnital (Computation r Double (D r Double)) r Double where zero = P.pure P.$ D 0 -instance AdditiveUnital (Computation r Float (D r Float)) r Float where +instance (AdditiveBasisConstraints r Float) => AdditiveUnital (Computation r Float (D r Float)) r Float where zero = P.pure P.$ D 0 -instance AdditiveAssociative (D r Double) r Double +instance (AdditiveBasisConstraints r Double) => AdditiveAssociative (D r Double) r Double -instance AdditiveAssociative (Computation r Double (D r Double)) r Double +instance (AdditiveBasisConstraints r Double) => AdditiveAssociative (Computation r Double (D r Double)) r Double -instance AdditiveAssociative (D r Float) r Float +instance (AdditiveBasisConstraints r Float) => AdditiveAssociative (D r Float) r Float -instance AdditiveAssociative (Computation r Float (D r Float)) r Float +instance (AdditiveBasisConstraints r Float) => AdditiveAssociative (Computation r Float (D r Float)) r Float -instance AdditiveCommutative (D r Double) r Double +instance (AdditiveBasisConstraints r Double) => AdditiveCommutative (D r Double) r Double -instance AdditiveCommutative (D r Float) r Float +instance (AdditiveBasisConstraints r Float) => AdditiveCommutative (D r Float) r Float -instance AdditiveCommutative (Computation r Double (D r Double)) r Double +instance (AdditiveBasisConstraints r Double) => AdditiveCommutative (Computation r Double (D r Double)) r Double -instance AdditiveCommutative (Computation r Float (D r Float)) r Float +instance (AdditiveBasisConstraints r Float) => AdditiveCommutative (Computation r Float (D r Float)) r Float -instance AdditiveInvertible (Computation r Double (D r Double)) r Double where +instance (AdditiveBasisConstraints r Double) => AdditiveInvertible (Computation r Double (D r Double)) r Double where negate a = do aa <- a monOp Negate aa -instance AdditiveInvertible (Computation r Float (D r Float)) r Float where +instance (AdditiveBasisConstraints r Float) => AdditiveInvertible (Computation r Float (D r Float)) r Float where negate a = do aa <- a monOp Negate aa -instance AdditiveInvertible (D r Double) r Double where +instance (AdditiveBasisConstraints r Double) => AdditiveInvertible (D r Double) r Double where negate = monOp Negate -instance AdditiveInvertible (D r Float) r Float where +instance (AdditiveBasisConstraints r Float) => AdditiveInvertible (D r Float) r Float where negate = monOp Negate -instance (P.Num a) => FfMon Negate a where +instance (E.AdditiveInvertible a) => FfMon Negate a where {-# INLINE ff #-} ff _ a = P.negate a -instance (AdditiveInvertible (D r a) r a, P.Num a) => MonOp Negate r a where +instance (E.AdditiveInvertible a, AdditiveInvertible (D r a) r a, E.Num a) => MonOp Negate r a where {-# INLINE fd #-} fd _ a = monOp Negate a {-# INLINE df #-} df _ _ _ at = monOp Negate at -instance (AdditiveInvertible (D r a) r a, P.Num a) => Trace Negate r a where +instance (AdditiveInvertible (D r a) r a, E.Num a) => Trace Negate r a where pushEl (U _ a) dA = do cda <- negate dA pure [(cda, a)] resetEl (U _ a) = pure [a] -instance Additive (D r Double) (D r Double) r Double +instance (AdditiveBasisConstraints r Double) => Additive (D r Double) (D r Double) r Double -instance Additive (Computation r Double (D r Double)) (D r Double) r Double +instance (AdditiveBasisConstraints r Double) => Additive (Computation r Double (D r Double)) (D r Double) r Double -instance Additive (D r Double) (Computation r Double (D r Double)) r Double +instance (AdditiveBasisConstraints r Double) => Additive (D r Double) (Computation r Double (D r Double)) r Double -instance Additive (D r Float) (D r Float) r Float +instance (AdditiveBasisConstraints r Float) => Additive (D r Float) (D r Float) r Float -instance Additive (D r Float) (Computation r Float (D r Float)) r Float +instance (AdditiveBasisConstraints r Float) => Additive (D r Float) (Computation r Float (D r Float)) r Float -instance Additive (Computation r Float (D r Float)) (D r Float) r Float +instance (AdditiveBasisConstraints r Float) => Additive (Computation r Float (D r Float)) (D r Float) r Float -instance Additive (Computation r Double (D r Double)) (Computation r Double (D r Double)) r Double +instance (AdditiveBasisConstraints r Double) => Additive (Computation r Double (D r Double)) (Computation r Double (D r Double)) r Double -instance Additive (Computation r Float (D r Float)) (Computation r Float (D r Float)) r Float +instance (AdditiveBasisConstraints r Float) => Additive (Computation r Float (D r Float)) (Computation r Float (D r Float)) r Float -instance AdditiveGroup (D r Double) (D r Double) r Double +instance (AdditiveBasisConstraints r Double) => AdditiveGroup (D r Double) (D r Double) r Double -instance AdditiveGroup (Computation r Double (D r Double)) (D r Double) r Double +instance (AdditiveBasisConstraints r Double) => AdditiveGroup (Computation r Double (D r Double)) (D r Double) r Double -instance AdditiveGroup (D r Double) (Computation r Double (D r Double)) r Double +instance (AdditiveBasisConstraints r Double) => AdditiveGroup (D r Double) (Computation r Double (D r Double)) r Double -instance AdditiveGroup (D r Float) (D r Float) r Float +instance (AdditiveBasisConstraints r Float) => AdditiveGroup (D r Float) (D r Float) r Float -instance AdditiveGroup (D r Float) (Computation r Float (D r Float)) r Float +instance (AdditiveBasisConstraints r Float) => AdditiveGroup (D r Float) (Computation r Float (D r Float)) r Float -instance AdditiveGroup (Computation r Float (D r Float)) (D r Float) r Float +instance (AdditiveBasisConstraints r Float) => AdditiveGroup (Computation r Float (D r Float)) (D r Float) r Float -instance AdditiveGroup (Computation r Double (D r Double)) (Computation r Double (D r Double)) r Double +instance (AdditiveBasisConstraints r Double) => AdditiveGroup (Computation r Double (D r Double)) (Computation r Double (D r Double)) r Double -instance AdditiveGroup (Computation r Float (D r Float)) (Computation r Float (D r Float)) r Float +instance (AdditiveBasisConstraints r Float) => AdditiveGroup (Computation r Float (D r Float)) (Computation r Float (D r Float)) r Float -- | Additive Module Laws @@ -345,6 +362,74 @@ class (Additive a b r t) => (+.) :: a -> b -> Computation r t (D r t) +instance (AdditiveBasisConstraints (A.Array c s) Double) => + AdditiveModule (A.Array c s) (Computation (A.Array c s) Double (D (A.Array c s) Double)) (D (A.Array c s) Double) Double where + (.+) a b = do + ca <- a + binOp Add ca b + (+.) a b = do + ca <- a + binOp Add ca b + +instance (AdditiveBasisConstraints (A.Array c s) Double) => + AdditiveModule (A.Array c s) (Computation (A.Array c s) Double (D (A.Array c s) Double)) (Computation (A.Array c s) Double (D (A.Array c s) Double)) Double where + (.+) a b = do + ca <- a + cb <- b + binOp Add ca cb + (+.) a b = do + ca <- a + cb <- b + binOp Add ca cb + + +instance (AdditiveBasisConstraints (A.Array c s) Double) => + AdditiveModule (A.Array c s) (D (A.Array c s) Double) (D (A.Array c s) Double) Double where + (.+) a b = binOp Add a b + (+.) a b = binOp Add a b + +instance (AdditiveBasisConstraints (A.Array c s) Double) => + AdditiveModule (A.Array c s) (D (A.Array c s) Double) (Computation (A.Array c s) Double (D (A.Array c s) Double)) Double where + (.+) a b = do + cb <- b + binOp Add a cb + (+.) a b = do + cb <- b + binOp Add a cb + +instance (AdditiveBasisConstraints (A.Array c s) Float) => + AdditiveModule (A.Array c s) (D (A.Array c s) Float) (D (A.Array c s) Float) Float where + (.+) a b = binOp Add a b + (+.) a b = binOp Add a b + +instance (AdditiveBasisConstraints (A.Array c s) Float) => + AdditiveModule (A.Array c s) (D (A.Array c s) Float) (Computation (A.Array c s) Float (D (A.Array c s) Float)) Float where + (.+) a b = do + cb <- b + binOp Add a cb + (+.) a b = do + cb <- b + binOp Add a cb + +instance (AdditiveBasisConstraints (A.Array c s) Float) => + AdditiveModule (A.Array c s) (Computation (A.Array c s) Float (D (A.Array c s) Float)) (D (A.Array c s) Float) Float where + (.+) a b = do + ca <- a + binOp Add ca b + (+.) a b = do + ca <- a + binOp Add ca b + +instance (AdditiveBasisConstraints (A.Array c s) Float) => + AdditiveModule (A.Array c s) (Computation (A.Array c s) Float (D (A.Array c s) Float)) (Computation (A.Array c s) Float (D (A.Array c s) Float)) Float where + (.+) a b = do + ca <- a + cb <- b + binOp Add ca cb + (+.) a b = do + ca <- a + cb <- b + binOp Add ca cb -- | Subtraction Module Laws -- -- > (a + b) .- c == a + (b .- c) @@ -358,6 +443,89 @@ class (AdditiveGroup a b r t) => infixl 6 -. (-.) :: a -> b -> Computation r t (D r t) + +instance (AdditiveBasisConstraints (A.Array c s) Float) => + AdditiveGroupModule (A.Array c s) (D (A.Array c s) Float) (D (A.Array c s) Float) Float where + (.-) a b = do + cb <- (negate b) + binOp Add a cb + (-.) a b = do + cb <- negate b + binOp Add a cb + +instance (AdditiveBasisConstraints (A.Array c s) Float) => + AdditiveGroupModule (A.Array c s) (D (A.Array c s) Float) (Computation (A.Array c s) Float (D (A.Array c s) Float)) Float where + (.-) a b = do + cb <- negate b + binOp Add a cb + (-.) a b = do + cb <- negate b + binOp Add a cb + +instance (AdditiveBasisConstraints (A.Array c s) Float) => + AdditiveGroupModule (A.Array c s) (Computation (A.Array c s) Float (D (A.Array c s) Float)) (D (A.Array c s) Float) Float where + (.-) a b = do + ca <- a + cb <- negate b + binOp Add ca cb + (-.) a b = do + ca <- a + cb <- negate b + binOp Add ca cb + +instance (AdditiveBasisConstraints (A.Array c s) Float) => + AdditiveGroupModule (A.Array c s) (Computation (A.Array c s) Float (D (A.Array c s) Float)) (Computation (A.Array c s) Float (D (A.Array c s) Float)) Float where + (.-) a b = do + ca <- a + cb <- negate b + binOp Add ca cb + (-.) a b = do + ca <- a + cb <- negate b + binOp Add ca cb + + + +instance (AdditiveBasisConstraints (A.Array c s) Double) => + AdditiveGroupModule (A.Array c s) (D (A.Array c s) Double) (D (A.Array c s) Double) Double where + (.-) a b = do + cb <- (negate b) + binOp Add a cb + (-.) a b = do + cb <- negate b + binOp Add a cb + +instance (AdditiveBasisConstraints (A.Array c s) Double) => + AdditiveGroupModule (A.Array c s) (D (A.Array c s) Double) (Computation (A.Array c s) Double (D (A.Array c s) Double)) Double where + (.-) a b = do + cb <- negate b + binOp Add a cb + (-.) a b = do + cb <- negate b + binOp Add a cb + +instance (AdditiveBasisConstraints (A.Array c s) Double) => + AdditiveGroupModule (A.Array c s) (Computation (A.Array c s) Double (D (A.Array c s) Double)) (D (A.Array c s) Double) Double where + (.-) a b = do + ca <- a + cb <- negate b + binOp Add ca cb + (-.) a b = do + ca <- a + cb <- negate b + binOp Add ca cb + +instance (AdditiveBasisConstraints (A.Array c s) Double) => + AdditiveGroupModule (A.Array c s) (Computation (A.Array c s) Double (D (A.Array c s) Double)) (Computation (A.Array c s) Double (D (A.Array c s) Double)) Double where + (.-) a b = do + ca <- a + cb <- negate b + binOp Add ca cb + (-.) a b = do + ca <- a + cb <- negate b + binOp Add ca cb + -- | element by element addition -- -- > (a .+. b) .+. c == a .+. (b .+. c) @@ -369,6 +537,61 @@ class (Additive a b r t) => infixl 7 .+. (.+.) :: a -> b -> Computation r t (D r t) +instance (AdditiveBasisConstraints (A.Array c s) Double) => + AdditiveBasis (A.Array c s) (D (A.Array c s) Double) (D (A.Array c s) Double) Double where + (.+.) a b = + binOp Add a b + + +instance (AdditiveBasisConstraints (A.Array c s) Double) => + AdditiveBasis (A.Array c s) (D (A.Array c s) Double) (Computation (A.Array c s) Double (D (A.Array c s) Double)) Double where + (.+.) a b = do + cb <- b + binOp Add a cb + + +instance (AdditiveBasisConstraints (A.Array c s) Double) => + AdditiveBasis (A.Array c s) (Computation (A.Array c s) Double (D (A.Array c s) Double)) (D (A.Array c s) Double) Double where + (.+.) a b = do + ca <- a + binOp Add ca b + + +instance (AdditiveBasisConstraints (A.Array c s) Double) => + AdditiveBasis (A.Array c s) (Computation (A.Array c s) Double (D (A.Array c s) Double)) (Computation (A.Array c s) Double (D (A.Array c s) Double)) Double where + (.+.) a b = do + ca <- a + cb <- b + binOp Add ca cb + + +instance (AdditiveBasisConstraints (A.Array c s) Float) => + AdditiveBasis (A.Array c s) (D (A.Array c s) Float) (D (A.Array c s) Float) Float where + (.+.) a b = + binOp Add a b + + +instance (AdditiveBasisConstraints (A.Array c s) Float) => + AdditiveBasis (A.Array c s) (D (A.Array c s) Float) (Computation (A.Array c s) Float (D (A.Array c s) Float)) Float where + (.+.) a b = do + cb <- b + binOp Add a cb + + +instance (AdditiveBasisConstraints (A.Array c s) Float) => + AdditiveBasis (A.Array c s) (Computation (A.Array c s) Float (D (A.Array c s) Float)) (D (A.Array c s) Float) Float where + (.+.) a b = do + ca <- a + binOp Add ca b + + +instance (AdditiveBasisConstraints (A.Array c s) Float) => + AdditiveBasis (A.Array c s) (Computation (A.Array c s) Float (D (A.Array c s) Float)) (Computation (A.Array c s) Float (D (A.Array c s) Float)) Float where + (.+.) a b = do + ca <- a + cb <- b + binOp Add ca cb + -- | element by element subtraction @@ -378,3 +601,62 @@ class (AdditiveGroup a b r t ) => AdditiveGroupBasis r a b t where infixl 6 .-. (.-.) :: a -> b -> Computation r t (D r t) + +instance (AdditiveBasisConstraints (A.Array c s) Float) => + AdditiveGroupBasis (A.Array c s) (D (A.Array c s) Float) (D (A.Array c s) Float) Float where + (.-.) a b = do + cb <- negate b + binOp Add a cb + + +instance (AdditiveBasisConstraints (A.Array c s) Float) => + AdditiveGroupBasis (A.Array c s) (D (A.Array c s) Float) (Computation (A.Array c s) Float (D (A.Array c s) Float)) Float where + (.-.) a b = do + cb <- negate b + binOp Add a cb + + +instance (AdditiveBasisConstraints (A.Array c s) Float) => + AdditiveGroupBasis (A.Array c s) (Computation (A.Array c s) Float (D (A.Array c s) Float)) (D (A.Array c s) Float) Float where + (.-.) a b = do + ca <- a + cb <- negate b + binOp Add ca cb + + +instance (AdditiveBasisConstraints (A.Array c s) Float) => + AdditiveGroupBasis (A.Array c s) (Computation (A.Array c s) Float (D (A.Array c s) Float)) (Computation (A.Array c s) Float (D (A.Array c s) Float)) Float where + (.-.) a b = do + ca <- a + cb <- negate b + binOp Add ca cb + + +instance (AdditiveBasisConstraints (A.Array c s) Double) => + AdditiveGroupBasis (A.Array c s) (D (A.Array c s) Double) (D (A.Array c s) Double) Double where + (.-.) a b = do + cb <- negate b + binOp Add a cb + + +instance (AdditiveBasisConstraints (A.Array c s) Double) => + AdditiveGroupBasis (A.Array c s) (D (A.Array c s) Double) (Computation (A.Array c s) Double (D (A.Array c s) Double)) Double where + (.-.) a b = do + cb <- negate b + binOp Add a cb + + +instance (AdditiveBasisConstraints (A.Array c s) Double) => + AdditiveGroupBasis (A.Array c s) (Computation (A.Array c s) Double (D (A.Array c s) Double)) (D (A.Array c s) Double) Double where + (.-.) a b = do + ca <- a + cb <- negate b + binOp Add ca cb + + +instance (AdditiveBasisConstraints (A.Array c s) Double) => + AdditiveGroupBasis (A.Array c s) (Computation (A.Array c s) Double (D (A.Array c s) Double)) (Computation (A.Array c s) Double (D (A.Array c s) Double)) Double where + (.-.) a b = do + ca <- a + cb <- negate b + binOp Add ca cb diff --git a/src/Internal/NumHask/Algebra/Basis.hs b/src/Internal/NumHask/Algebra/Basis.hs deleted file mode 100644 index 2c8c41e..0000000 --- a/src/Internal/NumHask/Algebra/Basis.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# OPTIONS_GHC -Wall #-} - --- | Element-by-element operation for 'Representable's -module Internal.NumHask.Algebra.Basis - ( AdditiveBasis(..) - , AdditiveGroupBasis(..) - , MultiplicativeBasis(..) - , MultiplicativeGroupBasis(..) - ) where - -import Internal.NumHask.Algebra.Additive -import Internal.NumHask.Algebra.Multiplicative -import Internal.NumHask.Algebra.Module -import Internal.Internal - - - - - - - diff --git a/src/Internal/NumHask/Algebra/Diff.hs b/src/Internal/NumHask/Algebra/Diff.hs deleted file mode 100644 index 71c9919..0000000 --- a/src/Internal/NumHask/Algebra/Diff.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# OPTIONS_GHC -Wall #-} - -module Internal.NumHask.Algebra.Diff - ( module Internal.NumHask.Algebra.Diff - ) where - -import Internal.NumHask.Algebra.Additive -import Internal.NumHask.Algebra.Basis -import Internal.NumHask.Algebra.Distribution -import Internal.NumHask.Algebra.Field -import Internal.NumHask.Algebra.Magma -import Internal.NumHask.Algebra.Metric -import Internal.NumHask.Algebra.Module -import Internal.NumHask.Algebra.Multiplicative -import Internal.NumHask.Algebra.Ring -import Internal.NumHask.Algebra.Singleton -import Internal.Internal -import Protolude (Bool (..), Double, Float, Int, Integer, - Show, pure, ($), (==), (<=), (>=), (<), (>), (&&)) -import qualified Protolude as P - - - - - - - - - - diff --git a/src/Internal/NumHask/Algebra/Distribution.hs b/src/Internal/NumHask/Algebra/Distribution.hs index ba16b70..8d08d43 100644 --- a/src/Internal/NumHask/Algebra/Distribution.hs +++ b/src/Internal/NumHask/Algebra/Distribution.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -11,7 +12,7 @@ module Internal.NumHask.Algebra.Distribution import Internal.Internal import Internal.NumHask.Algebra.Additive import Internal.NumHask.Algebra.Multiplicative -import Protolude (Double, Float) +import NumHask.Prelude (Double, Float) -- | Distribution (and annihilation) laws -- @@ -22,20 +23,20 @@ import Protolude (Double, Float) class (Additive a b r t, MultiplicativeMagma a b r t) => Distribution a b r t -instance Distribution (D r Double) (D r Double) r Double +instance (BasisConstraints r Double ) => Distribution (D r Double) (D r Double) r Double -instance Distribution (Computation r Double (D r Double)) (D r Double) r Double +instance (BasisConstraints r Double ) => Distribution (Computation r Double (D r Double)) (D r Double) r Double -instance Distribution (D r Double) (Computation r Double (D r Double)) r Double +instance (BasisConstraints r Double ) => Distribution (D r Double) (Computation r Double (D r Double)) r Double -instance Distribution (D r Float) (D r Float) r Float +instance (BasisConstraints r Float ) => Distribution (D r Float) (D r Float) r Float -instance Distribution (D r Float) (Computation r Float (D r Float)) r Float +instance (BasisConstraints r Float ) => Distribution (D r Float) (Computation r Float (D r Float)) r Float -instance Distribution (Computation r Float (D r Float)) (D r Float) r Float +instance (BasisConstraints r Float ) => Distribution (Computation r Float (D r Float)) (D r Float) r Float -instance Distribution (Computation r Double (D r Double)) (Computation r Double (D r Double)) r Double +instance (BasisConstraints r Double ) => Distribution (Computation r Double (D r Double)) (Computation r Double (D r Double)) r Double -instance Distribution (Computation r Float (D r Float)) (Computation r Float (D r Float)) r Float +instance (BasisConstraints r Float ) => Distribution (Computation r Float (D r Float)) (Computation r Float (D r Float)) r Float diff --git a/src/Internal/NumHask/Algebra/Field.hs b/src/Internal/NumHask/Algebra/Field.hs index 5a68ad6..4e4c996 100644 --- a/src/Internal/NumHask/Algebra/Field.hs +++ b/src/Internal/NumHask/Algebra/Field.hs @@ -28,11 +28,9 @@ import Internal.Internal import Internal.NumHask.Algebra.Additive import Internal.NumHask.Algebra.Multiplicative import Internal.NumHask.Algebra.Ring -import Protolude (Bool, Double, Float) -import Protolude (pure, ($), Show) -import qualified Protolude as P - - +import NumHask.Prelude (Bool, Double, Float) +import NumHask.Prelude (pure, ($), Show) +import qualified NumHask.Prelude as P -- | A Semifield is a Field without Commutative Multiplication. class (MultiplicativeInvertible a r t, Ring a b r t) => @@ -319,40 +317,40 @@ data ATan = ATan deriving Show data SinH = SinH deriving Show data CosH = CosH deriving Show -instance Semifield (D r Double) (D r Double) r Double +instance (BasisConstraints r Double) => Semifield (D r Double) (D r Double) r Double -instance Semifield (Computation r Double (D r Double)) (D r Double) r Double +instance (BasisConstraints r Double) => Semifield (Computation r Double (D r Double)) (D r Double) r Double -instance Semifield (D r Double) (Computation r Double (D r Double)) r Double +instance (BasisConstraints r Double) => Semifield (D r Double) (Computation r Double (D r Double)) r Double -instance Semifield (D r Float) (D r Float) r Float +instance (BasisConstraints r Float) => Semifield (D r Float) (D r Float) r Float -instance Semifield (D r Float) (Computation r Float (D r Float)) r Float +instance (BasisConstraints r Float) => Semifield (D r Float) (Computation r Float (D r Float)) r Float -instance Semifield (Computation r Float (D r Float)) (D r Float) r Float +instance (BasisConstraints r Float) => Semifield (Computation r Float (D r Float)) (D r Float) r Float -instance Semifield (Computation r Double (D r Double)) (Computation r Double (D r Double)) r Double +instance (BasisConstraints r Double) => Semifield (Computation r Double (D r Double)) (Computation r Double (D r Double)) r Double -instance Semifield (Computation r Float (D r Float)) (Computation r Float (D r Float)) r Float +instance (BasisConstraints r Float) => Semifield (Computation r Float (D r Float)) (Computation r Float (D r Float)) r Float -instance Field (D r Double) (D r Double) r Double +instance (BasisConstraints r Double) => Field (D r Double) (D r Double) r Double -instance Field (Computation r Double (D r Double)) (D r Double) r Double +instance (BasisConstraints r Double) => Field (Computation r Double (D r Double)) (D r Double) r Double -instance Field (D r Double) (Computation r Double (D r Double)) r Double +instance (BasisConstraints r Double) => Field (D r Double) (Computation r Double (D r Double)) r Double -instance Field (D r Float) (D r Float) r Float +instance (BasisConstraints r Float) => Field (D r Float) (D r Float) r Float -instance Field (D r Float) (Computation r Float (D r Float)) r Float +instance (BasisConstraints r Float) => Field (D r Float) (Computation r Float (D r Float)) r Float -instance Field (Computation r Float (D r Float)) (D r Float) r Float +instance (BasisConstraints r Float) => Field (Computation r Float (D r Float)) (D r Float) r Float -instance Field (Computation r Double (D r Double)) (Computation r Double (D r Double)) r Double +instance (BasisConstraints r Double) => Field (Computation r Double (D r Double)) (Computation r Double (D r Double)) r Double -instance Field (Computation r Float (D r Float)) (Computation r Float (D r Float)) r Float +instance (BasisConstraints r Float) => Field (Computation r Float (D r Float)) (Computation r Float (D r Float)) r Float -instance ExpField (Computation r Double (D r Double)) r Double where +instance (BasisConstraints r Double) => ExpField (Computation r Double (D r Double)) r Double where log a = do aa <- a monOp Log aa @@ -360,7 +358,7 @@ instance ExpField (Computation r Double (D r Double)) r Double where aa <- a monOp Exp aa -instance ExpField (Computation r Float (D r Float)) r Float where +instance (BasisConstraints r Float) => ExpField (Computation r Float (D r Float)) r Float where log a = do aa <- a monOp Log aa @@ -368,11 +366,11 @@ instance ExpField (Computation r Float (D r Float)) r Float where aa <- a monOp Exp aa -instance ExpField (D r Double) r Double where +instance (BasisConstraints r Double) => ExpField (D r Double) r Double where log = monOp Log exp = monOp Exp -instance ExpField (D r Float) r Float where +instance (BasisConstraints r Float) => ExpField (D r Float) r Float where log = monOp Log exp = monOp Exp @@ -380,7 +378,7 @@ instance ExpField (D r Float) r Float where -- | Exponentiation -- >>> compute $ diff' (\x -> x + ) a -- (D 6.0,D 1.0) -instance ( P.Floating t +instance ( P.ExpField t , ExpField (D r t) r t , MultiplicativeGroup (D r t) (Computation r t (D r t)) r t , ExpField (Computation r t (D r t)) r t @@ -393,7 +391,7 @@ instance ( P.Floating t {-# INLINE df #-} df _ cp ap at = at / (ap * (log10Val)) -instance (P.Floating t) => FfMon Exp t where +instance (P.ExpField t) => FfMon Exp t where {-# INLINE ff #-} ff _ a = P.exp a @@ -404,7 +402,7 @@ instance (MultiplicativeGroup (D r t) (D r t) r t) => Trace Exp r t where resetEl (U _ a) = pure [a] -instance ( P.Floating t +instance ( P.ExpField t , ExpField (D r t) r t , MultiplicativeGroup (D r t) (Computation r t (D r t)) r t , ExpField (Computation r t (D r t)) r t @@ -418,7 +416,7 @@ instance ( P.Floating t df _ cp ap at = at / ap -instance (P.Floating a) => FfMon Log a where +instance (P.ExpField a) => FfMon Log a where {-# INLINE ff #-} ff _ a = P.log a @@ -431,6 +429,7 @@ instance (MultiplicativeGroup (D r t) (D r t) r t) => Trace Log r t where instance ( BoundedField (D r Double) r Double + , BasisConstraints r Double , ExpField (Computation r Double (D r Double)) r Double , Additive ((D r Double)) ((D r Double)) r Double , Additive (D r Double) ((D r Double)) r Double @@ -462,6 +461,7 @@ instance ( BoundedField (D r Double) r Double instance (BoundedField (D r Float) r Float + , BasisConstraints r Float , ExpField (Computation r Float (D r Float)) r Float , Additive (D r Float) (D r Float) r Float , Additive (D r Float) (D r Float) r Float @@ -504,6 +504,7 @@ instance ( BoundedField (D r t) r t , ExpField (Computation r t (D r t)) r t , a ~ Computation r Double (D r Double) , t ~ Double + , BasisConstraints r Double ) => TrigField (Computation r Double (D r Double)) r Double where @@ -555,6 +556,7 @@ instance ( BoundedField (D r t) r t , ExpField (Computation r t (D r t)) r t , a ~ Computation r Float (D r Float) , t ~ Float + , BasisConstraints r Float ) => TrigField (Computation r Float (D r Float)) r Float where @@ -591,7 +593,7 @@ instance ( BoundedField (D r t) r t (log (z + (one :: D r Float)) - log (z - (one :: D r Float))) instance (TrigField (D r t) r t - , P.Floating t + , P.TrigField t , Multiplicative (D r t) (Computation r t (D r t)) r t , MonOp Cos r t , Trace Cos r t @@ -604,7 +606,7 @@ instance (TrigField (D r t) r t df _ _ ap at = at * (monOp Cos ap) instance ( - P.Floating a + P.TrigField a ) => FfMon Sin a where {-# INLINE ff #-} @@ -621,7 +623,7 @@ instance (TrigField (D r t) r t, Multiplicative (D r t) (Computation r t (D r t instance (TrigField (D r t) r t - , P.Floating t + , P.TrigField t , Multiplicative (D r t) (Computation r t (D r t)) r t , Multiplicative (Computation r t (D r t)) (Computation r t (D r t)) r t , MonOp Cos r t @@ -637,7 +639,7 @@ instance (TrigField (D r t) r t -instance (P.Floating a +instance (P.TrigField a ) => FfMon Cos a where {-# INLINE ff #-} @@ -656,7 +658,7 @@ instance (AdditiveInvertible (Computation r t (D r t)) r t instance (TrigField (D r t) r t - , P.Floating t + , P.TrigField t , Multiplicative (D r t) (Computation r t (D r t)) r t , Multiplicative (Computation r t (D r t)) (Computation r t (D r t)) r t , MultiplicativeGroup (D r t) (Computation r t (D r t)) r t @@ -671,7 +673,7 @@ instance (TrigField (D r t) r t {-# INLINE df #-} df _ _ ap at = at / sqrt ((one :: D r t) - ap * ap) -instance (P.Floating a) => FfMon ASin a where +instance (P.TrigField a) => FfMon ASin a where {-# INLINE ff #-} ff _ a = P.asin a @@ -692,7 +694,7 @@ instance (AdditiveInvertible (Computation r t (D r t)) r t instance (TrigField (D r t) r t - , P.Floating t + , P.TrigField t , Multiplicative (D r t) (Computation r t (D r t)) r t , Multiplicative (Computation r t (D r t)) (Computation r t (D r t)) r t , MultiplicativeGroup (D r t) (Computation r t (D r t)) r t @@ -707,7 +709,7 @@ instance (TrigField (D r t) r t {-# INLINE df #-} df _ _ ap at = negate $ at / sqrt ((one :: D r t) - ap * ap) -instance (P.Floating a) => FfMon ACos a where +instance (P.TrigField a) => FfMon ACos a where {-# INLINE ff #-} ff _ a = P.acos a @@ -728,7 +730,7 @@ instance (AdditiveInvertible (Computation r t (D r t)) r t instance (TrigField (D r t) r t - , P.Floating t + , P.TrigField t , Multiplicative (D r t) (Computation r t (D r t)) r t , Multiplicative (Computation r t (D r t)) (Computation r t (D r t)) r t , MultiplicativeGroup (D r t) (Computation r t (D r t)) r t @@ -745,7 +747,7 @@ instance (TrigField (D r t) r t -instance (P.Floating a) => FfMon ATan a where +instance (P.TrigField a) => FfMon ATan a where {-# INLINE ff #-} ff _ a = P.atan a @@ -763,7 +765,7 @@ instance (AdditiveInvertible (Computation r t (D r t)) r t resetEl (U _ a) = pure [a] instance ( TrigField (D r t) r t - , P.Floating t + , P.TrigField t , Multiplicative (D r t) (Computation r t (D r t)) r t , Multiplicative (Computation r t (D r t)) (Computation r t (D r t)) r t , MultiplicativeGroup (D r t) (Computation r t (D r t)) r t @@ -778,7 +780,7 @@ instance ( TrigField (D r t) r t {-# INLINE df #-} df _ _ ap at = at * (cosh ap) -instance (P.Floating a) => FfMon SinH a where +instance (P.TrigField a) => FfMon SinH a where {-# INLINE ff #-} ff _ a = P.sinh a @@ -798,7 +800,7 @@ instance (AdditiveInvertible (Computation r t (D r t)) r t resetEl (U _ a) = pure [a] instance (TrigField (D r t) r t - , P.Floating t + , P.TrigField t , Multiplicative (D r t) (Computation r t (D r t)) r t , Multiplicative (Computation r t (D r t)) (Computation r t (D r t)) r t , MultiplicativeGroup (D r t) (Computation r t (D r t)) r t @@ -813,7 +815,7 @@ instance (TrigField (D r t) r t {-# INLINE df #-} df _ _ ap at = at * (sinh ap) -instance (P.Floating a ) => FfMon CosH a where +instance (P.TrigField a ) => FfMon CosH a where {-# INLINE ff #-} ff _ a = P.cosh a diff --git a/src/Internal/NumHask/Algebra/Metric.hs b/src/Internal/NumHask/Algebra/Metric.hs index 09a2804..0d34af7 100644 --- a/src/Internal/NumHask/Algebra/Metric.hs +++ b/src/Internal/NumHask/Algebra/Metric.hs @@ -18,9 +18,9 @@ module Internal.NumHask.Algebra.Metric import Internal.NumHask.Algebra.Additive import Internal.NumHask.Algebra.Field import Internal.NumHask.Algebra.Multiplicative -import qualified Protolude as P +import qualified NumHask.Prelude as P import Internal.Internal -import Protolude +import NumHask.Prelude (Bool(..), Double, Eq(..), Float, Int, Integer, Ord(..), ($), (&&)) -- | 'signum' from base is not an operator replicated in numhask, being such a very silly name, and preferred is the much more obvious 'sign'. Compare with 'Norm' and 'Banach' where there is a change in codomain @@ -34,9 +34,6 @@ class (MultiplicativeUnital a r t) => abs :: a -> Computation r t (D r t) - - - -- | Like Signed, except the codomain can be different to the domain. class Normed a r t | a -> r, a -> t where size :: a -> Computation r t (D r t) @@ -76,21 +73,21 @@ data Abs = Abs deriving P.Show -instance Signed (D r Double) r Double where +instance (BasisConstraints r Double) => Signed (D r Double) r Double where sign a = if a >= zero then one else negate (one :: D r Double) abs = monOp Abs -instance Signed (D r Float) r Float where +instance (BasisConstraints r Float) => Signed (D r Float) r Float where sign a = if a >= zero then one else negate (one :: D r Float) abs = monOp Abs -instance Signed (Computation r Double (D r Double)) r Double where +instance (BasisConstraints r Double) => Signed (Computation r Double (D r Double)) r Double where sign a = do ca <- a if ca >= (zero :: (D r Double)) @@ -102,7 +99,7 @@ instance Signed (Computation r Double (D r Double)) r Double where -instance Signed (Computation r Float (D r Float)) r Float where +instance (BasisConstraints r Float) => Signed (Computation r Float (D r Float)) r Float where sign a = do ca <- a if ca >= zero @@ -116,7 +113,7 @@ instance Signed (Computation r Float (D r Float)) r Float where -- | Abs -- compute $ diff' abs a -- (D 3.0, D 1.0) -instance (P.Num a, Signed (D r a) r a, AdditiveUnital (D r a) r a, AdditiveInvertible (D r a) r a, P.Ord a, Multiplicative (D r a) (Computation r a (D r a)) r a +instance (P.AdditiveInvertible a, P.Num a, Signed (D r a) r a, AdditiveUnital (D r a) r a, AdditiveInvertible (D r a) r a, P.Ord a, Multiplicative (D r a) (Computation r a (D r a)) r a ) => MonOp Abs r a where @@ -128,7 +125,7 @@ instance (P.Num a, Signed (D r a) r a, AdditiveUnital (D r a) r a, AdditiveInver {-# INLINE df #-} df _ _ ap at = at * sign ap -instance (P.Num a) => FfMon Abs a where +instance (P.Signed a) => FfMon Abs a where {-# INLINE ff #-} ff _ a = P.abs a @@ -140,44 +137,44 @@ instance (Signed (D r a) r a, Multiplicative (D r a) (D r a) r a) => Trace Abs P.pure [(dl, a)] resetEl (U _ a ) = P.pure [a] -instance Normed (D r Double) r Double where +instance (BasisConstraints r Double) => Normed (D r Double) r Double where size = abs -instance Normed (D r Float) r Float where +instance (BasisConstraints r Float) => Normed (D r Float) r Float where size = abs -instance Normed (Computation r Double (D r Double)) r Double where +instance (BasisConstraints r Double) => Normed (Computation r Double (D r Double)) r Double where size = abs -instance Normed (Computation r Float (D r Float)) r Float where +instance (BasisConstraints r Float) => Normed (Computation r Float (D r Float)) r Float where size = abs -instance Metric (D r Double) (D r Double) r Double where +instance (BasisConstraints r Double) => Metric (D r Double) (D r Double) r Double where distance a b = abs (a - b) -instance Metric (D r Float) (D r Float) r Float where +instance (BasisConstraints r Float) => Metric (D r Float) (D r Float) r Float where distance a b = abs (a - b) -instance Metric (Computation r Double (D r Double)) (Computation r Double (D r Double)) r Double where +instance (BasisConstraints r Double) => Metric (Computation r Double (D r Double)) (Computation r Double (D r Double)) r Double where distance a b = abs (a - b) -instance Metric (Computation r Float (D r Float)) (Computation r Float (D r Float)) r Float where +instance (BasisConstraints r Float) => Metric (Computation r Float (D r Float)) (Computation r Float (D r Float)) r Float where distance a b = abs (a - b) -instance Metric (D r Double) (Computation r Double (D r Double)) r Double where +instance (BasisConstraints r Double) => Metric (D r Double) (Computation r Double (D r Double)) r Double where distance a b = abs (a - b) -instance Metric (D r Float) (Computation r Float (D r Float)) r Float where +instance (BasisConstraints r Float) => Metric (D r Float) (Computation r Float (D r Float)) r Float where distance a b = abs (a - b) -instance Metric (Computation r Double (D r Double)) (D r Double) r Double where +instance (BasisConstraints r Double) => Metric (Computation r Double (D r Double)) (D r Double) r Double where distance a b = abs (a - b) -instance Metric (Computation r Float (D r Float)) (D r Float) r Float where +instance (BasisConstraints r Float) => Metric (Computation r Float (D r Float)) (D r Float) r Float where distance a b = abs (a - b) -instance (P.Eq (Computation r Double (D r Double))) => Epsilon (D r Double) (D r Double) r Double where +instance (P.Eq (Computation r Double (D r Double)), BasisConstraints r Double) => Epsilon (D r Double) (D r Double) r Double where nearZero a = do ca <- abs a P.pure (ca <= (D 1e-12 :: D r Double)) @@ -195,7 +192,7 @@ instance (P.Eq (Computation r Double (D r Double))) => Epsilon (D r Double) (D r P.pure $ P.not na P.|| pa -instance (P.Eq (Computation r Float (D r Float))) => Epsilon (D r Float) (D r Float) r Float where +instance (P.Eq (Computation r Float (D r Float)), BasisConstraints r Float) => Epsilon (D r Float) (D r Float) r Float where nearZero a = do ca <- abs a P.pure (ca <= (D 1e-6 :: D r Float)) @@ -212,7 +209,7 @@ instance (P.Eq (Computation r Float (D r Float))) => Epsilon (D r Float) (D r Fl pa <- positive a P.pure $ P.not na P.|| pa -instance (P.Eq (Computation r Float (D r Float))) => Epsilon (Computation r Float (D r Float)) (Computation r Float (D r Float)) r Float where +instance (P.Eq (Computation r Float (D r Float)), BasisConstraints r Float) => Epsilon (Computation r Float (D r Float)) (Computation r Float (D r Float)) r Float where nearZero a = do ca <- abs a P.pure (ca <= (D 1e-6 :: D r Float)) @@ -229,7 +226,7 @@ instance (P.Eq (Computation r Float (D r Float))) => Epsilon (Computation r Floa -instance (P.Eq (Computation r Double (D r Double))) => Epsilon (D r Double) (Computation r Double (D r Double)) r Double where +instance (P.Eq (Computation r Double (D r Double)), BasisConstraints r Double) => Epsilon (D r Double) (Computation r Double (D r Double)) r Double where nearZero a = do ca <- abs a P.pure (ca <= (D 1e-12 :: D r Double)) @@ -246,7 +243,7 @@ instance (P.Eq (Computation r Double (D r Double))) => Epsilon (D r Double) (Com pa <- positive a P.pure $ P.not na P.|| pa -instance (P.Eq (Computation r Float (D r Float))) => Epsilon (D r Float) (Computation r Float (D r Float)) r Float where +instance (P.Eq (Computation r Float (D r Float)), BasisConstraints r Float) => Epsilon (D r Float) (Computation r Float (D r Float)) r Float where nearZero a = do ca <- abs a P.pure (ca <= (D 1e-6 :: D r Float)) @@ -266,7 +263,7 @@ instance (P.Eq (Computation r Float (D r Float))) => Epsilon (D r Float) (Comput -instance (P.Eq (Computation r Double (D r Double))) => Epsilon (Computation r Double (D r Double)) (D r Double) r Double where +instance (P.Eq (Computation r Double (D r Double)),BasisConstraints r Double) => Epsilon (Computation r Double (D r Double)) (D r Double) r Double where nearZero a = do ca <- abs a P.pure (ca <= (D 1e-12 :: D r Double)) @@ -281,7 +278,7 @@ instance (P.Eq (Computation r Double (D r Double))) => Epsilon (Computation r Do pa <- positive a P.pure $ P.not na P.|| pa -instance (P.Eq (Computation r Double (D r Double))) => Epsilon (Computation r Double (D r Double)) (Computation r Double (D r Double)) r Double where +instance (P.Eq (Computation r Double (D r Double)), BasisConstraints r Double) => Epsilon (Computation r Double (D r Double)) (Computation r Double (D r Double)) r Double where nearZero a = do ca <- abs a P.pure (ca <= (D 1e-12 :: D r Double)) @@ -297,7 +294,7 @@ instance (P.Eq (Computation r Double (D r Double))) => Epsilon (Computation r Do P.pure $ P.not na P.|| pa -instance (P.Eq (Computation r Float (D r Float))) => Epsilon (Computation r Float (D r Float)) (D r Float) r Float where +instance (P.Eq (Computation r Float (D r Float)), BasisConstraints r Float) => Epsilon (Computation r Float (D r Float)) (D r Float) r Float where nearZero a = do ca <- abs a P.pure (ca <= (D 1e-6 :: D r Float)) diff --git a/src/Internal/NumHask/Algebra/Module.hs b/src/Internal/NumHask/Algebra/Module.hs index 640d010..1949ad7 100644 --- a/src/Internal/NumHask/Algebra/Module.hs +++ b/src/Internal/NumHask/Algebra/Module.hs @@ -10,11 +10,12 @@ -- | Algebra for Representable numbers module Internal.NumHask.Algebra.Module - ( AdditiveModule(..) - , AdditiveGroupModule(..) - , MultiplicativeModule(..) - , MultiplicativeGroupModule(..) - , Banach(..) + ( --AdditiveModule(..) + --, AdditiveGroupModule(..) + --, MultiplicativeModule(..) + --, MultiplicativeGroupModule(..) + --, + Banach(..) , Hilbert(..) , type (><) , TensorProduct(..) @@ -26,7 +27,7 @@ import Internal.NumHask.Algebra.Field import Internal.NumHask.Algebra.Metric import Internal.NumHask.Algebra.Multiplicative import Internal.NumHask.Algebra.Ring -import Protolude (Double, Float, Int, +import NumHask.Prelude (Double, Float, Int, Integer) diff --git a/src/Internal/NumHask/Algebra/Multiplicative.hs b/src/Internal/NumHask/Algebra/Multiplicative.hs index be16d8b..b1817ab 100644 --- a/src/Internal/NumHask/Algebra/Multiplicative.hs +++ b/src/Internal/NumHask/Algebra/Multiplicative.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} @@ -19,23 +20,41 @@ module Internal.NumHask.Algebra.Multiplicative , MultiplicativeRightCancellative(..) , MultiplicativeLeftCancellative(..) , MultiplicativeGroup(..) + , MultiplicativeGroupModule(..) + , MultiplicativeBasis(..) + , BasisConstraints + , Multiply(..) + , Divide(..) ) where import Internal.Internal import Internal.NumHask.Algebra.Additive -import Protolude (Bool (..), Double, Float, +import NumHask.Prelude (Bool (..), Double, Float, Int, Integer, Show, pure, ($)) -import qualified Protolude as P - - - +import qualified NumHask.Prelude as P +import qualified NumHask.Prelude as E +import qualified NumHask.Array as A + +type BasisConstraints r t + = ( E.Num t + , E.AdditiveBasis r t + , E.AdditiveGroupBasis r t + , E.AdditiveGroupModule r t + , E.AdditiveModule r t + , E.MultiplicativeBasis r t + , E.MultiplicativeGroupBasis r t + , E.MultiplicativeModule r t + , E.MultiplicativeGroupModule r t) -- | 'times' is used as the operator for the multiplicative magam to distinguish from '*' which, by convention, implies commutativity -- -- > ∀ a,b ∈ A: a `times` b ∈ A -- -- law is true by construction in Haskell -class MultiplicativeMagma a b r t | a b -> t, a -> t, b -> t, a -> r, b -> r, a b -> r where +class MultiplicativeMagma a b r t | a b -> t, a -> t, b -> t + --, a -> r, b -> r + , a b -> r + where times :: a -> b -> Computation r t (D r t) @@ -168,80 +187,83 @@ class ( Multiplicative a b r t (/) a b = a `times` recip b + + data Multiply = Multiply deriving Show data Divide = Divide deriving Show -instance MultiplicativeMagma (Computation r Float (D r Float)) (Computation r Float (D r Float))r Float where +instance (BasisConstraints r Float) => MultiplicativeMagma (Computation r Float (D r Float)) (Computation r Float (D r Float))r Float where times a b = do aa <- a bb <- b binOp Multiply aa bb -instance MultiplicativeMagma (Computation r Float (D r Float)) (D r Float)r Float where +instance (BasisConstraints r Float) => MultiplicativeMagma (Computation r Float (D r Float)) (D r Float)r Float where times a b = do aa <- a binOp Multiply aa b -instance MultiplicativeMagma (D r Float) (Computation r Float (D r Float))r Float where +instance (BasisConstraints r Float) => MultiplicativeMagma (D r Float) (Computation r Float (D r Float))r Float where times a b = do bb <- b binOp Multiply a bb -instance MultiplicativeMagma (D r Float) (D r Float)r Float where +instance (BasisConstraints r Float) => MultiplicativeMagma (D r Float) (D r Float)r Float where times = binOp Multiply -instance MultiplicativeMagma (Computation r Double (D r Double)) (Computation r Double (D r Double)) r Double where +instance (BasisConstraints r Double) => MultiplicativeMagma (Computation r Double (D r Double)) (Computation r Double (D r Double)) r Double where times a b = do aa <- a bb <- b binOp Multiply aa bb -instance MultiplicativeMagma (Computation r Double (D r Double)) (D r Double) r Double where +instance (BasisConstraints r Double) => MultiplicativeMagma (Computation r Double (D r Double)) (D r Double) r Double where times a b = do aa <- a binOp Multiply aa b -instance MultiplicativeMagma (D r Double) (Computation r Double (D r Double)) r Double where +instance (BasisConstraints r Double) => MultiplicativeMagma (D r Double) (Computation r Double (D r Double)) r Double where times a b = do bb <- b binOp Multiply a bb -instance MultiplicativeMagma (D r Double) (D r Double) r Double where +instance (BasisConstraints r Double) => MultiplicativeMagma (D r Double) (D r Double) r Double where times = binOp Multiply -instance (P.Num a) => BinOp Multiply a where +instance (E.Multiplicative a) => BinOp Multiply a where {-# INLINE ff_bin #-} ff_bin _ a b = b P.* a -instance (P.Num t, Multiplicative (D r t) (D r t) r t) => DfDaBin Multiply r (D r t) t where +instance (E.Num t, Additive (D r t) (D r t) r t, BasisConstraints r t, Multiplicative (D r t) (D r t) r t) => DfDaBin Multiply r (D r t) t where {-# INLINE df_da #-} df_da _ b _ _ at = binOp Multiply at b -instance ( P.Num t, Multiplicative (D r t) (D r t) r t) => DfDbBin Multiply r (D r t) t where +instance ( E.Num t, Additive (D r t) (D r t) r t, Multiplicative (D r t) (D r t) r t, BasisConstraints r t) => DfDbBin Multiply r (D r t) t where {-# INLINE df_db #-} df_db _ a _ _ bt = binOp Multiply bt a -instance (P.Num a) => FfBin Multiply a r where +instance (BasisConstraints r a) => FfBin Multiply a r where {-#INLINE rff_bin #-} - rff_bin _ a b = a .*. b + rff_bin _ a b = a E..*. b {-#INLINE r_ff_bin #-} - r_ff_bin _ a b = a .* b + r_ff_bin _ a b = a E..* b {-#INLINE _ff_bin #-} - _ff_bin _ a b = a *. b + _ff_bin _ a b = a E.*. b -instance ( P.Num t, Multiplicative (D r t) (D r t) r t ) => DfBin Multiply r (D r t) (D r t) t where +instance ( E.Num t, BasisConstraints r t, Additive (D r t) (D r t) r t, Multiplicative (D r t) (D r t) r t ) => DfBin Multiply r (D r t) (D r t) t where {-# INLINE fd_bin #-} fd_bin _ a b = binOp Multiply a b {-# INLINE df_dab #-} df_dab _ _ _ _ ap at bp bt = do a <- (binOp Multiply at bp) b <- (binOp Multiply ap bt) - binOp Add a b + -- binOp Add a b + a + b instance ( Multiplicative (D r t) (D r t) r t ) => Trace Multiply r t where pushEl (B _ a b) dA = do @@ -253,69 +275,69 @@ instance ( Multiplicative (D r t) (D r t) r t ) => Trace Multiply r t where pure [(opa, a), (opb, b), (arga, a), (argb, b)] resetEl (B _ a b) = pure [a, b, a, b] -instance MultiplicativeUnital (D r Double) r Double where +instance (BasisConstraints r Double) => MultiplicativeUnital (D r Double) r Double where one = D 1 -instance MultiplicativeUnital (D r Float) r Float where +instance (BasisConstraints r Float) => MultiplicativeUnital (D r Float) r Float where one = D 1 -instance MultiplicativeUnital (Computation r Double (D r Double)) r Double where +instance (BasisConstraints r Double) => MultiplicativeUnital (Computation r Double (D r Double)) r Double where one = P.pure P.$ D 1 -instance MultiplicativeUnital (Computation r Float (D r Float)) r Float where +instance (BasisConstraints r Float) => MultiplicativeUnital (Computation r Float (D r Float)) r Float where one = P.pure P.$ D 1 -instance MultiplicativeAssociative (D r Double) r Double +instance (BasisConstraints r Double) => MultiplicativeAssociative (D r Double) r Double -instance MultiplicativeAssociative (D r Float) r Float +instance (BasisConstraints r Float) => MultiplicativeAssociative (D r Float) r Float -instance MultiplicativeAssociative (Computation r Float (D r Float)) r Float +instance (BasisConstraints r Float) => MultiplicativeAssociative (Computation r Float (D r Float)) r Float -instance MultiplicativeAssociative (Computation r Double (D r Double)) r Double +instance (BasisConstraints r Double) => MultiplicativeAssociative (Computation r Double (D r Double)) r Double -instance MultiplicativeCommutative (D r Double) r Double +instance (BasisConstraints r Double) => MultiplicativeCommutative (D r Double) r Double -instance MultiplicativeCommutative (D r Float) r Float +instance (BasisConstraints r Float) => MultiplicativeCommutative (D r Float) r Float -instance MultiplicativeCommutative (Computation r Float (D r Float)) r Float +instance (BasisConstraints r Float) => MultiplicativeCommutative (Computation r Float (D r Float)) r Float -instance MultiplicativeCommutative (Computation r Double (D r Double)) r Double +instance (BasisConstraints r Double) => MultiplicativeCommutative (Computation r Double (D r Double)) r Double -instance +instance (BasisConstraints r Double) => MultiplicativeInvertible (D r Double) r Double where recip = binOp Divide one -instance - MultiplicativeInvertible (D r Float) r Float where +instance (BasisConstraints r Float) => MultiplicativeInvertible (D r Float) r Float where recip = binOp Divide one -instance +instance (BasisConstraints r Double) => MultiplicativeInvertible (Computation r Double (D r Double)) r Double where recip a = do aa <- a binOp Divide one aa -instance +instance (BasisConstraints r Float) => MultiplicativeInvertible (Computation r Float (D r Float)) r Float where recip a = do aa <- a binOp Divide one aa -instance (P.Num a, P.Fractional a) => BinOp Divide a where +instance (E.MultiplicativeGroup a) => BinOp Divide a where {-# INLINE ff_bin #-} ff_bin _ a b = b P./ a -instance (P.Num a) => FfBin Divide a r where +instance (BasisConstraints r a) => FfBin Divide a r where {-#INLINE rff_bin #-} - rff_bin _ a b = a ./. b + rff_bin _ a b = a E../. b {-#INLINE r_ff_bin #-} - r_ff_bin _ a b = a ./ b + r_ff_bin _ a b = a E../ b {-#INLINE _ff_bin #-} - _ff_bin _ a b = a /. b + _ff_bin _ a b = a E./. b -instance ( P.Fractional t +instance ( E.Fractional t + , BasisConstraints r t , AdditiveGroup (D r t) (D r t) r t , Multiplicative (D r t) (D r t) r t , MultiplicativeGroup (D r t) (D r t) r t @@ -326,8 +348,8 @@ instance ( P.Fractional t {-# INLINE df_da #-} df_da _ b _ _ at = binOp Divide at b -instance ( P.Fractional t - +instance ( E.Fractional t + , BasisConstraints r t , AdditiveGroup (D r t) (D r t) r t , Multiplicative (D r t) (D r t) r t , AdditiveInvertible (D r t) r t @@ -344,7 +366,8 @@ instance ( P.Fractional t binOp Divide cbt ccpbp -instance ( P.Fractional t +instance ( E.Fractional t + , BasisConstraints r t , AdditiveGroup (D r t) (D r t) r t , Multiplicative (D r t) (D r t) r t , Multiplicative (D r t) (Computation r t (D r t)) r t @@ -360,7 +383,7 @@ instance ( P.Fractional t ccp <- binOp Multiply catbt cp binOp Divide (ccp) bp -instance ( P.Fractional t +instance ( E.Fractional t , Multiplicative (D r t) (Computation r t (D r t)) r t , AdditiveGroup (D r t) (D r t) r t , MultiplicativeGroup (D r t) (D r t) r t @@ -378,38 +401,38 @@ instance ( P.Fractional t pure [(opa, a), (opb, b), (arga, a), (argb, b)] resetEl (B _ a b) = pure [a, b, a, b] -instance Multiplicative (D r Double) (D r Double) r Double +instance (BasisConstraints r Double) => Multiplicative (D r Double) (D r Double) r Double -instance Multiplicative (Computation r Double (D r Double)) (D r Double) r Double +instance (BasisConstraints r Double) => Multiplicative (Computation r Double (D r Double)) (D r Double) r Double -instance Multiplicative (D r Double) (Computation r Double (D r Double)) r Double +instance (BasisConstraints r Double) => Multiplicative (D r Double) (Computation r Double (D r Double)) r Double -instance Multiplicative (D r Float) (D r Float) r Float +instance (BasisConstraints r Float) => Multiplicative (D r Float) (D r Float) r Float -instance Multiplicative (D r Float) (Computation r Float (D r Float)) r Float +instance (BasisConstraints r Float) => Multiplicative (D r Float) (Computation r Float (D r Float)) r Float -instance Multiplicative (Computation r Float (D r Float)) (D r Float) r Float +instance (BasisConstraints r Float) => Multiplicative (Computation r Float (D r Float)) (D r Float) r Float -instance Multiplicative (Computation r Double (D r Double)) (Computation r Double (D r Double)) r Double +instance (BasisConstraints r Double) => Multiplicative (Computation r Double (D r Double)) (Computation r Double (D r Double)) r Double -instance Multiplicative (Computation r Float (D r Float)) (Computation r Float (D r Float)) r Float -- | Non-commutative left divide +instance (BasisConstraints r Float) => Multiplicative (Computation r Float (D r Float)) (Computation r Float (D r Float)) r Float -- | Non-commutative left divide -- -instance MultiplicativeGroup (D r Double) (D r Double) r Double +instance (BasisConstraints r Double) => MultiplicativeGroup (D r Double) (D r Double) r Double -instance MultiplicativeGroup (Computation r Double (D r Double)) (D r Double) r Double +instance (BasisConstraints r Double) => MultiplicativeGroup (Computation r Double (D r Double)) (D r Double) r Double -instance MultiplicativeGroup (D r Double) (Computation r Double (D r Double)) r Double +instance (BasisConstraints r Double) => MultiplicativeGroup (D r Double) (Computation r Double (D r Double)) r Double -instance MultiplicativeGroup (D r Float) (D r Float) r Float +instance (BasisConstraints r Float) => MultiplicativeGroup (D r Float) (D r Float) r Float -instance MultiplicativeGroup (D r Float) (Computation r Float (D r Float)) r Float +instance (BasisConstraints r Float) => MultiplicativeGroup (D r Float) (Computation r Float (D r Float)) r Float -instance MultiplicativeGroup (Computation r Float (D r Float)) (D r Float) r Float +instance (BasisConstraints r Float) => MultiplicativeGroup (Computation r Float (D r Float)) (D r Float) r Float -instance MultiplicativeGroup (Computation r Double (D r Double)) (Computation r Double (D r Double)) r Double +instance (BasisConstraints r Double) => MultiplicativeGroup (Computation r Double (D r Double)) (Computation r Double (D r Double)) r Double -instance MultiplicativeGroup (Computation r Float (D r Float)) (Computation r Float (D r Float)) r Float +instance (BasisConstraints r Float) => MultiplicativeGroup (Computation r Float (D r Float)) (Computation r Float (D r Float)) r Float -- | Multiplicative Module Laws @@ -426,6 +449,76 @@ class (Multiplicative a b r t) => infixl 7 *. (*.) :: a -> b -> Computation r t (D r t) + +instance (BasisConstraints (A.Array c s) Float) => + MultiplicativeModule (A.Array c s) (D (A.Array c s) Float) (D (A.Array c s) Float) Float where + (.*) a b = binOp Multiply a b + (*.) a b = binOp Multiply a b + +instance (BasisConstraints (A.Array c s) Float) => + MultiplicativeModule (A.Array c s) (D (A.Array c s) Float) (Computation (A.Array c s) Float (D (A.Array c s) Float)) Float where + (.*) a b = do + cb <- b + binOp Multiply a cb + (*.) a b = do + cb <- b + binOp Multiply a cb + +instance (BasisConstraints (A.Array c s) Float) => + MultiplicativeModule (A.Array c s) (Computation (A.Array c s) Float (D (A.Array c s) Float)) (D (A.Array c s) Float) Float where + (.*) a b = do + ca <- a + binOp Multiply ca b + (*.) a b = do + ca <- a + binOp Multiply ca b + +instance (BasisConstraints (A.Array c s) Float) => + MultiplicativeModule (A.Array c s) (Computation (A.Array c s) Float (D (A.Array c s) Float)) (Computation (A.Array c s) Float (D (A.Array c s) Float)) Float where + (.*) a b = do + ca <- a + cb <- b + binOp Multiply ca cb + (*.) a b = do + ca <- a + cb <- b + binOp Multiply ca cb + + + +instance (BasisConstraints (A.Array c s) Double) => + MultiplicativeModule (A.Array c s) (D (A.Array c s) Double) (D (A.Array c s) Double) Double where + (.*) a b = binOp Multiply a b + (*.) a b = binOp Multiply a b + +instance (BasisConstraints (A.Array c s) Double) => + MultiplicativeModule (A.Array c s) (D (A.Array c s) Double) (Computation (A.Array c s) Double (D (A.Array c s) Double)) Double where + (.*) a b = do + cb <- b + binOp Multiply a cb + (*.) a b = do + cb <- b + binOp Multiply a cb + +instance (BasisConstraints (A.Array c s) Double) => + MultiplicativeModule (A.Array c s) (Computation (A.Array c s) Double (D (A.Array c s) Double)) (D (A.Array c s) Double) Double where + (.*) a b = do + ca <- a + binOp Multiply ca b + (*.) a b = do + ca <- a + binOp Multiply ca b + +instance (BasisConstraints (A.Array c s) Double) => + MultiplicativeModule (A.Array c s) (Computation (A.Array c s) Double (D (A.Array c s) Double)) (Computation (A.Array c s) Double (D (A.Array c s) Double)) Double where + (.*) a b = do + ca <- a + cb <- b + binOp Multiply ca cb + (*.) a b = do + ca <- a + cb <- b + binOp Multiply ca cb -- | Division Module Laws -- -- > nearZero a || a ./ one == a @@ -438,6 +531,86 @@ class (MultiplicativeGroup a b r t) => (/.) :: a -> b -> Computation r t (D r t) +instance (BasisConstraints (A.Array c s) Float) => + MultiplicativeGroupModule (A.Array c s) (D (A.Array c s) Float) (D (A.Array c s) Float) Float where + (./) a b = do + cb <- (recip b) + binOp Multiply a cb + (/.) a b = do + cb <- recip b + binOp Multiply a cb + +instance (BasisConstraints (A.Array c s) Float) => + MultiplicativeGroupModule (A.Array c s) (D (A.Array c s) Float) (Computation (A.Array c s) Float (D (A.Array c s) Float)) Float where + (./) a b = do + cb <- recip b + binOp Multiply a cb + (/.) a b = do + cb <- recip b + binOp Multiply a cb + +instance (BasisConstraints (A.Array c s) Float) => + MultiplicativeGroupModule (A.Array c s) (Computation (A.Array c s) Float (D (A.Array c s) Float)) (D (A.Array c s) Float) Float where + (./) a b = do + ca <- a + cb <- recip b + binOp Multiply ca cb + (/.) a b = do + ca <- a + cb <- recip b + binOp Multiply ca cb + +instance (BasisConstraints (A.Array c s) Float) => + MultiplicativeGroupModule (A.Array c s) (Computation (A.Array c s) Float (D (A.Array c s) Float)) (Computation (A.Array c s) Float (D (A.Array c s) Float)) Float where + (./) a b = do + ca <- a + cb <- recip b + binOp Multiply ca cb + (/.) a b = do + ca <- a + cb <- recip b + binOp Multiply ca cb + +instance (BasisConstraints (A.Array c s) Double) => + MultiplicativeGroupModule (A.Array c s) (D (A.Array c s) Double) (D (A.Array c s) Double) Double where + (./) a b = do + cb <- (recip b) + binOp Multiply a cb + (/.) a b = do + cb <- recip b + binOp Multiply a cb + +instance (BasisConstraints (A.Array c s) Double) => + MultiplicativeGroupModule (A.Array c s) (D (A.Array c s) Double) (Computation (A.Array c s) Double (D (A.Array c s) Double)) Double where + (./) a b = do + cb <- recip b + binOp Multiply a cb + (/.) a b = do + cb <- recip b + binOp Multiply a cb + +instance (BasisConstraints (A.Array c s) Double) => + MultiplicativeGroupModule (A.Array c s) (Computation (A.Array c s) Double (D (A.Array c s) Double)) (D (A.Array c s) Double) Double where + (./) a b = do + ca <- a + cb <- recip b + binOp Multiply ca cb + (/.) a b = do + ca <- a + cb <- recip b + binOp Multiply ca cb + +instance (BasisConstraints (A.Array c s) Double) => + MultiplicativeGroupModule (A.Array c s) (Computation (A.Array c s) Double (D (A.Array c s) Double)) (Computation (A.Array c s) Double (D (A.Array c s) Double)) Double where + (./) a b = do + ca <- a + cb <- recip b + binOp Multiply ca cb + (/.) a b = do + ca <- a + cb <- recip b + binOp Multiply ca cb + -- | element by element multiplication -- -- > (a .*. b) .*. c == a .*. (b .*. c) @@ -449,6 +622,56 @@ class (Multiplicative a b r t) => infixl 7 .*. (.*.) :: a -> b -> Computation r t (D r t) +instance (BasisConstraints (A.Array c s) Double) => + MultiplicativeBasis (A.Array c s) (D (A.Array c s) Double) (D (A.Array c s) Double) Double where + (.*.) a b = binOp Multiply a b + +instance (BasisConstraints (A.Array c s) Double) => + MultiplicativeBasis (A.Array c s) (D (A.Array c s) Double) (Computation (A.Array c s) Double (D (A.Array c s) Double)) Double where + (.*.) a b = do + cb <- b + binOp Multiply a cb + + +instance (BasisConstraints (A.Array c s) Double) => + MultiplicativeBasis (A.Array c s) (Computation (A.Array c s) Double (D (A.Array c s) Double)) (D (A.Array c s) Double) Double where + (.*.) a b = do + ca <- a + binOp Multiply ca b + + +instance (BasisConstraints (A.Array c s) Double) => + MultiplicativeBasis (A.Array c s) (Computation (A.Array c s) Double (D (A.Array c s) Double)) (Computation (A.Array c s) Double (D (A.Array c s) Double)) Double where + (.*.) a b = do + ca <- a + cb <- b + binOp Multiply ca cb + +instance (BasisConstraints (A.Array c s) Float) => + MultiplicativeBasis (A.Array c s) (D (A.Array c s) Float) (D (A.Array c s) Float) Float where + (.*.) a b = binOp Multiply a b + +instance (BasisConstraints (A.Array c s) Float) => + MultiplicativeBasis (A.Array c s) (D (A.Array c s) Float) (Computation (A.Array c s) Float (D (A.Array c s) Float)) Float where + (.*.) a b = do + cb <- b + binOp Multiply a cb + + +instance (BasisConstraints (A.Array c s) Float) => + MultiplicativeBasis (A.Array c s) (Computation (A.Array c s) Float (D (A.Array c s) Float)) (D (A.Array c s) Float) Float where + (.*.) a b = do + ca <- a + binOp Multiply ca b + + +instance (BasisConstraints (A.Array c s) Float) => + MultiplicativeBasis (A.Array c s) (Computation (A.Array c s) Float (D (A.Array c s) Float)) (Computation (A.Array c s) Float (D (A.Array c s) Float)) Float where + (.*.) a b = do + ca <- a + cb <- b + binOp Multiply ca cb + -- | element by element division -- -- > a ./. a == singleton one @@ -456,3 +679,54 @@ class (MultiplicativeGroup a b r t ) => MultiplicativeGroupBasis r a b t where infixl 7 ./. (./.) :: a -> b -> Computation r t (D r t) + +instance (BasisConstraints (A.Array c s) Float) => + MultiplicativeGroupBasis (A.Array c s) (D (A.Array c s) Float) (D (A.Array c s) Float) Float where + (./.) a b = binOp Divide a b + +instance (BasisConstraints (A.Array c s) Float) => + MultiplicativeGroupBasis (A.Array c s) (D (A.Array c s) Float) (Computation (A.Array c s) Float (D (A.Array c s) Float)) Float where + (./.) a b = do + cb <- b + binOp Divide a cb + + +instance (BasisConstraints (A.Array c s) Float) => + MultiplicativeGroupBasis (A.Array c s) (Computation (A.Array c s) Float (D (A.Array c s) Float)) (D (A.Array c s) Float) Float where + (./.) a b = do + ca <- a + binOp Divide ca b + + +instance (BasisConstraints (A.Array c s) Float) => + MultiplicativeGroupBasis (A.Array c s) (Computation (A.Array c s) Float (D (A.Array c s) Float)) (Computation (A.Array c s) Float (D (A.Array c s) Float)) Float where + (./.) a b = do + ca <- a + cb <- b + binOp Divide ca cb + + +instance (BasisConstraints (A.Array c s) Double) => + MultiplicativeGroupBasis (A.Array c s) (D (A.Array c s) Double) (D (A.Array c s) Double) Double where + (./.) a b = binOp Divide a b + +instance (BasisConstraints (A.Array c s) Double) => + MultiplicativeGroupBasis (A.Array c s) (D (A.Array c s) Double) (Computation (A.Array c s) Double (D (A.Array c s) Double)) Double where + (./.) a b = do + cb <- b + binOp Divide a cb + + +instance (BasisConstraints (A.Array c s) Double) => + MultiplicativeGroupBasis (A.Array c s) (Computation (A.Array c s) Double (D (A.Array c s) Double)) (D (A.Array c s) Double) Double where + (./.) a b = do + ca <- a + binOp Divide ca b + + +instance (BasisConstraints (A.Array c s) Double) => + MultiplicativeGroupBasis (A.Array c s) (Computation (A.Array c s) Double (D (A.Array c s) Double)) (Computation (A.Array c s) Double (D (A.Array c s) Double)) Double where + (./.) a b = do + ca <- a + cb <- b + binOp Divide ca cb diff --git a/src/Internal/NumHask/Algebra/Ring.hs b/src/Internal/NumHask/Algebra/Ring.hs index 47c684f..f784828 100644 --- a/src/Internal/NumHask/Algebra/Ring.hs +++ b/src/Internal/NumHask/Algebra/Ring.hs @@ -17,7 +17,7 @@ import Internal.Internal import Internal.NumHask.Algebra.Additive import Internal.NumHask.Algebra.Distribution import Internal.NumHask.Algebra.Multiplicative -import Protolude (Double, Float) +import NumHask.Prelude (Double, Float) -- | Semiring class ( MultiplicativeAssociative a r t @@ -81,53 +81,53 @@ class ( Semiring a a r t class (StarSemiring a r t, StarSemiring b r t, AdditiveIdempotent a b r t) => KleeneAlgebra a b r t -instance Semiring (D r Double) (D r Double) r Double +instance (BasisConstraints r Double) => Semiring (D r Double) (D r Double) r Double -instance Semiring (Computation r Double (D r Double)) (D r Double) r Double +instance (BasisConstraints r Double) => Semiring (Computation r Double (D r Double)) (D r Double) r Double -instance Semiring (D r Double) (Computation r Double (D r Double)) r Double +instance (BasisConstraints r Double) => Semiring (D r Double) (Computation r Double (D r Double)) r Double -instance Semiring (D r Float) (D r Float) r Float +instance (BasisConstraints r Float) => Semiring (D r Float) (D r Float) r Float -instance Semiring (D r Float) (Computation r Float (D r Float)) r Float +instance (BasisConstraints r Float) => Semiring (D r Float) (Computation r Float (D r Float)) r Float -instance Semiring (Computation r Float (D r Float)) (D r Float) r Float +instance (BasisConstraints r Float) => Semiring (Computation r Float (D r Float)) (D r Float) r Float -instance Semiring (Computation r Double (D r Double)) (Computation r Double (D r Double)) r Double +instance (BasisConstraints r Double) => Semiring (Computation r Double (D r Double)) (Computation r Double (D r Double)) r Double -instance Semiring (Computation r Float (D r Float)) (Computation r Float (D r Float)) r Float +instance (BasisConstraints r Float) => Semiring (Computation r Float (D r Float)) (Computation r Float (D r Float)) r Float -instance Ring (D r Double) (D r Double) r Double +instance (BasisConstraints r Double) => Ring (D r Double) (D r Double) r Double -instance Ring (Computation r Double (D r Double)) (D r Double) r Double +instance (BasisConstraints r Double) => Ring (Computation r Double (D r Double)) (D r Double) r Double -instance Ring (D r Double) (Computation r Double (D r Double)) r Double +instance (BasisConstraints r Double) => Ring (D r Double) (Computation r Double (D r Double)) r Double -instance Ring (D r Float) (D r Float) r Float +instance (BasisConstraints r Float) => Ring (D r Float) (D r Float) r Float -instance Ring (D r Float) (Computation r Float (D r Float)) r Float +instance (BasisConstraints r Float) => Ring (D r Float) (Computation r Float (D r Float)) r Float -instance Ring (Computation r Float (D r Float)) (D r Float) r Float +instance (BasisConstraints r Float) => Ring (Computation r Float (D r Float)) (D r Float) r Float -instance Ring (Computation r Double (D r Double)) (Computation r Double (D r Double)) r Double +instance (BasisConstraints r Double) => Ring (Computation r Double (D r Double)) (Computation r Double (D r Double)) r Double -instance Ring (Computation r Float (D r Float)) (Computation r Float (D r Float)) r Float +instance (BasisConstraints r Float) => Ring (Computation r Float (D r Float)) (Computation r Float (D r Float)) r Float -instance CRing (D r Double) (D r Double) r Double +instance (BasisConstraints r Double) => CRing (D r Double) (D r Double) r Double -instance CRing (Computation r Double (D r Double)) (D r Double) r Double +instance (BasisConstraints r Double) => CRing (Computation r Double (D r Double)) (D r Double) r Double -instance CRing (D r Double) (Computation r Double (D r Double)) r Double +instance (BasisConstraints r Double) => CRing (D r Double) (Computation r Double (D r Double)) r Double -instance CRing (D r Float) (D r Float) r Float +instance (BasisConstraints r Float) => CRing (D r Float) (D r Float) r Float -instance CRing (D r Float) (Computation r Float (D r Float)) r Float +instance (BasisConstraints r Float) => CRing (D r Float) (Computation r Float (D r Float)) r Float -instance CRing (Computation r Float (D r Float)) (D r Float) r Float +instance (BasisConstraints r Float) => CRing (Computation r Float (D r Float)) (D r Float) r Float -instance CRing (Computation r Double (D r Double)) (Computation r Double (D r Double)) r Double +instance (BasisConstraints r Double) => CRing (Computation r Double (D r Double)) (Computation r Double (D r Double)) r Double -instance CRing (Computation r Float (D r Float)) (Computation r Float (D r Float)) r Float +instance (BasisConstraints r Float) => CRing (Computation r Float (D r Float)) (Computation r Float (D r Float)) r Float diff --git a/src/Internal/NumHask/Prelude.hs b/src/Internal/NumHask/Prelude.hs index 8c4f329..7fd712b 100644 --- a/src/Internal/NumHask/Prelude.hs +++ b/src/Internal/NumHask/Prelude.hs @@ -9,7 +9,7 @@ module Internal.NumHask.Prelude -- * Algebraic Heirarchy -- $instances , module Internal.NumHask.Algebra.Additive - , module Internal.NumHask.Algebra.Basis + -- , module Internal.NumHask.Algebra.Basis , module Internal.NumHask.Algebra.Distribution , module Internal.NumHask.Algebra.Field -- , module NumHask.Algebra.Integral @@ -19,7 +19,7 @@ module Internal.NumHask.Prelude , module Internal.NumHask.Algebra.Multiplicative , module Internal.NumHask.Algebra.Ring , module Internal.NumHask.Algebra.Singleton - , module Internal.NumHask.Algebra.Diff + -- , module Internal.NumHask.Algebra.Diff ) where @@ -32,7 +32,7 @@ import Protolude zero) import Internal.NumHask.Algebra.Additive -import Internal.NumHask.Algebra.Basis +-- import Internal.NumHask.Algebra.Basis import Internal.NumHask.Algebra.Distribution import Internal.NumHask.Algebra.Field -- import NumHask.Algebra.Integral @@ -42,7 +42,7 @@ import Internal.NumHask.Algebra.Module import Internal.NumHask.Algebra.Multiplicative import Internal.NumHask.Algebra.Ring import Internal.NumHask.Algebra.Singleton -import Internal.NumHask.Algebra.Diff +-- import Internal.NumHask.Algebra.Diff -- $backend -- NumHask imports Protolude as the prelude and replaces much of the 'Num' heirarchy in base. diff --git a/src/Num.hs b/src/Num.hs index 1eb9327..a1b6467 100644 --- a/src/Num.hs +++ b/src/Num.hs @@ -17,8 +17,6 @@ import Internal.NumHask.Prelude hiding (State, diff, evalSt import qualified NumHask.Prelude as P import Internal.Internal - - data FixPoint = FixPoint deriving Show fpPush :: diff --git a/stack.yaml b/stack.yaml index f9cdcf9..df549f7 100644 --- a/stack.yaml +++ b/stack.yaml @@ -4,7 +4,7 @@ packages: - . - location: git: https://github.com/o1lo01ol1o/numhask-array - commit: 8d1e75c45d587f541f6b6031276e317bfe4e0035 + commit: b5c745d24630dfff294d37d1ed93352f724c5792 extra-dep: true extra-deps: diff --git a/test/.#Spec.hs b/test/.#Spec.hs new file mode 120000 index 0000000..f858ff5 --- /dev/null +++ b/test/.#Spec.hs @@ -0,0 +1 @@ +timpierson@Tims-MBP-2.lan.16551 \ No newline at end of file diff --git a/test/Spec.hs b/test/Spec.hs index 9b65bac..d72c9e5 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,16 +1,87 @@ - +{-# LANGUAGE NoImplicitPrelude#-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE UndecidableInstances #-} module Main where -- import Test.DocTest -import Test.Tasty () -- (TestTree, defaultMain, testGroup, localOption) +import Test.Tasty (testGroup, TestTree,defaultMain) -- (TestTree, defaultMain, testGroup, localOption) import Test.Tasty.QuickCheck() +import Test.Tasty.HUnit (testCase, (@?=)) + +import Internal.Internal +import Core +import Num +import Internal.NumHask.Prelude +-- import NumHask.Array() +import qualified NumHask.Array as A +-- import qualified NumHask.Prelude as E + +instance (AdditiveBasisConstraints (A.Array c s) Float) => + AdditiveModule (A.Array c s) (D (A.Array c s) Float) (D (A.Array c s) Float) Float where + (.+) a b = binOp Add a b + (+.) a b = binOp Add a b + +instance (AdditiveBasisConstraints (A.Array c s) Float) => + AdditiveBasis (A.Array c s) (D (A.Array c s) Float) (D (A.Array c s) Float) Float where + (.+.) a b = + binOp Add a b + +-- simple = go +-- where +-- g :: +-- D (A.Array [] '[1]) Float +-- -> D (A.Array [] '[1]) Float +-- -> Computation (A.Array [] '[1]) Float (D (A.Array [] '[1]) Float) +-- g a b = (a + b / a) / (D 2.0 :: D (A.Array [] '[1]) Float) +-- go :: ((D (A.Array [] '[1]) Float), (D (A.Array [] '[1]) Float)) +-- go = compute $ diff' (fixPoint g (D 1.2 :: D (A.Array [] '[1]) Float)) (D 25.0 :: D (A.Array [] '[1]) Float) + +add = let b = D 2 :: (D (A.Array [] '[]) Float) + a = D 3 :: (D (A.Array [] '[0]) Float) + c = [3,4] :: A.Array [] '[2] Float + d = Dm c :: (D (A.Array [] '[2]) Float) + -- in compute $ diff' (+ a) a + in compute $ a +. d + +unitTests = + testGroup + "Unit tests" + [ testCase "Addition" $ + add @?= (Dm [6, 7] :: (D (A.Array [] '[2]) Float)) + -- add @?= False + + + -- testCase "Fixpoint" $ + -- simple @?= + -- ( ( (D 1.0 :: D (A.Array [] '[ 1]) Float) + -- --, (D 5.0 :: D (A.Array [] '[ 1]) Float)) + -- , (( D 1.0 :: D (A.Array [] '[ 1]) Float) + -- -- , (D 0.1 :: D (A.Array [] '[ 1]) Float))) + -- ))) + ] main :: IO () -main = -- do - -- putStrLn "\n Core DocTest" - -- doctest ["src/Core.hs"] - -- putStrLn "\n Num DocTest" - -- doctest ["src/Num.hs"] - return () -- defaultMain +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Tests" [ unitTests] + +