diff --git a/numhask.cabal b/numhask.cabal --- a/numhask.cabal +++ b/numhask.cabal @@ -1,12 +1,9 @@ name: numhask -version: 0.0.9 +version: 0.1.0 synopsis: A numeric prelude description: - Classes for numbers, higher-dimension representable objects, and algebras that combine them. - . - See NumHask.Examples for usage. - . + A numeric prelude, providing a clean structure for numbers and operations that combine them. category: mathematics homepage: @@ -33,12 +30,12 @@ Haskell2010 ghc-options: -Wall - -fno-warn-orphans hs-source-dirs: src exposed-modules: NumHask.Prelude, NumHask.Examples, + NumHask.Algebra, NumHask.Algebra.Additive, NumHask.Algebra.Basis, NumHask.Algebra.Distribution, @@ -48,9 +45,8 @@ NumHask.Algebra.Magma, NumHask.Algebra.Metric, NumHask.Algebra.Module, - NumHask.Algebra.Multiplicative - NumHask.Algebra.Ordering, - NumHask.Naperian, + NumHask.Algebra.Multiplicative, + NumHask.Shape, NumHask.Vector, NumHask.Matrix build-depends: @@ -59,41 +55,13 @@ vector >= 0.11 && < 0.13, QuickCheck >= 2.8 && < 3, adjunctions >= 4.3 && < 5, - distributive >= 0.5 && < 0.6 + distributive >= 0.5 && < 0.6, + singletons >= 2.2 && < 3, + matrix >=0.3.5.0 && <0.4 default-extensions: NoImplicitPrelude, - UnicodeSyntax, - BangPatterns, - BinaryLiterals, - DeriveFoldable, - DeriveFunctor, - DeriveGeneric, - DeriveTraversable, - DisambiguateRecordFields, - EmptyCase, - FlexibleContexts, - FlexibleInstances, - FunctionalDependencies, - GADTSyntax, - InstanceSigs, - KindSignatures, - LambdaCase, - MonadComprehensions, - MultiParamTypeClasses, - MultiWayIf, - NegativeLiterals, OverloadedStrings, - ParallelListComp, - PartialTypeSignatures, - PatternSynonyms, - RankNTypes, - RecordWildCards, - RecursiveDo, - ScopedTypeVariables, - TupleSections, - TypeFamilies, - TypeOperators, - ExtendedDefaultRules + UnicodeSyntax test-suite test default-language: @@ -112,38 +80,8 @@ doctest default-extensions: NoImplicitPrelude, - UnicodeSyntax, - BangPatterns, - BinaryLiterals, - DeriveFoldable, - DeriveFunctor, - DeriveGeneric, - DeriveTraversable, - DisambiguateRecordFields, - EmptyCase, - FlexibleContexts, - FlexibleInstances, - FunctionalDependencies, - GADTSyntax, - InstanceSigs, - KindSignatures, - LambdaCase, - MonadComprehensions, - MultiParamTypeClasses, - MultiWayIf, - NegativeLiterals, OverloadedStrings, - ParallelListComp, - PartialTypeSignatures, - PatternSynonyms, - RankNTypes, - RecordWildCards, - RecursiveDo, - ScopedTypeVariables, - TupleSections, - TypeFamilies, - TypeOperators, - ExtendedDefaultRules + UnicodeSyntax source-repository head type: diff --git a/readme.md b/readme.md --- a/readme.md +++ b/readme.md @@ -3,22 +3,46 @@ [![Build Status](https://travis-ci.org/tonyday567/numhask.svg)](https://travis-ci.org/tonyday567/numhask) [![Hackage](https://img.shields.io/hackage/v/numhask.svg)](https://hackage.haskell.org/package/numhask) [![lts](https://www.stackage.org/package/numhask/badge/lts)](http://stackage.org/lts/package/numhask) [![nightly](https://www.stackage.org/package/numhask/badge/nightly)](http://stackage.org/nightly/package/numhask) -A numeric prelude for primitive numbers and representable objects. +A numeric prelude, providing a clean structure for numbers and operations that combine them. -``` {.sourceCode .literate .haskell} -{-# LANGUAGE ExtendedDefaultRules #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE DataKinds #-} -``` + +This particular shed has been painted: + +- by providing separately named magma-derived classes for addition and multiplication, and then being symetrical in the treatment of the two heirarchies. A short magma structure is provided with the intention of supplying appropriate classes fro operators that are no addition nor multiplication, but this structure is not hooked up to the main classes. +- to be as compatible as practical with the existing haskell ecosystem. Ints, Integers, Floats, Doubles and Complex are taken from base and given numhask instances, so they are also Num instances. Monoid and Semigroup are not used in numhask to maintain compatability. +- as a replacement for anything in base that has a Num, Fractional or Real constraint. +- with type-checked Vector and Matrix instances using Representable to build the shape and structure. +- includes QuickCheck tests of the numeric laws implicit in the classes. This also includes tracking where laws are approximate or fail for non-exact numbers. +- the usual operators (+) and (*) operators are reserved for commutative relationships, with plus and times being used for non-commutative ones. + +Alternative color-schemes, stylistic flourishes and opines are welcome. + +In summary, the library doesn't do anything fancy. But if having to define `(*)` when you just want a `(+)` offends your sensibilities, it may bring some sanity. + + +Representable numbers +--- + + + +`Vector` and `Matrix` objects are provided that: + +- are shape type-checked +- are based on Representable instances +- have inner and tensor product operators + +These are experimental and await testing in the wild. + +Usage +--- + ``` {.sourceCode .literate .haskell} +{-# LANGUAGE NoImplicitPrelude #-} import Numhask.Prelude ``` -`Numhask.Prelude` is a drop-in replacement for `Prelude`. Behind the -scenes, it wraps `Protolude`. +'Numhask.Prelude' is designed as a drop-in replacement for Prelude and 'NoImplicitPrelude' is obligatory. Behind the scenes, the module wraps [protolude](https://www.stackage.org/package/protolude). -~~~ -stack build --test -~~~ +See [Examples](src/NumHask/Examples.hs) for basic examples, and [numhask-space](https://www.stackage.org/package/numhask-space) for slightly heavier number crunching. diff --git a/src/NumHask/Algebra.hs b/src/NumHask/Algebra.hs new file mode 100644 --- /dev/null +++ b/src/NumHask/Algebra.hs @@ -0,0 +1,27 @@ +{-# OPTIONS_HADDOCK prune #-} +{-# OPTIONS_GHC -Wall #-} + +-- | Algebraic structure +module NumHask.Algebra + ( module NumHask.Algebra.Additive + , module NumHask.Algebra.Basis + , module NumHask.Algebra.Distribution + , module NumHask.Algebra.Field + , module NumHask.Algebra.Integral + , module NumHask.Algebra.Magma + , module NumHask.Algebra.Metric + , module NumHask.Algebra.Module + , module NumHask.Algebra.Multiplicative + , module NumHask.Algebra.Ring + ) where + +import NumHask.Algebra.Additive +import NumHask.Algebra.Basis +import NumHask.Algebra.Distribution +import NumHask.Algebra.Field +import NumHask.Algebra.Integral +import NumHask.Algebra.Magma +import NumHask.Algebra.Metric +import NumHask.Algebra.Module +import NumHask.Algebra.Multiplicative +import NumHask.Algebra.Ring diff --git a/src/NumHask/Algebra/Additive.hs b/src/NumHask/Algebra/Additive.hs --- a/src/NumHask/Algebra/Additive.hs +++ b/src/NumHask/Algebra/Additive.hs @@ -1,183 +1,214 @@ {-# OPTIONS_GHC -Wall #-} --- | Additive Structure - -module NumHask.Algebra.Additive ( - -- ** Additive Structure - AdditiveMagma(..) +-- | A magma heirarchy for addition. The basic magma structure is repeated and prefixed with 'Additive-'. +module NumHask.Algebra.Additive + ( AdditiveMagma(..) , AdditiveUnital(..) , AdditiveAssociative , AdditiveCommutative , AdditiveInvertible(..) - , AdditiveHomomorphic(..) , AdditiveIdempotent - , AdditiveMonoidal + , sum , Additive(..) , AdditiveRightCancellative(..) , AdditiveLeftCancellative(..) , AdditiveGroup(..) ) where -import qualified Protolude as P -import Protolude (Double, Float, Int, Integer, Bool(..)) import Data.Complex (Complex(..)) +import qualified Protolude as P +import Protolude (Bool(..), Double, Float, Int, Integer) --- * Additive structure --- The Magma structures are repeated for an additive and multiplicative heirarchy, mostly so we can name the specific operators in the usual ways. +-- | 'plus' is used as the operator for the additive magma to distinguish from '+' which, by convention, implies commutativity -- --- | 'plus' is used for the additive magma to distinguish from '+' which, by convention, implies commutativity -class AdditiveMagma a where plus :: a -> a -> a +-- > ∀ a,b ∈ A: a `plus` b ∈ A +-- +-- law is true by construction in Haskell +class AdditiveMagma a where + plus :: a -> a -> a -instance AdditiveMagma Double where plus = (P.+) -instance AdditiveMagma Float where plus = (P.+) -instance AdditiveMagma Int where plus = (P.+) -instance AdditiveMagma Integer where plus = (P.+) -instance AdditiveMagma Bool where plus = (P.||) +instance AdditiveMagma Double where + plus = (P.+) + +instance AdditiveMagma Float where + plus = (P.+) + +instance AdditiveMagma Int where + plus = (P.+) + +instance AdditiveMagma Integer where + plus = (P.+) + +instance AdditiveMagma Bool where + plus = (P.||) + instance (AdditiveMagma a) => AdditiveMagma (Complex a) where - (rx :+ ix) `plus` (ry :+ iy) = (rx `plus` ry) :+ (ix `plus` iy) + (rx :+ ix) `plus` (ry :+ iy) = (rx `plus` ry) :+ (ix `plus` iy) --- | AdditiveUnital +-- | Unital magma for addition. -- -- > zero `plus` a == a -- > a `plus` zero == a -class AdditiveMagma a => AdditiveUnital a where zero :: a +class AdditiveMagma a => + AdditiveUnital a where + zero :: a -instance AdditiveUnital Double where zero = 0 -instance AdditiveUnital Float where zero = 0 -instance AdditiveUnital Int where zero = 0 -instance AdditiveUnital Integer where zero = 0 -instance AdditiveUnital Bool where zero = False +instance AdditiveUnital Double where + zero = 0 + +instance AdditiveUnital Float where + zero = 0 + +instance AdditiveUnital Int where + zero = 0 + +instance AdditiveUnital Integer where + zero = 0 + +instance AdditiveUnital Bool where + zero = False + instance (AdditiveUnital a) => AdditiveUnital (Complex a) where - zero = zero :+ zero + zero = zero :+ zero --- | AdditiveAssociative +-- | Associative magma for addition. -- -- > (a `plus` b) `plus` c == a `plus` (b `plus` c) -class AdditiveMagma a => AdditiveAssociative a +class AdditiveMagma a => + AdditiveAssociative a instance AdditiveAssociative Double + instance AdditiveAssociative Float + instance AdditiveAssociative Int + instance AdditiveAssociative Integer + instance AdditiveAssociative Bool + instance (AdditiveAssociative a) => AdditiveAssociative (Complex a) --- | AdditiveCommutative +-- | Commutative magma for addition. -- -- > a `plus` b == b `plus` a -class AdditiveMagma a => AdditiveCommutative a +class AdditiveMagma a => + AdditiveCommutative a instance AdditiveCommutative Double + instance AdditiveCommutative Float + instance AdditiveCommutative Int + instance AdditiveCommutative Integer + instance AdditiveCommutative Bool + instance (AdditiveCommutative a) => AdditiveCommutative (Complex a) --- | AdditiveInvertible +-- | Invertible magma for addition. -- -- > ∀ a ∈ A: negate a ∈ A -- -- law is true by construction in Haskell -class AdditiveMagma a => AdditiveInvertible a where negate :: a -> a +class AdditiveMagma a => + AdditiveInvertible a where + negate :: a -> a -instance AdditiveInvertible Double where negate = P.negate -instance AdditiveInvertible Float where negate = P.negate -instance AdditiveInvertible Int where negate = P.negate -instance AdditiveInvertible Integer where negate = P.negate -instance AdditiveInvertible Bool where negate = P.not -instance (AdditiveInvertible a) => AdditiveInvertible (Complex a) where - negate (rx :+ ix) = negate rx :+ negate ix +instance AdditiveInvertible Double where + negate = P.negate --- | AdditiveHomomorphic --- --- > ∀ a ∈ A: plushom a ∈ B --- --- law is true by construction in Haskell -class (AdditiveMagma b) => AdditiveHomomorphic a b where - plushom :: a -> b +instance AdditiveInvertible Float where + negate = P.negate -instance AdditiveMagma a => AdditiveHomomorphic a a where plushom a = a +instance AdditiveInvertible Int where + negate = P.negate --- | AdditiveIdempotent +instance AdditiveInvertible Integer where + negate = P.negate + +instance AdditiveInvertible Bool where + negate = P.not + +instance (AdditiveInvertible a) => AdditiveInvertible (Complex a) where + negate (rx :+ ix) = negate rx :+ negate ix + +-- | Idempotent magma for addition. -- -- > a `plus` a == a -class AdditiveMagma a => AdditiveIdempotent a +class AdditiveMagma a => + AdditiveIdempotent a instance AdditiveIdempotent Bool --- | AdditiveMonoidal -class ( AdditiveUnital a - , AdditiveAssociative a) => - AdditiveMonoidal a - -instance AdditiveMonoidal Double -instance AdditiveMonoidal Float -instance AdditiveMonoidal Int -instance AdditiveMonoidal Integer -instance AdditiveMonoidal Bool -instance (AdditiveMonoidal a) => AdditiveMonoidal (Complex a) +-- | sum definition avoiding a clash with the Sum monoid in base +-- +sum :: (Additive a, P.Foldable f) => f a -> a +sum = P.foldr (+) zero -- | Additive is commutative, unital and associative under addition -- --- > a + b = b + a --- --- > (a + b) + c = a + (b + c) --- --- > zero + a = a --- --- > a + zero = a --- -class ( AdditiveCommutative a - , AdditiveUnital a - , AdditiveAssociative a) => +-- > zero + a == a +-- > a + zero == a +-- > (a + b) + c == a + (b + c) +-- > a + b == b + a +class (AdditiveCommutative a, AdditiveUnital a, AdditiveAssociative a) => Additive a where - infixl 6 + - (+) :: a -> a -> a - a + b = plus a b + infixl 6 + + (+) :: a -> a -> a + a + b = plus a b instance Additive Double + instance Additive Float + instance Additive Int + instance Additive Integer + instance Additive Bool -instance {-# Overlapping #-} (Additive a) => Additive (Complex a) +instance (Additive a) => Additive (Complex a) + -- | Non-commutative left minus -class ( AdditiveUnital a - , AdditiveAssociative a - , AdditiveInvertible a) => +-- +-- > negate a `plus` a = zero +class (AdditiveUnital a, AdditiveAssociative a, AdditiveInvertible a) => AdditiveLeftCancellative a where - infixl 6 ~- - (~-) :: a -> a -> a - (~-) a b = negate b `plus` a + infixl 6 ~- + (~-) :: a -> a -> a + (~-) a b = negate b `plus` a -- | Non-commutative right minus -class ( AdditiveUnital a - , AdditiveAssociative a - , AdditiveInvertible a) => +-- +-- > a `plus` negate a = zero +class (AdditiveUnital a, AdditiveAssociative a, AdditiveInvertible a) => AdditiveRightCancellative a where - infixl 6 -~ - (-~) :: a -> a -> a - (-~) a b = a `plus` negate b + infixl 6 -~ + (-~) :: a -> a -> a + (-~) a b = a `plus` negate b --- | AdditiveGroup +-- | Minus ('-') is reserved for where both the left and right cancellative laws hold. This then implies that the AdditiveGroup is also Abelian. -- --- > a - a = zero +-- Syntactic unary negation - substituting "negate a" for "-a" in code - is hard-coded in the language to assume a Num instance. So, for example, using ''-a = zero - a' for the second rule below doesn't work. -- +-- > a - a = zero -- > negate a = zero - a --- -- > negate a + a = zero --- -class ( Additive a - , AdditiveInvertible a) => +-- > a + negate a = zero +class (Additive a, AdditiveInvertible a) => AdditiveGroup a where - infixl 6 - - (-) :: a -> a -> a - (-) a b = a `plus` negate b + infixl 6 - + (-) :: a -> a -> a + (-) a b = a `plus` negate b instance AdditiveGroup Double + instance AdditiveGroup Float + instance AdditiveGroup Int + instance AdditiveGroup Integer -instance {-# Overlapping #-} (AdditiveGroup a) => AdditiveGroup (Complex a) + +instance (AdditiveGroup a) => AdditiveGroup (Complex a) diff --git a/src/NumHask/Algebra/Basis.hs b/src/NumHask/Algebra/Basis.hs --- a/src/NumHask/Algebra/Basis.hs +++ b/src/NumHask/Algebra/Basis.hs @@ -1,58 +1,66 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_GHC -Wall #-} --- | Highjacking 'Representable's to provide a basis to provide element-by-element operations - -module NumHask.Algebra.Basis ( - AdditiveBasis(..) +-- | Element-by-element operation for 'Representable's +module NumHask.Algebra.Basis + ( AdditiveBasis(..) , AdditiveGroupBasis(..) , MultiplicativeBasis(..) , MultiplicativeGroupBasis(..) ) where import Data.Functor.Rep -import NumHask.Algebra.Multiplicative import NumHask.Algebra.Additive +import NumHask.Algebra.Multiplicative --- | AdditiveBasis --- element by element addition -class ( Representable m - , Additive a ) => +-- | element by element addition +-- +-- > (a .+. b) .+. c == a .+. (b .+. c) +-- > zero .+. a = a +-- > a .+. zero = a +-- > a .+. b == b .+. a +class (Representable m, Additive a) => AdditiveBasis m a where - infixl 7 .+. - (.+.) :: m a -> m a -> m a - (.+.) = liftR2 (+) + infixl 7 .+. + (.+.) :: m a -> m a -> m a + (.+.) = liftR2 (+) instance (Representable r, Additive a) => AdditiveBasis r a --- | AdditiveGroupBasis --- element by element subtraction -class ( Representable m - , AdditiveGroup a ) => +-- | element by element subtraction +-- +-- > a .-. a = singleton zero +class (Representable m, AdditiveGroup a) => AdditiveGroupBasis m a where - infixl 6 .-. - (.-.) :: m a -> m a -> m a - (.-.) = liftR2 (-) + infixl 6 .-. + (.-.) :: m a -> m a -> m a + (.-.) = liftR2 (-) instance (Representable r, AdditiveGroup a) => AdditiveGroupBasis r a --- | MultiplicativeBasis --- element by element multiplication -class ( Representable m - , Multiplicative a ) => +-- | element by element multiplication +-- +-- > (a .*. b) .*. c == a .*. (b .*. c) +-- > singleton one .*. a = a +-- > a .*. singelton one = a +-- > a .*. b == b .*. a +class (Representable m, Multiplicative a) => MultiplicativeBasis m a where - infixl 7 .*. - (.*.) :: m a -> m a -> m a - (.*.) = liftR2 (*) + infixl 7 .*. + (.*.) :: m a -> m a -> m a + (.*.) = liftR2 (*) instance (Representable r, Multiplicative a) => MultiplicativeBasis r a --- | MultiplicativeGroupBasis --- element by element division -class ( Representable m - , MultiplicativeGroup a ) => +-- | element by element division +-- +-- > a ./. a == singleton one +class (Representable m, MultiplicativeGroup a) => MultiplicativeGroupBasis m a where - infixl 7 ./. - (./.) :: m a -> m a -> m a - (./.) = liftR2 (/) + infixl 7 ./. + (./.) :: m a -> m a -> m a + (./.) = liftR2 (/) -instance (Representable r, MultiplicativeGroup a) => MultiplicativeGroupBasis r a +instance (Representable r, MultiplicativeGroup a) => + MultiplicativeGroupBasis r a diff --git a/src/NumHask/Algebra/Distribution.hs b/src/NumHask/Algebra/Distribution.hs --- a/src/NumHask/Algebra/Distribution.hs +++ b/src/NumHask/Algebra/Distribution.hs @@ -1,33 +1,32 @@ {-# OPTIONS_GHC -Wall #-} --- | Distribution, avoiding name clashes with 'Data.Distributive' -module NumHask.Algebra.Distribution ( - -- * Distribution - Distribution +-- | 'Distribution' avoids a name clash with 'Data.Distributive' +module NumHask.Algebra.Distribution + ( Distribution ) where -import Protolude (Double, Float, Int, Integer,Bool(..)) +import Data.Complex (Complex(..)) import NumHask.Algebra.Additive import NumHask.Algebra.Multiplicative -import Data.Complex (Complex(..)) +import Protolude (Bool(..), Double, Float, Int, Integer) --- | Distribution +-- | Distribution (and annihilation) laws -- -- > a * (b + c) == a * b + a * c --- -- > (a + b) * c == a * c + b * c --- -class ( - Additive a - , MultiplicativeMagma a - ) => Distribution a +-- > a * zero == zero +-- > zero * a == zero +class (Additive a, MultiplicativeMagma a) => + Distribution a instance Distribution Double + instance Distribution Float + instance Distribution Int + instance Distribution Integer -instance Distribution Bool -instance {-# Overlapping #-} (AdditiveGroup a, Distribution a) => - Distribution (Complex a) +instance Distribution Bool +instance (AdditiveGroup a, Distribution a) => Distribution (Complex a) diff --git a/src/NumHask/Algebra/Field.hs b/src/NumHask/Algebra/Field.hs --- a/src/NumHask/Algebra/Field.hs +++ b/src/NumHask/Algebra/Field.hs @@ -1,99 +1,140 @@ {-# OPTIONS_GHC -Wall #-} --- | Field -module NumHask.Algebra.Field ( - Field +-- | Field classes +module NumHask.Algebra.Field + ( Semifield + , Field , ExpField(..) , QuotientField(..) , BoundedField(..) , infinity , neginfinity + , TrigField(..) ) where -import Protolude (Double, Float, Integer, Bool, (||)) -import qualified Protolude as P +import Data.Complex (Complex(..)) import NumHask.Algebra.Additive import NumHask.Algebra.Multiplicative -import NumHask.Algebra.Distribution import NumHask.Algebra.Ring -import Data.Complex (Complex(..)) +import Protolude (Bool, Double, Float, Integer, (||)) +import qualified Protolude as P --- | Field -class ( AdditiveGroup a - , MultiplicativeGroup a - , Distribution a - , Ring a) => +-- | A Semifield is a Field without Commutative Multiplication. +class (MultiplicativeInvertible a, Ring a) => + Semifield a + +instance Semifield Double + +instance Semifield Float + +instance (Semifield a) => Semifield (Complex a) + +-- | A Field is a Ring plus additive invertible and multiplicative invertible operations. +-- +-- A summary of the rules inherited from super-classes of Field +-- +-- > zero + a == a +-- > a + zero == a +-- > (a + b) + c == a + (b + c) +-- > a + b == b + a +-- > a - a = zero +-- > negate a = zero - a +-- > negate a + a = zero +-- > a + negate a = zero +-- > one * a == a +-- > a * one == a +-- > (a * b) * c == a * (b * c) +-- > a * (b + c) == a * b + a * c +-- > (a + b) * c == a * c + b * c +-- > a * zero == zero +-- > zero * a == zero +-- > a * b == b * a +-- > a / a = one +-- > recip a = one / a +-- > recip a * a = one +-- > a * recip a = one +class (AdditiveGroup a, MultiplicativeGroup a, Ring a) => Field a instance Field Double -instance Field Float -instance {-# Overlapping #-} (Field a) => Field (Complex a) --- | ExpField -class (Field a) => ExpField a where - exp :: a -> a - log :: a -> a - - logBase :: a -> a -> a - logBase a b = log b / log a +instance Field Float - (**) :: a -> a -> a - (**) a b = exp (log a * b) +instance (Field a) => Field (Complex a) - sqrt :: a -> a - sqrt a = a**(one/(one+one)) +-- | A hyperbolic field class +-- +-- > sqrt . (**2) == identity +-- > log . exp == identity +-- > for +ive b, a != 0,1: a ** logBase a b ≈ b +class (Field a) => + ExpField a where + exp :: a -> a + log :: a -> a + logBase :: a -> a -> a + logBase a b = log b / log a + (**) :: a -> a -> a + (**) a b = exp (log a * b) + sqrt :: a -> a + sqrt a = a ** (one / (one + one)) instance ExpField Double where - exp = P.exp - log = P.log - (**) = (P.**) + exp = P.exp + log = P.log + (**) = (P.**) instance ExpField Float where - exp = P.exp - log = P.log - (**) = (P.**) - -instance {-# Overlapping #-} (ExpField a) => ExpField (Complex a) where - exp (rx :+ ix) = exp rx * cos ix :+ exp rx * sin ix - where - cos = P.undefined - sin = P.undefined + exp = P.exp + log = P.log + (**) = (P.**) - log (rx :+ ix) = log (sqrt (rx * rx + ix * ix)) :+ atan2 ix rx - where - atan2 = P.undefined +-- | todo: bottom is here somewhere??? +instance (TrigField a, ExpField a) => ExpField (Complex a) where + exp (rx :+ ix) = exp rx * cos ix :+ exp rx * sin ix + log (rx :+ ix) = log (sqrt (rx * rx + ix * ix)) :+ atan2 ix rx --- | quotient fields explode constraints if they are polymorphed to emit general integrals -class (Field a) => QuotientField a where - round :: a -> Integer - ceiling :: a -> Integer - floor :: a -> Integer - (^^) :: a -> Integer -> a +-- | quotient fields explode constraints if they allow for polymorphic integral types +-- +-- > a - one < floor a <= a <= ceiling a < a + one +-- > round a == floor (a + one/(one+one)) +class (Field a) => + QuotientField a where + round :: a -> Integer + ceiling :: a -> Integer + floor :: a -> Integer + (^^) :: a -> Integer -> a instance QuotientField Float where - round = P.round - ceiling = P.ceiling - floor = P.floor - (^^) = (P.^^) + round = P.round + ceiling = P.ceiling + floor = P.floor + (^^) = (P.^^) instance QuotientField Double where - round = P.round - ceiling = P.ceiling - floor = P.floor - (^^) = (P.^^) - --- | providing the concepts of infinity and NaN, thus moving away from error throwing -class (Field a) => BoundedField a where - maxBound :: a - maxBound = one/zero - - minBound :: a - minBound = negate (one/zero) - - nan :: a - nan = zero/zero + round = P.round + ceiling = P.ceiling + floor = P.floor + (^^) = (P.^^) - isNaN :: a -> Bool +-- | A bounded field includes the concepts of infinity and NaN, thus moving away from error throwing. +-- +-- > one / zero + infinity == infinity +-- > infinity + a == infinity +-- > isNaN (infinity - infinity) +-- > isNaN (infinity / infinity) +-- > isNaN (nan + a) +-- > zero / zero != nan +-- +-- Note the tricky law that, although nan is assigned to zero/zero, they are never-the-less not equal. A committee decided this. +class (Field a) => + BoundedField a where + maxBound :: a + maxBound = one / zero + minBound :: a + minBound = negate (one / zero) + nan :: a + nan = zero / zero + isNaN :: a -> Bool -- | prints as `Infinity` infinity :: BoundedField a => a @@ -103,8 +144,70 @@ neginfinity :: BoundedField a => a neginfinity = minBound -instance BoundedField Float where isNaN = P.isNaN -instance BoundedField Double where isNaN = P.isNaN -instance {-# Overlapping #-} (BoundedField a) => BoundedField (Complex a) where - isNaN (rx :+ ix) = isNaN rx || isNaN ix +instance BoundedField Float where + isNaN = P.isNaN +instance BoundedField Double where + isNaN = P.isNaN + +-- | todo: work out boundings for complex +-- as it stands now, complex is different eg +-- +-- > one / (zero :: Complex Float) == nan +instance (BoundedField a) => BoundedField (Complex a) where + isNaN (rx :+ ix) = isNaN rx || isNaN ix + +-- | Trigonometric Field +class (P.Ord a, Field a) => + TrigField a where + pi :: a + sin :: a -> a + cos :: a -> a + tan :: a -> a + tan x = sin x / cos x + asin :: a -> a + acos :: a -> a + atan :: a -> a + sinh :: a -> a + cosh :: a -> a + tanh :: a -> a + tanh x = sinh x / cosh x + asinh :: a -> a + acosh :: a -> a + atanh :: a -> a + atan2 :: a -> a -> a + atan2 y x + | x P.> zero = atan (y / x) + | x P.== zero P.&& y P.> zero = pi / (one + one) + | x P.< one P.&& y P.> one = pi + atan (y / x) + | (x P.<= zero P.&& y P.< zero) || (x P.< zero) = + negate (atan2 (negate y) x) + | y P.== zero = pi -- must be after the previous test on zero y + | x P.== zero P.&& y P.== zero = y -- must be after the other double zero tests + | P.otherwise = x + y -- x or y is a NaN, return a NaN (via +) + +instance TrigField Double where + pi = P.pi + sin = P.sin + cos = P.cos + asin = P.asin + acos = P.acos + atan = P.atan + sinh = P.sinh + cosh = P.cosh + asinh = P.sinh + acosh = P.acosh + atanh = P.atanh + +instance TrigField Float where + pi = P.pi + sin = P.sin + cos = P.cos + asin = P.asin + acos = P.acos + atan = P.atan + sinh = P.sinh + cosh = P.cosh + asinh = P.sinh + acosh = P.acosh + atanh = P.atanh diff --git a/src/NumHask/Algebra/Integral.hs b/src/NumHask/Algebra/Integral.hs --- a/src/NumHask/Algebra/Integral.hs +++ b/src/NumHask/Algebra/Integral.hs @@ -1,53 +1,63 @@ {-# OPTIONS_GHC -Wall #-} --- | Integral domains -module NumHask.Algebra.Integral ( - -- * Integral - Integral(..) +-- | Integral classes +module NumHask.Algebra.Integral + ( Integral(..) , ToInteger(..) , FromInteger(..) , fromIntegral ) where +import NumHask.Algebra.Ring import qualified Protolude as P import Protolude (Double, Float, Int, Integer, (.), fst, snd) -import NumHask.Algebra.Ring --- | Integral +-- | Integral laws -- -- > b == zero || b * (a `div` b) + (a `mod` b) == a --- -class (Ring a) => Integral a where - - infixl 7 `div`, `mod` - - -- | truncates towards negative infinity - div :: a -> a -> a - div a1 a2 = fst (divMod a1 a2) - mod :: a -> a -> a - mod a1 a2 = snd (divMod a1 a2) +class (Ring a) => + Integral a where + infixl 7 `div`, `mod` + div :: a -> a -> a + div a1 a2 = fst (divMod a1 a2) + mod :: a -> a -> a + mod a1 a2 = snd (divMod a1 a2) + divMod :: a -> a -> (a, a) - divMod :: a -> a -> (a,a) +instance Integral Int where + divMod = P.divMod -instance Integral Int where divMod = P.divMod -instance Integral Integer where divMod = P.divMod +instance Integral Integer where + divMod = P.divMod --- | toInteger and fromInteger as per the base 'Num' instance is problematic for numbers with a 'Basis' +-- | toInteger is kept separate from Integral to help with compatability issues. class ToInteger a where - toInteger :: a -> Integer + toInteger :: a -> Integer --- | fromInteger -class (Ring a) => FromInteger a where - fromInteger :: Integer -> a +-- | fromInteger is the most problematic of the 'Num' class operators. Particularly heinous, it is assumed that any number type can be constructed from an Integer, so that the broad classes of objects that are composed of multiple elements is avoided in haskell. +class FromInteger a where + fromInteger :: Integer -> a --- | This splitting away of fromInteger from the 'Ring' instance tends to increase constraint boier-plate +-- | coercion of 'Integral's +-- +-- > fromIntegral a == a fromIntegral :: (ToInteger a, FromInteger b) => a -> b fromIntegral = fromInteger . toInteger -instance FromInteger Double where fromInteger = P.fromInteger -instance FromInteger Float where fromInteger = P.fromInteger -instance FromInteger Int where fromInteger = P.fromInteger -instance FromInteger Integer where fromInteger = P.fromInteger +instance FromInteger Double where + fromInteger = P.fromInteger -instance ToInteger Int where toInteger = P.toInteger -instance ToInteger Integer where toInteger = P.toInteger +instance FromInteger Float where + fromInteger = P.fromInteger + +instance FromInteger Int where + fromInteger = P.fromInteger + +instance FromInteger Integer where + fromInteger = P.fromInteger + +instance ToInteger Int where + toInteger = P.toInteger + +instance ToInteger Integer where + toInteger = P.toInteger diff --git a/src/NumHask/Algebra/Magma.hs b/src/NumHask/Algebra/Magma.hs --- a/src/NumHask/Algebra/Magma.hs +++ b/src/NumHask/Algebra/Magma.hs @@ -1,15 +1,15 @@ {-# OPTIONS_GHC -Wall #-} --- | Magma -module NumHask.Algebra.Magma ( - Magma(..) +-- | Bootstrapping the number system. +-- +-- This heirarchy is repeated for the Additive and Multiplicative structures, in order to achieve class separation, so these classes are not used in the main numerical classes. +module NumHask.Algebra.Magma + ( Magma(..) , Unital(..) , Associative , Commutative , Invertible(..) , Idempotent - , Homomorphic(..) - , Isomorphic(..) , Monoidal , CMonoidal , Loop @@ -38,24 +38,29 @@ -- These laws are true by construction in haskell: the type signature of 'magma' and the above mathematical laws are synonyms. -- -- -class Magma a where (⊕) :: a -> a -> a +class Magma a where + (⊕) :: a -> a -> a -- | A Unital Magma -- -- > unit ⊕ a = a -- > a ⊕ unit = a -- -class Magma a => Unital a where unit :: a +class Magma a => + Unital a where + unit :: a -- | An Associative Magma --- +-- -- > (a ⊕ b) ⊕ c = a ⊕ (b ⊕ c) -class Magma a => Associative a +class Magma a => + Associative a -- | A Commutative Magma -- -- > a ⊕ b = b ⊕ a -class Magma a => Commutative a +class Magma a => + Commutative a -- | An Invertible Magma -- @@ -63,63 +68,40 @@ -- -- law is true by construction in Haskell -- -class Magma a => Invertible a where inv :: a -> a +class Magma a => + Invertible a where + inv :: a -> a -- | An Idempotent Magma -- -- > a ⊕ a = a -class Magma a => Idempotent a - --- | A Homomorph between two Magmas --- --- > ∀ a ∈ A: hom a ∈ B --- --- law is true by construction in Haskell --- -class ( Magma a - , Magma b) => - Homomorphic a b where hom :: a -> b - -instance Magma a => Homomorphic a a where hom a = a - --- | major conceptual clashidge with many other libraries -class (Magma a, Magma b) => Isomorphic a b where - isomorph :: (a -> b, b -> a) +class Magma a => + Idempotent a -- | A Monoidal Magma is associative and unital. -class ( Associative a - , Unital a) => +class (Associative a, Unital a) => Monoidal a -- | A CMonoidal Magma is commutative, associative and unital. -class ( Commutative a - , Associative a - , Unital a) => +class (Commutative a, Associative a, Unital a) => CMonoidal a -- | A Loop is unital and invertible -class ( Unital a - , Invertible a) => +class (Unital a, Invertible a) => Loop a -- | A Group is associative, unital and invertible -class ( Associative a - , Unital a - , Invertible a) => +class (Associative a, Unital a, Invertible a) => Group a -- | see http://chris-taylor.github.io/blog/2013/02/25/xor-trick/ -groupSwap :: (Group a) => (a,a) -> (a,a) -groupSwap (a,b) = - let a' = a ⊕ b - b' = a ⊕ inv b - a'' = inv b' ⊕ a' - in (a'',b') +groupSwap :: (Group a) => (a, a) -> (a, a) +groupSwap (a, b) = + let a' = a ⊕ b + b' = a ⊕ inv b + a'' = inv b' ⊕ a' + in (a'', b') -- | An Abelian Group is associative, unital, invertible and commutative -class ( Associative a - , Unital a - , Invertible a - , Commutative a) => +class (Associative a, Unital a, Invertible a, Commutative a) => Abelian a - diff --git a/src/NumHask/Algebra/Metric.hs b/src/NumHask/Algebra/Metric.hs --- a/src/NumHask/Algebra/Metric.hs +++ b/src/NumHask/Algebra/Metric.hs @@ -1,91 +1,142 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_GHC -Wall #-} --- | Metric structure -module NumHask.Algebra.Metric ( - -- * Metric - Metric(..) +-- | Metric classes +module NumHask.Algebra.Metric + ( Signed(..) , Normed(..) - , Signed(..) + , Metric(..) , Epsilon(..) , (≈) ) where -import qualified Protolude as P -import Protolude (Double, Float, Int, Integer, ($), Bool(..), Ord(..), Eq(..), (&&)) -import NumHask.Algebra.Field +import Data.Complex (Complex(..)) import NumHask.Algebra.Additive +import NumHask.Algebra.Field import NumHask.Algebra.Multiplicative -import Data.Complex (Complex(..)) +import qualified Protolude as P +import Protolude + (Bool(..), Double, Eq(..), Float, Int, Integer, Ord(..), ($), (&&)) --- | abs and signnum are warts on the standard 'Num' class, and are separated here to provide a cleaner structure. -class ( MultiplicativeUnital a - ) => Signed a where - sign :: a -> a - abs :: a -> a +-- | '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 +-- +-- > abs a * sign a == a +-- +-- Generalising this class tends towards size and direction (abs is the size on the one-dim number line of a vector with its tail at zero, and sign is the direction, right?). +class (MultiplicativeUnital a) => + Signed a where + sign :: a -> a + abs :: a -> a instance Signed Double where - sign a = if a >= zero then one else negate one - abs = P.abs + sign a = + if a >= zero + then one + else negate one + abs = P.abs + instance Signed Float where - sign a = if a >= zero then one else negate one - abs = P.abs + sign a = + if a >= zero + then one + else negate one + abs = P.abs + instance Signed Int where - sign a = if a >= zero then one else negate one - abs = P.abs + sign a = + if a >= zero + then one + else negate one + abs = P.abs + instance Signed Integer where - sign a = if a >= zero then one else negate one - abs = P.abs + sign a = + if a >= zero + then one + else negate one + abs = P.abs --- | Normed is a current wart on the NumHask api, causing all sorts of runaway constraint boiler-plate. +-- | Like Signed, except the codomain can be different to the domain. class Normed a b where - size :: a -> b + size :: a -> b -instance Normed Double Double where size = P.abs -instance Normed Float Float where size = P.abs -instance Normed Int Int where size = P.abs -instance Normed Integer Integer where size = P.abs -instance {-# Overlapping #-} (Multiplicative a, ExpField a, Normed a a) => Normed (Complex a) a where - size (rx :+ ix) = sqrt (rx * rx + ix * ix) +instance Normed Double Double where + size = P.abs --- | This should probably be split off into some sort of alternative Equality logic, but to what end? -class (AdditiveGroup a) => Epsilon a where - nearZero :: a -> Bool - aboutEqual :: a -> a -> Bool +instance Normed Float Float where + size = P.abs +instance Normed Int Int where + size = P.abs + +instance Normed Integer Integer where + size = P.abs + +instance (Multiplicative a, ExpField a, Normed a a) => + Normed (Complex a) a where + size (rx :+ ix) = sqrt (rx * rx + ix * ix) + +-- | distance between numbers +-- +-- > distance a b >= zero +-- > distance a a == zero +-- > \a b c -> distance a c + distance b c - distance a b >= zero && +-- > distance a b + distance b c - distance a c >= zero && +-- > distance a b + distance a c - distance b c >= zero && +class Metric a b where + distance :: a -> a -> b + +instance Metric Double Double where + distance a b = abs (a - b) + +instance Metric Float Float where + distance a b = abs (a - b) + +instance Metric Int Int where + distance a b = abs (a - b) + +instance Metric Integer Integer where + distance a b = abs (a - b) + +instance (Multiplicative a, ExpField a, Normed a a) => + Metric (Complex a) a where + distance a b = size (a - b) + +-- | todo: This should probably be split off into some sort of alternative Equality logic, but to what end? +class (AdditiveGroup a) => + Epsilon a where + nearZero :: a -> Bool + aboutEqual :: a -> a -> Bool + positive :: (Eq a, Signed a) => a -> Bool + positive a = a == abs a + veryPositive :: (Eq a, Signed a) => a -> Bool + veryPositive a = P.not (nearZero a) && positive a + veryNegative :: (Eq a, Signed a) => a -> Bool + veryNegative a = P.not (nearZero a P.|| positive a) + infixl 4 ≈ --- | utf ??? +-- | todo: is utf perfectly acceptable these days? (≈) :: (Epsilon a) => a -> a -> Bool (≈) = aboutEqual instance Epsilon Double where - nearZero a = abs a <= (1e-12 :: Double) - aboutEqual a b = nearZero $ a - b + nearZero a = abs a <= (1e-12 :: Double) + aboutEqual a b = nearZero $ a - b instance Epsilon Float where - nearZero a = abs a <= (1e-6 :: Float) - aboutEqual a b = nearZero $ a - b + nearZero a = abs a <= (1e-6 :: Float) + aboutEqual a b = nearZero $ a - b instance Epsilon Int where - nearZero a = a == zero - aboutEqual a b = nearZero $ a - b + nearZero a = a == zero + aboutEqual a b = nearZero $ a - b instance Epsilon Integer where - nearZero a = a == zero - aboutEqual a b = nearZero $ a - b - -instance {-# Overlapping #-} (Epsilon a) => Epsilon (Complex a) where - nearZero (rx :+ ix) = nearZero rx && nearZero ix - aboutEqual a b = nearZero $ a - b - --- | distance between numbers -class Metric a b where - distance :: a -> a -> b - -instance Metric Double Double where distance a b = abs (a - b) -instance Metric Float Float where distance a b = abs (a - b) -instance Metric Int Int where distance a b = abs (a - b) -instance Metric Integer Integer where distance a b = abs (a - b) -instance {-# Overlapping #-} (Multiplicative a, ExpField a, Normed a a) => Metric (Complex a) a where - distance a b = size (a - b) + nearZero a = a == zero + aboutEqual a b = nearZero $ a - b +instance (Epsilon a) => Epsilon (Complex a) where + nearZero (rx :+ ix) = nearZero rx && nearZero ix + aboutEqual a b = nearZero $ a - b diff --git a/src/NumHask/Algebra/Module.hs b/src/NumHask/Algebra/Module.hs --- a/src/NumHask/Algebra/Module.hs +++ b/src/NumHask/Algebra/Module.hs @@ -1,134 +1,164 @@ -{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ExplicitNamespaces #-} {-# OPTIONS_GHC -Wall #-} --- | Algebra - -module NumHask.Algebra.Module ( - -- * Module - AdditiveModule(..) +-- | Algebra for Representable numbers +module NumHask.Algebra.Module + ( AdditiveModule(..) , AdditiveGroupModule(..) , MultiplicativeModule(..) , MultiplicativeGroupModule(..) - -- * Tensoring , Banach(..) , Hilbert(..) + , inner , type (><) , TensorProduct(..) ) where -import Protolude (Double, Float, Int, Integer, Functor(..), ($), Foldable(..)) import Data.Functor.Rep import NumHask.Algebra.Additive import NumHask.Algebra.Field import NumHask.Algebra.Metric import NumHask.Algebra.Multiplicative import NumHask.Algebra.Ring - --- * Additive Module Structure - --- | AdditiveModule -class ( Representable m - , Additive a) => - AdditiveModule m a where - infixl 6 .+ - (.+) :: m a -> a -> m a - m .+ a = fmap (a+) m +import Protolude + (Double, Float, Foldable(..), Functor(..), Int, Integer, ($)) - infixl 6 +. - (+.) :: a -> m a -> m a - a +. m = fmap (a+) m +-- | Additive Module Laws +-- +-- > (a + b) .+ c == a + (b .+ c) +-- > (a + b) .+ c == (a .+ c) + b +-- > a .+ zero == a +-- > a .+ b == b +. a +class (Representable r, Additive a) => + AdditiveModule r a where + infixl 6 .+ + (.+) :: r a -> a -> r a + r .+ a = fmap (a +) r + infixl 6 +. + (+.) :: a -> r a -> r a + a +. r = fmap (a +) r instance (Representable r, Additive a) => AdditiveModule r a --- | AdditiveGroupModule -class ( Representable m - , AdditiveGroup a) => - AdditiveGroupModule m a where - infixl 6 .- - (.-) :: m a -> a -> m a - m .- a = fmap (\x -> x - a) m - - infixl 6 -. - (-.) :: a -> m a -> m a - a -. m = fmap (\x -> a - x) m +-- | Subtraction Module Laws +-- +-- > (a + b) .- c == a + (b .- c) +-- > (a + b) .- c == (a .- c) + b +-- > a .- zero == a +-- > a .- b == negate b +. a +class (Representable r, AdditiveGroup a) => + AdditiveGroupModule r a where + infixl 6 .- + (.-) :: r a -> a -> r a + r .- a = fmap (\x -> x - a) r + infixl 6 -. + (-.) :: a -> r a -> r a + a -. r = fmap (\x -> a - x) r instance (Representable r, AdditiveGroup a) => AdditiveGroupModule r a --- * Multiplicative Module Structure --- | MultiplicativeModule -class ( Representable m - , Multiplicative a) => - MultiplicativeModule m a where - infixl 7 .* - (.*) :: m a -> a -> m a - m .* a = fmap (a*) m - - infixl 7 *. - (*.) :: a -> m a -> m a - a *. m = fmap (a*) m +-- | Multiplicative Module Laws +-- +-- > a .* one == a +-- > (a + b) .* c == (a .* c) + (b .* c) +-- > c *. (a + b) == (c *. a) + (c *. b) +-- > a .* zero == zero +-- > a .* b == b *. a +class (Representable r, Multiplicative a) => + MultiplicativeModule r a where + infixl 7 .* + (.*) :: r a -> a -> r a + r .* a = fmap (a *) r + infixl 7 *. + (*.) :: a -> r a -> r a + a *. r = fmap (a *) r instance (Representable r, Multiplicative a) => MultiplicativeModule r a --- | MultiplicativeGroupModule -class ( Representable m - , MultiplicativeGroup a) => - MultiplicativeGroupModule m a where - infixl 7 ./ - (./) :: m a -> a -> m a - m ./ a = fmap (/ a) m - - infixl 7 /. - (/.) :: a -> m a -> m a - a /. m = fmap (\x -> a / x) m +-- | Division Module Laws +-- +-- > nearZero a || a ./ one == a +-- > b == zero || a ./ b == recip b *. a +class (Representable r, MultiplicativeGroup a) => + MultiplicativeGroupModule r a where + infixl 7 ./ + (./) :: r a -> a -> r a + r ./ a = fmap (/ a) r + infixl 7 /. + (/.) :: a -> r a -> r a + a /. r = fmap (\x -> a / x) r -instance (Representable r, MultiplicativeGroup a) => MultiplicativeGroupModule r a +instance (Representable r, MultiplicativeGroup a) => + MultiplicativeGroupModule r a --- | Banach -class ( Representable m - , ExpField a - , Normed (m a) a) => - Banach m a where - normalize :: m a -> m a - normalize a = a ./ size a +-- | Banach (with Norm) laws form rules around size and direction of a number, with a potential crossing into another codomain. +-- +-- > a == singleton zero || normalize a *. size a == a +class (Representable r, ExpField a, Normed (r a) a) => + Banach r a where + normalize :: r a -> r a + normalize a = a ./ size a instance (Normed (r a) a, ExpField a, Representable r) => Banach r a --- | Hilbert -class (Additive (m a)) => Hilbert m a where - infix 8 <.> - (<.>) :: m a -> m a -> a +-- | the inner product of a representable over a semiring +-- +-- > a <.> b == b <.> a +-- > a <.> (b +c) == a <.> b + a <.> c +-- > a <.> (s *. b + c) == s * (a <.> b) + a <.> c +-- (s0 *. a) <.> (s1 *. b) == s0 * s1 * (a <.> b) +class (Semiring a, Foldable r, Representable r) => + Hilbert r a where + infix 8 <.> + (<.>) :: r a -> r a -> a + (<.>) a b = sum $ liftR2 times a b -instance (Additive (r a), Foldable r, Representable r, CRing a) => - Hilbert r a where - (<.>) a b = foldl' (+) zero $ liftR2 (*) a b +-- | synonym for (<.>) +inner :: (Hilbert r a) => r a -> r a -> a +inner = (<.>) --- | tensorial tomfoolery -type family (><) (a::k1) (b::k2) :: * +-- | tensorial type +type family (><) (a :: k1) (b :: k2) :: * type instance Int >< Int = Int + type instance Integer >< Integer = Integer + type instance Double >< Double = Double + type instance Float >< Float = Float +-- | representation synthesis type family TensorRep k1 k2 where - TensorRep (r a) (r a) = r (r a) - TensorRep (r a) a = r a + TensorRep (r a) (r a) = r (r a) + TensorRep (r a) (s a) = r (s a) + TensorRep (r a) a = r a type instance r a >< b = TensorRep (r a) b --- | TensorAlgebra +-- | generalised outer product +-- +-- > a>< b +-- > a>< (b+c) +-- +-- todo: work out why these laws down't apply +-- > a *. (b> (a>< - (><) :: a -> a -> (a> (a> a - timesright :: (a> a -> a + infix 8 >< + (><) :: a -> a -> (a >< a) + outer :: a -> a -> (a >< a) + outer = (><) + timesleft :: a -> (a >< a) -> a + timesright :: (a >< a) -> a -> a -instance (AdditiveGroup (r a), Foldable r, Representable r, CRing a ) => - TensorProduct (r a) - where - (><) m n = tabulate (\i -> index m i *. n) - timesleft v m = tabulate (\i -> v <.> index m i) - timesright m v = tabulate (\i -> v <.> index m i) +instance (Hilbert r a, Multiplicative a) => TensorProduct (r a) where + (><) m n = tabulate (\i -> index m i *. n) + timesleft v m = tabulate (\i -> v <.> index m i) + timesright m v = tabulate (\i -> v <.> index m i) diff --git a/src/NumHask/Algebra/Multiplicative.hs b/src/NumHask/Algebra/Multiplicative.hs --- a/src/NumHask/Algebra/Multiplicative.hs +++ b/src/NumHask/Algebra/Multiplicative.hs @@ -1,184 +1,217 @@ -{-# LANGUAGE Unsafe #-} {-# OPTIONS_GHC -Wall #-} --- | Multiplicate structure --- Many treatments of a numeric tower treat multiplication differently to addition. NumHask treats these two as exactly symmetrical, and thus departs from the usual mathematical terminology. - -module NumHask.Algebra.Multiplicative ( - -- ** Multiplicative Structure - MultiplicativeMagma(..) +-- | A magma heirarchy for multiplication. The basic magma structure is repeated and prefixed with 'Multiplicative-'. +module NumHask.Algebra.Multiplicative + ( MultiplicativeMagma(..) , MultiplicativeUnital(..) , MultiplicativeAssociative , MultiplicativeCommutative , MultiplicativeInvertible(..) - , MultiplicativeHomomorphic(..) - , MultiplicativeMonoidal + , product , Multiplicative(..) , MultiplicativeRightCancellative(..) , MultiplicativeLeftCancellative(..) , MultiplicativeGroup(..) ) where -import qualified Protolude as P -import Protolude (Double, Float, Int, Integer, Bool(..)) import Data.Complex (Complex(..)) import NumHask.Algebra.Additive +import qualified Protolude as P +import Protolude (Bool(..), Double, Float, Int, Integer) --- * Multiplicative structure --- | 'times' is used for the multiplicative magma to distinguish from '*' which, by convention, implies commutativity -class MultiplicativeMagma a where times :: a -> a -> a +-- | '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 where + times :: a -> a -> a -instance MultiplicativeMagma Double where times = (P.*) -instance MultiplicativeMagma Float where times = (P.*) -instance MultiplicativeMagma Int where times = (P.*) -instance MultiplicativeMagma Integer where times = (P.*) -instance MultiplicativeMagma Bool where times = (P.&&) +instance MultiplicativeMagma Double where + times = (P.*) + +instance MultiplicativeMagma Float where + times = (P.*) + +instance MultiplicativeMagma Int where + times = (P.*) + +instance MultiplicativeMagma Integer where + times = (P.*) + +instance MultiplicativeMagma Bool where + times = (P.&&) + instance (MultiplicativeMagma a, AdditiveGroup a) => - MultiplicativeMagma (Complex a) where - (rx :+ ix) `times` (ry :+ iy) = - (rx `times` ry - ix `times` iy) :+ (ix `times` ry + iy `times` rx) + MultiplicativeMagma (Complex a) where + (rx :+ ix) `times` (ry :+ iy) = + (rx `times` ry - ix `times` iy) :+ (ix `times` ry + iy `times` rx) --- | MultiplicativeUnital +-- | Unital magma for multiplication. -- -- > one `times` a == a -- > a `times` one == a -class MultiplicativeMagma a => MultiplicativeUnital a where one :: a +class MultiplicativeMagma a => + MultiplicativeUnital a where + one :: a -instance MultiplicativeUnital Double where one = 1 -instance MultiplicativeUnital Float where one = 1 -instance MultiplicativeUnital Int where one = 1 -instance MultiplicativeUnital Integer where one = 1 -instance MultiplicativeUnital Bool where one = True +instance MultiplicativeUnital Double where + one = 1 + +instance MultiplicativeUnital Float where + one = 1 + +instance MultiplicativeUnital Int where + one = 1 + +instance MultiplicativeUnital Integer where + one = 1 + +instance MultiplicativeUnital Bool where + one = True + instance (AdditiveUnital a, AdditiveGroup a, MultiplicativeUnital a) => - MultiplicativeUnital (Complex a) where - one = one :+ zero + MultiplicativeUnital (Complex a) where + one = one :+ zero --- | MultiplicativeAssociative +-- | Associative magma for multiplication. -- -- > (a `times` b) `times` c == a `times` (b `times` c) -class MultiplicativeMagma a => MultiplicativeAssociative a +class MultiplicativeMagma a => + MultiplicativeAssociative a instance MultiplicativeAssociative Double + instance MultiplicativeAssociative Float + instance MultiplicativeAssociative Int + instance MultiplicativeAssociative Integer + instance MultiplicativeAssociative Bool + instance (AdditiveGroup a, MultiplicativeAssociative a) => - MultiplicativeAssociative (Complex a) + MultiplicativeAssociative (Complex a) --- | MultiplicativeCommutative +-- | Commutative magma for multiplication. -- -- > a `times` b == b `times` a -class MultiplicativeMagma a => MultiplicativeCommutative a +class MultiplicativeMagma a => + MultiplicativeCommutative a instance MultiplicativeCommutative Double + instance MultiplicativeCommutative Float + instance MultiplicativeCommutative Int + instance MultiplicativeCommutative Integer + instance MultiplicativeCommutative Bool + instance (AdditiveGroup a, MultiplicativeCommutative a) => - MultiplicativeCommutative (Complex a) + MultiplicativeCommutative (Complex a) --- | MultiplicativeInvertible +-- | Invertible magma for multiplication. -- -- > ∀ a ∈ A: recip a ∈ A -- -- law is true by construction in Haskell -class MultiplicativeMagma a => MultiplicativeInvertible a where recip :: a -> a +class MultiplicativeMagma a => + MultiplicativeInvertible a where + recip :: a -> a -instance MultiplicativeInvertible Double where recip = P.recip -instance MultiplicativeInvertible Float where recip = P.recip +instance MultiplicativeInvertible Double where + recip = P.recip + +instance MultiplicativeInvertible Float where + recip = P.recip + instance (AdditiveGroup a, MultiplicativeInvertible a) => - MultiplicativeInvertible (Complex a) where - recip (rx :+ ix) = (rx `times` d) :+ (negate ix `times` d) - where - d = recip ((rx `times` rx) `plus` (ix `times` ix)) + MultiplicativeInvertible (Complex a) where + recip (rx :+ ix) = (rx `times` d) :+ (negate ix `times` d) + where + d = recip ((rx `times` rx) `plus` (ix `times` ix)) --- | MultiplicativeHomomorphic --- --- > ∀ a ∈ A: timeshom a ∈ B +-- | Idempotent magma for multiplication. -- --- law is true by construction in Haskell -class ( MultiplicativeMagma b) => - MultiplicativeHomomorphic a b where - timeshom :: a -> b - -instance MultiplicativeMagma a => MultiplicativeHomomorphic a a where - timeshom a = a +-- > a `times` a == a +class MultiplicativeMagma a => + MultiplicativeIdempotent a --- | MultiplicativeMonoidal -class ( MultiplicativeUnital a - , MultiplicativeAssociative a) => - MultiplicativeMonoidal a +instance MultiplicativeIdempotent Bool -instance MultiplicativeMonoidal Double -instance MultiplicativeMonoidal Float -instance MultiplicativeMonoidal Int -instance MultiplicativeMonoidal Integer -instance MultiplicativeMonoidal Bool -instance (AdditiveGroup a, MultiplicativeMonoidal a) => - MultiplicativeMonoidal (Complex a) +-- | product definition avoiding a clash with the Product monoid in base +-- +product :: (Multiplicative a, P.Foldable f) => f a -> a +product = P.foldr (*) one -- | Multiplicative is commutative, associative and unital under multiplication -- --- > a * b = b * a --- --- > (a * b) * c = a * (b * c) --- --- > one * a = a --- --- > a * one = a --- +-- > one * a == a +-- > a * one == a +-- > (a * b) * c == a * (b * c) +-- > a * b == b * a class ( MultiplicativeCommutative a , MultiplicativeUnital a - , MultiplicativeAssociative a) => + , MultiplicativeAssociative a + ) => Multiplicative a where - infixl 7 * - (*) :: a -> a -> a - a * b = times a b + infixl 7 * + (*) :: a -> a -> a + a * b = times a b instance Multiplicative Double + instance Multiplicative Float + instance Multiplicative Int + instance Multiplicative Integer + instance Multiplicative Bool -instance {-# Overlapping #-} (AdditiveGroup a, Multiplicative a) => - Multiplicative (Complex a) where +instance (AdditiveGroup a, Multiplicative a) => Multiplicative (Complex a) + -- | Non-commutative left divide +-- +-- > recip a `times` a = one class ( MultiplicativeUnital a , MultiplicativeAssociative a - , MultiplicativeInvertible a) => + , MultiplicativeInvertible a + ) => MultiplicativeLeftCancellative a where - infixl 7 ~/ - (~/) :: a -> a -> a - a ~/ b = recip b `times` a + infixl 7 ~/ + (~/) :: a -> a -> a + a ~/ b = recip b `times` a -- | Non-commutative right divide +-- +-- > a `times` recip a = one class ( MultiplicativeUnital a , MultiplicativeAssociative a - , MultiplicativeInvertible a) => + , MultiplicativeInvertible a + ) => MultiplicativeRightCancellative a where - infixl 7 /~ - (/~) :: a -> a -> a - a /~ b = a `times` recip b + infixl 7 /~ + (/~) :: a -> a -> a + a /~ b = a `times` recip b --- | MultiplicativeGroup +-- | Divide ('/') is reserved for where both the left and right cancellative laws hold. This then implies that the MultiplicativeGroup is also Abelian. -- -- > a / a = one --- -- > recip a = one / a --- -- > recip a * a = one --- -class ( Multiplicative a - , MultiplicativeInvertible a) => +-- > a * recip a = one +class (Multiplicative a, MultiplicativeInvertible a) => MultiplicativeGroup a where - infixl 7 / - (/) :: a -> a -> a - (/) a b = a `times` recip b + infixl 7 / + (/) :: a -> a -> a + (/) a b = a `times` recip b instance MultiplicativeGroup Double + instance MultiplicativeGroup Float -instance {-# Overlapping #-} (AdditiveGroup a, MultiplicativeGroup a) => - MultiplicativeGroup (Complex a) where + +instance (AdditiveGroup a, MultiplicativeGroup a) => + MultiplicativeGroup (Complex a) diff --git a/src/NumHask/Algebra/Ordering.hs b/src/NumHask/Algebra/Ordering.hs deleted file mode 100644 --- a/src/NumHask/Algebra/Ordering.hs +++ /dev/null @@ -1,214 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wall #-} - --- | A bit of extra Ordering taken from gaia. -module NumHask.Algebra.Ordering ( - -- * lattice - POrd(..) - , POrdering(..) - , Topped(..) - , Bottomed(..) - , Bounded - , Negated(..) - , Semilattice - , Lattice(..) - , ord2pord - ) where - -import qualified Protolude as P -import Protolude (Double, Float, Int, Integer, Bool(..), Ord(..), Eq(..), fst) -import Data.Coerce -import NumHask.Algebra.Magma - --- | Equal to, Less than, Greater than, Not comparable to -data POrdering = PEQ | PLT | PGT | PNC - --- | P's just to avoid name clashes -class POrd s where pcompare :: s -> s -> POrdering - --- | POrd -instance (Ord a) => POrd a where - pcompare n m - | n > m = PGT - | n == m = PEQ - | P.otherwise = PLT - --- | conversion -ord2pord :: P.Ordering -> POrdering -ord2pord P.EQ = PEQ -ord2pord P.LT = PLT -ord2pord P.GT = PGT - --- | Topped -class POrd s => Topped s where top :: s - --- | Bottomed -class POrd s => Bottomed s where bottom :: s - --- | Semilattice -class ( Associative a - , Commutative a - , Idempotent a) => - Semilattice a - --- | Replaces the Bounded in base. Is this a good idea? -class ( Topped a - , Bottomed a) => - Bounded a - -instance Topped Int where top = P.maxBound -instance Bottomed Int where bottom = P.minBound -instance Bounded Int - -instance Topped Bool where top = True -instance Bottomed Bool where bottom = False -instance Bounded Bool - --- | a nice Lattice, but the types explode the instance requirements -class ( - Coercible a (Sup a) - , Coercible a (Inf a) - , Semilattice (Sup a) - , Semilattice (Inf a) - , POrd a - ) => Lattice a where - type Inf a - type Sup a - (/\) :: a -> a -> a - (/\) = coerce ((⊕) :: Sup a -> Sup a -> Sup a) - (\/) :: a -> a -> a - (\/) = coerce ((⊕) :: Inf a -> Inf a -> Inf a) - --- | which creates a nice alternative for negate -class (Lattice a, Isomorphic (Inf a) (Sup a) ) => Negated a where - negated :: a -> a - negated a = coerce (fst isomorph (coerce a :: Inf a) :: Sup a) :: a - --- Int -newtype InfInt = InfInt Int -newtype SupInt = SupInt Int - -instance Magma InfInt where - InfInt a ⊕ InfInt b = InfInt (if a <= b then a else b) - -instance Magma SupInt where - SupInt a ⊕ SupInt b = SupInt (if a >= b then a else b) - -instance Associative InfInt -instance Associative SupInt - -instance Commutative SupInt -instance Commutative InfInt - -instance Idempotent SupInt -instance Idempotent InfInt - -instance Homomorphic SupInt InfInt where hom (SupInt a) = InfInt (-a) -instance Homomorphic InfInt SupInt where hom (InfInt a) = SupInt (-a) - -instance Isomorphic SupInt InfInt where isomorph = (hom, hom) -instance Isomorphic InfInt SupInt where isomorph = (hom, hom) - -instance Semilattice SupInt -instance Semilattice InfInt - -instance Lattice Int where - type Inf Int = InfInt - type Sup Int = SupInt - --- Integer -newtype InfInteger = InfInteger Integer -newtype SupInteger = SupInteger Integer - -instance Magma InfInteger where - InfInteger a ⊕ InfInteger b = InfInteger (if a <= b then a else b) - -instance Magma SupInteger where - SupInteger a ⊕ SupInteger b = SupInteger (if a >= b then a else b) - -instance Associative InfInteger -instance Associative SupInteger - -instance Commutative SupInteger -instance Commutative InfInteger - -instance Idempotent SupInteger -instance Idempotent InfInteger - -instance Homomorphic SupInteger InfInteger where hom (SupInteger a) = InfInteger (-a) -instance Homomorphic InfInteger SupInteger where hom (InfInteger a) = SupInteger (-a) - -instance Isomorphic SupInteger InfInteger where isomorph = (hom, hom) -instance Isomorphic InfInteger SupInteger where isomorph = (hom, hom) - -instance Semilattice SupInteger -instance Semilattice InfInteger - -instance Lattice Integer where - type Inf Integer = InfInteger - type Sup Integer = SupInteger - --- Float -newtype InfFloat = InfFloat Float -newtype SupFloat = SupFloat Float - -instance Magma InfFloat where - InfFloat a ⊕ InfFloat b = InfFloat (if a <= b then a else b) - -instance Magma SupFloat where - SupFloat a ⊕ SupFloat b = SupFloat (if a >= b then a else b) - -instance Associative InfFloat -instance Associative SupFloat - -instance Commutative SupFloat -instance Commutative InfFloat - -instance Idempotent SupFloat -instance Idempotent InfFloat - -instance Homomorphic SupFloat InfFloat where hom (SupFloat a) = InfFloat (-a) -instance Homomorphic InfFloat SupFloat where hom (InfFloat a) = SupFloat (-a) - -instance Isomorphic SupFloat InfFloat where isomorph = (hom, hom) -instance Isomorphic InfFloat SupFloat where isomorph = (hom, hom) - -instance Semilattice SupFloat -instance Semilattice InfFloat - -instance Lattice Float where - type Inf Float = InfFloat - type Sup Float = SupFloat - --- Double -newtype InfDouble = InfDouble Double -newtype SupDouble = SupDouble Double - -instance Magma InfDouble where - InfDouble a ⊕ InfDouble b = InfDouble (if a <= b then a else b) - -instance Magma SupDouble where - SupDouble a ⊕ SupDouble b = SupDouble (if a >= b then a else b) - -instance Associative InfDouble -instance Associative SupDouble - -instance Commutative SupDouble -instance Commutative InfDouble - -instance Idempotent SupDouble -instance Idempotent InfDouble - -instance Homomorphic SupDouble InfDouble where hom (SupDouble a) = InfDouble (-a) -instance Homomorphic InfDouble SupDouble where hom (InfDouble a) = SupDouble (-a) - -instance Isomorphic SupDouble InfDouble where isomorph = (hom, hom) -instance Isomorphic InfDouble SupDouble where isomorph = (hom, hom) - -instance Semilattice SupDouble -instance Semilattice InfDouble - -instance Lattice Double where - type Inf Double = InfDouble - type Sup Double = SupDouble - diff --git a/src/NumHask/Algebra/Ring.hs b/src/NumHask/Algebra/Ring.hs --- a/src/NumHask/Algebra/Ring.hs +++ b/src/NumHask/Algebra/Ring.hs @@ -1,52 +1,79 @@ {-# OPTIONS_GHC -Wall #-} --- | Rings --- An interesting feature of the NumHask structure is the importance of the commutative Ring ('CRing'), which is a class often needed higher up the class tree. -module NumHask.Algebra.Ring ( - -- * Ring - Semiring +-- | Ring classes. A distinguishment is made between Rings and Commutative Rings. +module NumHask.Algebra.Ring + ( Semiring , Ring , CRing ) where -import Protolude (Double, Float, Int, Integer,Bool(..)) +import Data.Complex (Complex(..)) import NumHask.Algebra.Additive -import NumHask.Algebra.Multiplicative import NumHask.Algebra.Distribution -import Data.Complex (Complex(..)) +import NumHask.Algebra.Multiplicative +import Protolude (Bool(..), Double, Float, Int, Integer) --- | a semiring -class ( Additive a - , MultiplicativeAssociative a - , MultiplicativeUnital a - , Distribution a) => +-- | Semiring +class (MultiplicativeAssociative a, MultiplicativeUnital a, Distribution a) => Semiring a instance Semiring Double + instance Semiring Float + instance Semiring Int + instance Semiring Integer + instance Semiring Bool + instance (AdditiveGroup a, Semiring a) => Semiring (Complex a) -- | Ring +-- a summary of the laws inherited from the ring super-classes +-- +-- > zero + a == a +-- > a + zero == a +-- > (a + b) + c == a + (b + c) +-- > a + b == b + a +-- > a - a = zero +-- > negate a = zero - a +-- > negate a + a = zero +-- > a + negate a = zero +-- > one `times` a == a +-- > a `times` one == a +-- > (a `times` b) `times` c == a `times` (b `times` c) +-- > a `times` (b + c) == a `times` b + a `times` c +-- > (a + b) `times` c == a `times` c + b `times` c +-- > a `times` zero == zero +-- > zero `times` a == zero class ( AdditiveGroup a , MultiplicativeAssociative a , MultiplicativeUnital a - , Distribution a) => + , Distribution a + ) => Ring a instance Ring Double + instance Ring Float + instance Ring Int + instance Ring Integer + instance (Ring a) => Ring (Complex a) --- | CRing is a Commutative Ring. It arises often due to * being defined as only multiplicative commutative. -class ( Multiplicative a, Ring a) => CRing a +-- | CRing is a Ring with Multiplicative Commutation. It arises often due to '*' being defined as a multiplicative commutative operation. +class (Multiplicative a, Ring a) => + CRing a instance CRing Double + instance CRing Float + instance CRing Int + instance CRing Integer + instance (CRing a) => CRing (Complex a) diff --git a/src/NumHask/Examples.hs b/src/NumHask/Examples.hs --- a/src/NumHask/Examples.hs +++ b/src/NumHask/Examples.hs @@ -1,34 +1,39 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE DataKinds #-} +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} -- | NumHask usage examples - -module NumHask.Examples ( - -- * Examples - +module NumHask.Examples + ( -- ** Imports and Pragmas -- $imports - -- $setup + -- $setup -- ** Basic Arithmetic -- $basic + -- ** Complex numbers + -- $complex + -- ** Vectors -- $vector - ) where + -- ** Matrices + -- $matrices + ) where --- import NumHask.Prelude +import Data.Functor.Rep +import NumHask.Matrix +import NumHask.Prelude +import NumHask.Vector -- $imports --- NumHask.Prelude is a complete replacement for the standard prelude. --- --- 'NoImplicitPrelude' is explicitly required as a pragma, and 'ExtendedDefaultRules' is needed to avoid having to explicitly type literal numbers. +-- NumHask.Prelude is a replacement for the standard prelude with the 'NoImplicitPrelude' extension explicitly required. -- -- $setup -- >>> :set -XNoImplicitPrelude --- >>> :set -XExtendedDefaultRules -- >>> import NumHask.Prelude -- -- $basic @@ -36,18 +41,15 @@ -- -- >>> 1 + 1 -- 2 --- -- >>> 1 - 1 -- 0 --- -- >>> 1 * 1 -- 1 --- -- >>> 1 / 1 -- 1.0 -- -- Note that the literal numbers in the divide above defaulted to Float rather than Int. --- +-- -- >>> 1 / (1::Int) -- ... -- ... No instance for (MultiplicativeGroup Int) @@ -55,106 +57,98 @@ -- -- >>> 1 / fromIntegral (1::Int) -- 1.0 --- --- >>> 1 `div` 2 --- 0 -- --- >>> 3 `mod` 2 --- 1 --- -- 'Float' and 'Double' are 'NumHask.Algebra.Fields.Field' instances. -- -- >>> zero == 0.0 -- True --- -- >>> one == 1.0 -- True --- -- >>> 1.0 + 1.0 -- 2.0 --- -- >>> 1.0 - 1.0 -- 0.0 --- -- >>> 1.0 * 1.0 -- 1.0 --- -- >>> 1.0 / 1.0 -- 1.0 -- --- 'BoundedField' lets divide by zero work for 'Float's and 'Double's. +-- 'QuotientField' -- +-- >>> 1 `div` 2 +-- 0 +-- >>> 3 `mod` 2 +-- 1 +-- +-- 'BoundedField' +-- -- >>> one/zero -- Infinity --- -- >>> -one/zero -- -Infinity --- -- >>> zero/zero+one -- NaN --- +-- +-- 'ExpField' +-- -- >>> logBase 2 4 -- 2.0 --- -- >>> 2 ** 2 -- 4.0 --- -- >>> sqrt 4 -- 2.0 --- -- >>> exp 2 -- 7.38905609893065 --- -- >>> log 2 -- 0.6931471805599453 -- +-- $complex +-- +-- >>> let a = 1 :+ 2 +-- >>> a +-- 1 :+ 2 +-- >>> zero - a +-- (-1) :+ (-2) +-- >>> (1 :+ (-2)) * ((-2) :+ 4) +-- 6 :+ 8 +-- >>> (1 :+ (-1)) / (2 :+ 2) +-- 0.0 :+ (-0.5) -- $vector --- A 'Vector' is a number by virtue of it being a 'Representable' 'Functor' where the representation is an 'Int'. +-- A 'Vector' is a 'Representable' 'Functor' where the representation is an 'Int'. -- -- >>> import NumHask.Vector -- >>> :set -XDataKinds -- >>> :set -XOverloadedLists -- >>> [] :: Vector 3 Int -- [0,0,0] --- -- >>> let a = [1..] :: Vector 3 Int -- >>> a -- [1,2,3] --- -- >>> let b = [3,2] :: Vector 3 Int -- >>> b -- [3,2,0] --- --- >>> let c = [1.0,2.0] :: Vector 3 Float --- >>> let d = [3.0,2.0] :: Vector 3 Float --- -- >>> a+zero==a -- True -- >>> zero+a==a -- True -- >>> a+b -- [4,4,3] --- -- >>> a-a == zero -- True --- -- >>> a * b -- [3,4,0] --- -- >>> let a' = unsafeToVector . someVector $ a :: Vector 2 Int -- >>> let b' = unsafeToVector . someVector $ b :: Vector 2 Int -- >>> a' `divMod` b' -- ([0,1],[1,0]) --- +-- >>> let c = [1.0,2.0] :: Vector 3 Float +-- >>> let d = [3.0,2.0] :: Vector 3 Float -- >>> c / d -- [0.33333334,1.0,NaN] --- -- >>> size c :: Float -- 2.236068 --- -- >>> distance c d :: Float -- 2.0 --- -- >>> c <.> d :: Float -- 7.0 -- @@ -165,4 +159,33 @@ -- -- >>> (a >< b) >< (b >< a) -- [[[9,12,0],[6,8,0],[0,0,0]],[[18,24,0],[12,16,0],[0,0,0]],[[27,36,0],[18,24,0],[0,0,0]]] - +-- $matrices +-- A 'Matrix' is a 'Representable' 'Functor' where the representation is an (Int,Int). +-- +-- >>> import NumHask.Matrix +-- >>> :set -XDataKinds +-- >>> :set -XOverloadedLists +-- >>> [] :: Matrix 2 1 Int +-- [[0] +-- [0]] +-- >>> let a = [1..] :: Matrix 2 3 Int +-- >>> let b = trans a +-- >>> a +-- [[1,2,3] +-- [4,5,6]] +-- >>> b +-- [[1,4] +-- [2,5] +-- [3,6]] +-- >>> mmult a b +-- [[14,32] +-- [32,77]] +-- >>> getDiag one == (one :: Vector 6 Int) +-- True +-- >>> diagonal one == (one :: Matrix 4 4 Int) +-- True +-- >>> let a = [1..] :: Matrix 3 3 Int +-- >>> a <.> a +-- 285 +-- >>> toVV a <.> toVV a +-- [66,93,126] diff --git a/src/NumHask/Matrix.hs b/src/NumHask/Matrix.hs --- a/src/NumHask/Matrix.hs +++ b/src/NumHask/Matrix.hs @@ -1,5 +1,15 @@ -{-# LANGUAGE PolyKinds #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wall #-} -- | Two-dimensional arrays. Two classes are supplied @@ -8,184 +18,412 @@ -- - 'SomeMatrix' where shape is held at the value level. -- -- In both cases, the underlying data is contained as a flat vector for efficiency purposes. - module NumHask.Matrix ( Matrix(..) , SomeMatrix(..) - , ShapeM(..) - -- * Conversion + -- ** Conversion , someMatrix , unsafeToMatrix , toMatrix , unsafeFromVV + , toVV , toCol , toRow , fromCol , fromRow , col , row - -- * Operations + , joinc + , joinr + , resize + , reshape + -- ** Operations , mmult + , trans + , getDiag + , diagonal + , mapc + , mapr + -- ** Arbitrary + , ShapeM(..) ) where -import qualified Protolude as P import Data.Distributive as D import Data.Functor.Rep import Data.Proxy (Proxy(..)) -import GHC.TypeLits -import NumHask.Prelude hiding (show) -import NumHask.Naperian -import NumHask.Vector -import Test.QuickCheck import qualified Data.Vector as V -import GHC.Show import GHC.Exts +import GHC.Show +import GHC.TypeLits +import Protolude (Ord(..), Fractional, Functor, Eq, Foldable, Traversable, Maybe(..), ($), (<$>), fmap, (.)) +import NumHask.Algebra +import NumHask.Shape +import NumHask.Vector +import qualified Protolude as P +import Test.QuickCheck hiding (resize) +import Data.Singletons.Prelude.Num +import qualified Data.Matrix as Matrix --- | a two-dimensional array where shape is specified at the type level +-- | A two-dimensional array where shape is specified at the type level -- The main purpose of this, beyond safe typing, is to supply the Representable instance with an initial object. -- A single Boxed 'Data.Vector.Vector' is used underneath for efficient slicing, but this may change or become polymorphic in the future. -newtype Matrix m n a = Matrix { flattenMatrix :: V.Vector a } - deriving (Functor, Eq, Foldable) +-- +-- todo: the natural type for a matrix, the output from a vector outer product for example, is a 'Vector' ('Vector' a). We should be able to unify to a different representation such as this, using type families. +newtype Matrix m n a = Matrix + { flattenMatrix :: V.Vector a + } deriving (Functor, Eq, Foldable, Traversable) instance forall m n. (KnownNat m, KnownNat n) => - HasShape (Matrix (m::Nat) (n::Nat)) where - type Shape (Matrix m n) = (Int,Int) - shape _= ( P.fromInteger $ natVal (Proxy :: Proxy m) - , P.fromInteger $ natVal (Proxy :: Proxy n)) - ndim = P.length . shape - -instance (KnownNat m, KnownNat n) => Naperian (Matrix (m::Nat) (n::Nat)) + HasShape (Matrix (m :: Nat) (n :: Nat)) where + type Shape (Matrix m n) = (Int, Int) + shape _ = + ( P.fromInteger $ natVal (Proxy :: Proxy m) + , P.fromInteger $ natVal (Proxy :: Proxy n)) -instance (Show a, KnownNat m, KnownNat n) => Show (Matrix (m::Nat) (n::Nat) a) where - show = show . someMatrix +instance (Show a, KnownNat m, KnownNat n) => + Show (Matrix (m :: Nat) (n :: Nat) a) where + show m = "[" P.++ P.intercalate "\n " (P.toList (show <$> toVV m)) P.++ "]" -instance (KnownNat m, KnownNat n, Arbitrary a, AdditiveUnital a) => Arbitrary (Matrix m n a) where - arbitrary = frequency - [ (1, P.pure zero) - , (9,fromList <$> vector (m*n)) - ] - where - n = P.fromInteger $ natVal (Proxy :: Proxy n) - m = P.fromInteger $ natVal (Proxy :: Proxy m) +instance (KnownNat m, KnownNat n, Arbitrary a, AdditiveUnital a) => + Arbitrary (Matrix m n a) where + arbitrary = frequency [(1, P.pure zero), (9, fromList <$> vector (m * n))] + where + n = P.fromInteger $ natVal (Proxy :: Proxy n) + m = P.fromInteger $ natVal (Proxy :: Proxy m) instance (KnownNat m, KnownNat n) => Distributive (Matrix m n) where - distribute f = Matrix $ V.generate (n*m) - $ \i -> fmap (\(Matrix v) -> V.unsafeIndex v i) f - where - m = P.fromInteger $ natVal (Proxy :: Proxy m) - n = P.fromInteger $ natVal (Proxy :: Proxy n) + distribute f = + Matrix $ + V.generate (n * m) $ \i -> fmap (\(Matrix v) -> V.unsafeIndex v i) f + where + m = P.fromInteger $ natVal (Proxy :: Proxy m) + n = P.fromInteger $ natVal (Proxy :: Proxy n) instance (KnownNat m, KnownNat n) => Representable (Matrix m n) where - type Rep (Matrix m n) = (P.Int, P.Int) - tabulate f = Matrix $ V.generate (m*n) (\x -> f (divMod x (m*n))) - where - m = P.fromInteger $ natVal (Proxy :: Proxy m) - n = P.fromInteger $ natVal (Proxy :: Proxy n) - index (Matrix xs) (i0,i1) = xs V.! (i0*m + i1) - where - m = P.fromInteger $ natVal (Proxy :: Proxy m) + type Rep (Matrix m n) = (P.Int, P.Int) + tabulate f = Matrix $ V.generate (m * n) (\x -> f (divMod x n)) + where + m = P.fromInteger $ natVal (Proxy :: Proxy m) + n = P.fromInteger $ natVal (Proxy :: Proxy n) + index (Matrix xs) (i0, i1) = xs V.! (i0 * n + i1) + where + n = P.fromInteger $ natVal (Proxy :: Proxy n) -- | a two-dimensional array where shape is specified at the value level as a '(Int,Int)' -- Use this to avoid type-level hasochism by demoting a 'Matrix' with 'someMatrix' -data SomeMatrix a = SomeMatrix (Int,Int) (V.Vector a) - deriving (Functor, Eq, Foldable) +data SomeMatrix a = + SomeMatrix (Int, Int) + (V.Vector a) + deriving (Functor, Eq, Foldable) instance HasShape SomeMatrix where - type Shape SomeMatrix = (Int,Int) - shape (SomeMatrix sh _) = sh - ndim = P.length . shape + type Shape SomeMatrix = (Int, Int) + shape (SomeMatrix sh _) = sh instance (Show a) => Show (SomeMatrix a) where - show (SomeMatrix _ v) = show (P.toList v) - + show (SomeMatrix _ v) = show (P.toList v) -- ** conversion - -- | convert from a 'Matrix' to a 'SomeMatrix' -someMatrix :: (KnownNat m, KnownNat n) => Matrix (m::Nat) (n::Nat) a -> SomeMatrix a +someMatrix :: + (KnownNat m, KnownNat n) => Matrix (m :: Nat) (n :: Nat) a -> SomeMatrix a someMatrix v = SomeMatrix (shape v) (flattenMatrix v) -- | convert from a 'SomeMatrix' to a 'Matrix' with no shape check -unsafeToMatrix :: SomeMatrix a -> Matrix (m::Nat) (n::Nat) a +unsafeToMatrix :: SomeMatrix a -> Matrix (m :: Nat) (n :: Nat) a unsafeToMatrix (SomeMatrix _ v) = Matrix v -- | convert from a 'SomeMatrix' to a 'Matrix', checking shape -toMatrix :: forall a m n. (KnownNat m, KnownNat n) => SomeMatrix a -> - Maybe (Matrix (m::Nat) (n::Nat) a) -toMatrix (SomeMatrix s v) = if s==(m,n) then Just $ Matrix v else Nothing +toMatrix :: + forall a m n. (KnownNat m, KnownNat n) + => SomeMatrix a + -> Maybe (Matrix (m :: Nat) (n :: Nat) a) +toMatrix (SomeMatrix s v) = + if s P.== (m, n) + then Just $ Matrix v + else Nothing where m = P.fromInteger $ natVal (Proxy :: Proxy m) n = P.fromInteger $ natVal (Proxy :: Proxy n) +toDMatrix :: forall a m n. (KnownNat m, KnownNat n) + => Matrix (m :: Nat) (n :: Nat) a + -> Matrix.Matrix a +toDMatrix x = Matrix.matrix m n (\(i,j) -> index x (i-1,j-1)) + where + m = P.fromInteger $ natVal (Proxy :: Proxy m) + n = P.fromInteger $ natVal (Proxy :: Proxy n) + +fromDMatrix :: forall a m n. (AdditiveUnital a, KnownNat m, KnownNat n) + => Matrix.Matrix a + -> Matrix (m :: Nat) (n :: Nat) a +fromDMatrix x = fromList $ Matrix.toList x + -- | from flat list -instance (KnownNat m, KnownNat n, AdditiveUnital a) => IsList (Matrix m n a) where - type Item (Matrix m n a) = a - fromList l = Matrix $ V.fromList $ P.take (m*n) $ l P.++ P.repeat zero - where - m = P.fromInteger $ natVal (Proxy :: Proxy m) - n = P.fromInteger $ natVal (Proxy :: Proxy n) - toList (Matrix v) = V.toList v +instance (KnownNat m, KnownNat n, AdditiveUnital a) => + IsList (Matrix m n a) where + type Item (Matrix m n a) = a + fromList l = Matrix $ V.fromList $ P.take (m * n) $ l P.++ P.repeat zero + where + m = P.fromInteger $ natVal (Proxy :: Proxy m) + n = P.fromInteger $ natVal (Proxy :: Proxy n) + toList (Matrix v) = V.toList v -- | from nested list instance IsList (SomeMatrix a) where - type Item (SomeMatrix a) = [a] - fromList l = - SomeMatrix (P.length l,P.length $ P.head l) (V.fromList $ P.mconcat l) - toList (SomeMatrix (m,n) v) = - (\i -> V.toList $ V.unsafeSlice (i*n) n v) <$> [0..(m - 1)] - --- | just used to get sensible arbitrary instances of SomeMatrix -newtype ShapeM = ShapeM { unshapeM :: (Int,Int) } - -instance Arbitrary ShapeM where - arbitrary = - (\m n -> ShapeM (unshapeV m, unshapeV n)) <$> arbitrary P.<*> arbitrary - -instance (Arbitrary a) => Arbitrary (SomeMatrix a) where - arbitrary = frequency - [ (1, P.pure (SomeMatrix (zero,zero) V.empty)) - , (9,fromList <$> - (P.take <$> - ((\m n -> unshapeV m * unshapeV n) <$> arbitrary P.<*> arbitrary) P.<*> - vector 20)) - ] + type Item (SomeMatrix a) = [a] + fromList l = + SomeMatrix (P.length l, P.length $ P.head l) (V.fromList $ P.mconcat l) + toList (SomeMatrix (m, n) v) = + (\i -> V.toList $ V.unsafeSlice (i * n) n v) <$> [0 .. (m - 1)] -- | conversion from a double Vector representation -unsafeFromVV :: forall a m n. ( ) => Vector m (Vector n a) -> Matrix m n a +unsafeFromVV :: + forall a m n. () + => Vector m (Vector n a) + -> Matrix m n a unsafeFromVV vv = Matrix $ P.foldr ((V.++) . toVec) V.empty vv +-- | conversion to a double Vector representation +toVV :: + forall a m n. (KnownNat m, KnownNat n) + => Matrix m n a + -> Vector m (Vector n a) +toVV m = tabulate (row m) + -- | convert a 'Vector' to a column 'Matrix' -toCol :: forall a n. ( ) => Vector n a -> Matrix 1 n a +toCol :: + forall a n. () + => Vector n a + -> Matrix 1 n a toCol v = Matrix $ toVec v -- | convert a 'Vector' to a row 'Matrix' -toRow :: forall a m. ( ) => Vector m a -> Matrix m 1 a +toRow :: + forall a m. () + => Vector m a + -> Matrix m 1 a toRow v = Matrix $ toVec v -- | convert a row 'Matrix' to a 'Vector' -fromCol :: forall a n. ( ) => Matrix 1 n a -> Vector n a +fromCol :: + forall a n. () + => Matrix 1 n a + -> Vector n a fromCol m = Vector $ flattenMatrix m -- | convert a column 'Matrix' to a 'Vector' -fromRow :: forall a m. ( ) => Matrix m 1 a -> Vector m a +fromRow :: + forall a m. () + => Matrix m 1 a + -> Vector m a fromRow m = Vector $ flattenMatrix m -- | extract a row from a 'Matrix' as a 'Vector' -row :: forall a m n. (KnownNat m, KnownNat n) => P.Int -> Matrix m n a -> Vector n a -row i (Matrix a) = Vector $ V.unsafeSlice (i*m) n a +row :: + forall a m n. (KnownNat m, KnownNat n) + => Matrix m n a + -> Int + -> Vector n a +row (Matrix a) i = Vector $ V.unsafeSlice (i * n) n a where - m = P.fromInteger $ natVal (Proxy :: Proxy m) n = P.fromInteger $ natVal (Proxy :: Proxy n) -- | extract a column from a 'Matrix' as a 'Vector' -col :: forall a m n. (KnownNat m, KnownNat n) => P.Int -> Matrix m n a -> Vector m a -col i (Matrix a) = Vector $ V.generate m (\x -> a V.! (i+x*n)) +col :: + forall a m n. (KnownNat m, KnownNat n) + => Matrix m n a + -> Int + -> Vector m a +col (Matrix a) i = Vector $ V.generate m (\x -> a V.! (i + x * n)) where m = P.fromInteger $ natVal (Proxy :: Proxy m) n = P.fromInteger $ natVal (Proxy :: Proxy n) + +-- | resize matrix, appending with zero if needed +resize :: forall m0 m1 n0 n1 a. ( KnownNat m0, KnownNat m1 + , KnownNat n0, KnownNat n1, AdditiveUnital a) + => Matrix m0 n0 a + -> Matrix m1 n1 a +resize m = tabulate + (\(i,j) -> if i < m0 P.&& i < n0 then index m (i,j) else zero) + where + m0 = P.fromInteger $ natVal (Proxy :: Proxy m0) + n0 = P.fromInteger $ natVal (Proxy :: Proxy n0) + +-- | reshape matrix, appending with zero if needed +reshape :: forall m0 m1 n0 n1 a. ( KnownNat m0, KnownNat m1 + , KnownNat n0, KnownNat n1, AdditiveUnital a) + => Matrix m0 n0 a + -> Matrix m1 n1 a +reshape (Matrix v) = tabulate + (\(i,j) -> if i*n0+j < (m0*n0) then v V.! (i*n0+j) else zero) + where + m0 = P.fromInteger $ natVal (Proxy :: Proxy m0) + n0 = P.fromInteger $ natVal (Proxy :: Proxy n0) + + + -- ** Operations --- | matrix multiplication for a 'Matrix' -mmult :: forall m n k a. (CRing a, KnownNat m, KnownNat n, KnownNat k) => - Matrix m k a -> Matrix k n a -> Matrix m n a -mmult x y = tabulate (\(i,j) -> row i x <.> col j y) +-- | matrix transposition +-- +-- trans . trans == identity +trans :: + forall m n a. (KnownNat m, KnownNat n) + => Matrix m n a + -> Matrix n m a +trans x = tabulate (\(i, j) -> index x (j,i)) + +-- | extract the matrix diagonal as a vector +-- +-- > getDiag one == one +getDiag :: + forall n a. (KnownNat n) + => Matrix n n a + -> Vector n a +getDiag x = tabulate (\i -> index x (i,i)) + +-- | create a matrix using a vector as the diagonal +-- +-- > diagonal one = one +-- > getDiag . diagonal == identity +diagonal :: forall n a. (KnownNat n, AdditiveUnital a) + => Vector n a + -> Matrix n n a +diagonal v = tabulate (\(i,j) -> if i P.== j then index v i else zero) + +inv :: + forall n a. (BoundedField a, Eq a, Fractional a, KnownNat n) + => Matrix n n a + -> Matrix n n a +inv = P.either (P.const $ singleton nan) fromDMatrix . Matrix.inverse . toDMatrix + +-- | map a homomorphic vector function, row-wise +mapr :: + forall m n a. (KnownNat m, KnownNat n) + => (Vector n a -> Vector n a) + -> Matrix m n a + -> Matrix m n a +mapr f x = unsafeFromVV $ tabulate (f . row x) + +-- | map a homomorphic vector function, column-wise +mapc :: + forall m n a. (KnownNat m, KnownNat n) + => (Vector m a -> Vector m a) + -> Matrix m n a + -> Matrix m n a +mapc f x = unsafeFromVV $ distribute $ tabulate (f . col x) + +-- | matrix multiplication +mmult :: + forall m n k a. (Hilbert (Vector k) a, KnownNat m, KnownNat n, KnownNat k) + => Matrix m k a + -> Matrix k n a + -> Matrix m n a +mmult x y = tabulate (\(i, j) -> row x i <.> col y j) + +-- | join column-wise +joinc :: forall m n0 n1 a. ( KnownNat m + , KnownNat n0 + , KnownNat n1 + , Representable (Matrix m (n0 :+ n1))) + => Matrix m n0 a + -> Matrix m n1 a + -> Matrix m (n0 :+ n1) a +joinc x y = tabulate + (\(i,j) -> if j Matrix m0 n a + -> Matrix m1 n a + -> Matrix (m0 :+ m1) n a +joinr x y = tabulate + (\(i,j) -> if i ShapeM (unshapeV m, unshapeV n)) <$> arbitrary P.<*> arbitrary + +instance (Arbitrary a) => Arbitrary (SomeMatrix a) where + arbitrary = + frequency + [ (1, P.pure (SomeMatrix (zero, zero) V.empty)) + , ( 9 + , fromList <$> + (P.take <$> + ((\m n -> unshapeV m * unshapeV n) <$> arbitrary P.<*> arbitrary) P.<*> + vector 20)) + ] + +-- NumHask heirarchy +instance (KnownNat m, KnownNat n, AdditiveMagma a) => + AdditiveMagma (Matrix m n a) where + plus = liftR2 plus + +instance (KnownNat m, KnownNat n, AdditiveUnital a) => + AdditiveUnital (Matrix m n a) where + zero = singleton zero + +instance (KnownNat m, KnownNat n, AdditiveAssociative a) => + AdditiveAssociative (Matrix m n a) + +instance (KnownNat m, KnownNat n, AdditiveCommutative a) => + AdditiveCommutative (Matrix m n a) + +instance (KnownNat m, KnownNat n, AdditiveInvertible a) => + AdditiveInvertible (Matrix m n a) where + negate = fmapRep negate + +instance (KnownNat m, KnownNat n, Additive a) => Additive (Matrix m n a) + +instance (KnownNat m, KnownNat n, AdditiveGroup a) => + AdditiveGroup (Matrix m n a) + +instance (KnownNat n, Semiring a) => + MultiplicativeMagma (Matrix n n a) where + times = mmult + +instance (KnownNat n, Semiring a) => + MultiplicativeUnital (Matrix n n a) where + one = tabulate (\(i,j) -> if i P.== j then one else zero) + +instance (KnownNat n, Semiring a) => + MultiplicativeAssociative (Matrix n n a) + +instance (KnownNat n, Fractional a, Eq a, BoundedField a, Semiring a) => + MultiplicativeInvertible (Matrix n n a) where + recip = NumHask.Matrix.inv + +instance (KnownNat n, Semiring a) => + Distribution (Matrix n n a) + +instance (KnownNat n, Semiring a) => + Semiring (Matrix n n a) + +instance (KnownNat n, AdditiveGroup a, Semiring a) => + Ring (Matrix n n a) + +instance (Eq a, Fractional a, BoundedField a, KnownNat n, AdditiveGroup a, Semiring a) => + Semifield (Matrix n n a) + +instance (KnownNat m, KnownNat n, Epsilon a) => Epsilon (Matrix m n a) where + nearZero f = P.and (fmapRep nearZero f) + aboutEqual a b = P.and (liftR2 aboutEqual a b) + +instance (Semiring a, KnownNat m, KnownNat n) => Hilbert (Matrix m n) a + diff --git a/src/NumHask/Naperian.hs b/src/NumHask/Naperian.hs deleted file mode 100644 --- a/src/NumHask/Naperian.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | multi-dimensional representable numbers -module NumHask.Naperian - ( Naperian - , HasShape(..) - , module Data.Functor.Rep - ) where - -import Protolude (Int, foldr, Foldable(..), ($), (<$>), fmap, fst, snd, or, and) -import Data.Functor.Rep -import NumHask.Prelude - --- | ToDo: integrate with Naperian instance -class HasShape f where - type Shape f - shape :: f a -> Shape f - ndim :: f a -> Int - -class (HasShape f, Representable f) => Naperian f - -instance {-# Overlappable #-} (Naperian f, AdditiveMagma a) => AdditiveMagma (f a) where - plus = liftR2 plus -instance {-# Overlappable #-} (Naperian f, AdditiveUnital a) => AdditiveUnital (f a) where - zero = pureRep zero -instance {-# Overlappable #-} (Naperian f, AdditiveAssociative a) => AdditiveAssociative (f a) -instance {-# Overlappable #-} (Naperian f, AdditiveCommutative a) => AdditiveCommutative (f a) -instance {-# Overlappable #-} (Naperian f, AdditiveInvertible a) => AdditiveInvertible (f a) where - negate = fmapRep negate -instance {-# Overlappable #-} (Naperian f, AdditiveMagma a) => AdditiveHomomorphic a (f a) where - plushom a = pureRep a -instance {-# Overlappable #-} (Naperian f, AdditiveMonoidal a) => AdditiveMonoidal (f a) -instance {-# Overlappable #-} (Naperian f, Additive a) => Additive (f a) -instance {-# Overlappable #-} (Naperian f, AdditiveGroup a) => AdditiveGroup (f a) - -instance {-# Overlappable #-} (Naperian f, MultiplicativeMagma a) => MultiplicativeMagma (f a) where - times = liftR2 times -instance {-# Overlappable #-} (Naperian f, MultiplicativeUnital a) => MultiplicativeUnital (f a) where - one = pureRep one -instance {-# Overlappable #-} (Naperian f, MultiplicativeAssociative a) => MultiplicativeAssociative (f a) -instance {-# Overlappable #-} (Naperian f, MultiplicativeCommutative a) => MultiplicativeCommutative (f a) -instance {-# Overlappable #-} (Naperian f, MultiplicativeInvertible a) => MultiplicativeInvertible (f a) where - recip = fmapRep recip -instance {-# Overlappable #-} (Naperian f, MultiplicativeMagma a) => MultiplicativeHomomorphic a (f a) where - timeshom a = pureRep a -instance {-# Overlappable #-} (Naperian f, MultiplicativeMonoidal a) => MultiplicativeMonoidal (f a) -instance {-# Overlappable #-} (Naperian f, Multiplicative a) => Multiplicative (f a) -instance {-# Overlappable #-} (Naperian f, MultiplicativeGroup a) => MultiplicativeGroup (f a) - -instance {-# Overlappable #-} (Naperian f, MultiplicativeMagma a, Additive a) => Distribution (f a) - -instance {-# Overlappable #-} (Naperian f, Semiring a) => Semiring (f a) -instance {-# Overlappable #-} (Naperian f, Ring a) => Ring (f a) -instance {-# Overlappable #-} (Naperian f, CRing a) => CRing (f a) -instance {-# Overlappable #-} (Naperian f, Field a) => Field (f a) - -instance {-# Overlappable #-} (Naperian f, ExpField a) => ExpField (f a) where - exp = fmapRep exp - log = fmapRep log - -instance {-# Overlappable #-} (Naperian f, BoundedField a, Foldable f) => BoundedField (f a) where - isNaN f = or (fmapRep isNaN f) - -instance {-# Overlappable #-} (Naperian f, Signed a) => Signed (f a) where - sign = fmapRep sign - abs = fmapRep abs - -instance {-# Overlappable #-} (Foldable f, Naperian f, ExpField a) => - Normed (f a) a where - size r = sqrt $ foldr (+) zero $ (**(one+one)) <$> r - -instance {-# Overlappable #-} (Foldable f, Naperian f, Epsilon a) => Epsilon (f a) where - nearZero f = and (fmapRep nearZero f) - aboutEqual a b = and (liftR2 aboutEqual a b) - -instance {-# Overlappable #-} (Foldable f, Naperian f, ExpField a) => Metric (f a) a where - distance a b = size (a - b) - -instance {-# Overlappable #-} (Naperian f, Integral a) => Integral (f a) where - divMod a b = (d,m) - where - x = liftR2 divMod a b - d = fmap fst x - m = fmap snd x diff --git a/src/NumHask/Prelude.hs b/src/NumHask/Prelude.hs --- a/src/NumHask/Prelude.hs +++ b/src/NumHask/Prelude.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE ExtendedDefaultRules #-} +{-# OPTIONS_HADDOCK hide #-} {-# OPTIONS_GHC -Wall #-} -- | A prelude for NumHask - -module NumHask.Prelude ( - -- * Backend +module NumHask.Prelude + ( -- * Backend -- $backend module Protolude + -- * Algebraic Heirarchy -- $instances , module NumHask.Algebra.Additive @@ -18,40 +18,25 @@ , module NumHask.Algebra.Metric , module NumHask.Algebra.Module , module NumHask.Algebra.Multiplicative - , module NumHask.Algebra.Ordering , module NumHask.Algebra.Ring + + -- * Representable Functors over numbers + -- $representable + , module Data.Functor.Rep + , module NumHask.Shape + , module NumHask.Vector + , module NumHask.Matrix ) where -import Protolude hiding - ( (+) - , (-) - , (*) - , (/) - , zero - , negate - , recip - , Integral(..) - , round - , ceiling - , floor - , (^^) - , Semiring(..) - , log - , logBase - , exp - , sqrt - , (**) - , abs - , (^) - , infinity - , Bounded(..) - , isNaN - , fromIntegral - , toInteger - , fromInteger - , Rep - ) +import Protolude + hiding (Bounded(..), Integral(..), Rep, Semiring(..), (*), (**), + (+), (-), (/), (^), (^^), abs, acos, acosh, asin, asinh, atan, + atan2, atanh, ceiling, cos, cosh, exp, floor, fromInteger, + fromIntegral, infinity, isNaN, log, logBase, negate, pi, product, + recip, round, sin, sinh, sqrt, sum, tan, tanh, toInteger, trans, + zero) +import Data.Functor.Rep import NumHask.Algebra.Additive import NumHask.Algebra.Basis import NumHask.Algebra.Distribution @@ -61,15 +46,21 @@ import NumHask.Algebra.Metric import NumHask.Algebra.Module import NumHask.Algebra.Multiplicative -import NumHask.Algebra.Ordering import NumHask.Algebra.Ring +import NumHask.Matrix +import NumHask.Shape +import NumHask.Vector -- $backend -- NumHask imports Protolude as the prelude and replaces much of the 'Num' heirarchy in base. -- Usage of 'Semigroup' and 'Monoid' has been avoided to retain basic compatability. - -- $instances -- Re-defines the numeric tower. -- --- Instances for 'Int', 'Integer', 'Float', 'Double', 'Bool' and 'Complex' are supplied +-- Instances for 'Int', 'Integer', 'Float', 'Double', 'Bool' and 'Complex' are supplied. -- + +-- $representable +-- NumHask uses 'Representable' functors over number classes to supply useful vectors and matrices that are themselves numbers (ie satisfy the class laws). +-- +-- 'Vector' and 'Matrix' instances are supplied with shape held at the type-level. diff --git a/src/NumHask/Shape.hs b/src/NumHask/Shape.hs new file mode 100644 --- /dev/null +++ b/src/NumHask/Shape.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wall #-} + +-- | numbers with a shape +module NumHask.Shape + ( HasShape(..) + -- * Representable + -- | Representable has most of what's needed to define numbers that have elements (aka scalars) and a fixed shape. + , Representable(..) + , Singleton(..) + ) where + +import Data.Functor.Rep + +-- | Not everything that has a shape is representable. +-- +-- todo: Structure is a useful alternative concept/naming convention +class HasShape f where + type Shape f + shape :: f a -> Shape f + +-- Undecidable + missing method +-- instance (Representable f) => HasShape f where +-- type Shape f = Rep f +-- | This class could also be called replicate. Looking forward, however, it may be useful to consider a Representable such as +-- +-- > VectorThing a = Vector a | Single a | Zero +-- +-- and then +-- +-- > singleton a = Single a +-- > singleton zero = Zero +-- +-- short-circuiting an expensive computation. As the class action then doesn't actually involve replication, it would be mis-named. +-- +class Singleton f where + singleton :: a -> f a + +instance (Representable f) => Singleton f where + singleton = pureRep diff --git a/src/NumHask/Vector.hs b/src/NumHask/Vector.hs --- a/src/NumHask/Vector.hs +++ b/src/NumHask/Vector.hs @@ -1,126 +1,240 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wall #-} --- | Two different classes are supplied: +-- | Two classes are supplied: -- --- - 'Vector' where shape information is held at the type level, and --- - 'SomeVector' where shape is held at the value level. - +-- - A 'Vector' class, with fixed-length n, where shape is held at the type level. +-- - A 'SomeVector' class, with fixed-length, where shape is held at the value level. module NumHask.Vector ( Vector(..) , SomeVector(..) - , ShapeV(..) -- ** Conversion , someVector , unsafeToVector , toVector + -- ** Arbitrary + , ShapeV(..) ) where -import qualified Protolude as P import Data.Distributive as D +import Data.Foldable +import Data.Functor.Classes import Data.Functor.Rep import Data.Proxy (Proxy(..)) +import qualified Data.Vector as V import GHC.Exts import GHC.Show (show) import GHC.TypeLits -import NumHask.Prelude hiding (show) -import NumHask.Naperian -import Test.QuickCheck -import qualified Data.Vector as V +import NumHask.Algebra +import NumHask.Shape +import Protolude + (Maybe(..), ($), (.), (<$>), fmap, fst, identity, snd, take) +import qualified Protolude as P +import qualified Test.QuickCheck as QC --- | a one-dimensional array where shape is specified at the type level --- The main purpose of this, beyond safe typing, is to supply the Representable instance with an initial object. --- A Boxed 'Data.Vector.Vector' is used underneath for efficient slicing, but this may change or become polymorphic in the future. -newtype Vector (n::Nat) a = Vector { toVec :: V.Vector a } - deriving (Functor, Eq, Foldable, Ord) +-- | A one-dimensional array where shape is specified at the type level +-- The main purpose of this, beyond safe-typing, is to supply the Representable instance with an initial object. +-- A boxed 'Data.Vector.Vector' is used under the hood. +newtype Vector (n :: Nat) a = Vector + { toVec :: V.Vector a + } deriving (P.Eq, P.Functor, Foldable, P.Traversable) -instance forall n. (KnownNat n) => - HasShape (Vector (n::Nat)) where - type Shape (Vector n) = Int - shape _ = P.fromInteger $ natVal (Proxy :: Proxy n) - ndim _ = 1 +instance Eq1 (Vector n) where + liftEq c (Vector a) (Vector b) = V.all identity $ V.zipWith c a b -instance (KnownNat n) => Naperian (Vector (n::Nat)) +instance (P.Show a, KnownNat n) => P.Show (Vector (n :: Nat) a) where + show = show . someVector -instance (Show a, KnownNat n) => Show (Vector (n::Nat) a) where - show = show . someVector +-- | pads with 'zero's if needed +instance (KnownNat n, AdditiveUnital a) => IsList (Vector n a) where + type Item (Vector n a) = a + fromList l = Vector $ V.fromList $ P.take n $ l P.++ P.repeat zero + where + n = P.fromInteger $ natVal (Proxy :: Proxy n) + toList = Data.Foldable.toList -instance (KnownNat n, Arbitrary a, AdditiveUnital a) => Arbitrary (Vector n a) where - arbitrary = frequency - [ (1, P.pure zero) - , (9, fromList <$> vector n) - ] - where - n = P.fromInteger $ natVal (Proxy :: Proxy n) +instance forall n. (KnownNat n) => HasShape (Vector (n :: Nat)) where + type Shape (Vector n) = Int + shape _ = P.fromInteger $ natVal (Proxy :: Proxy n) instance KnownNat n => D.Distributive (Vector n) where - distribute f = Vector $ V.generate n $ \i -> fmap (\(Vector v) -> V.unsafeIndex v i) f - where - n = P.fromInteger $ natVal (Proxy :: Proxy n) + distribute f = + Vector $ V.generate n $ \i -> fmap (\(Vector v) -> V.unsafeIndex v i) f + where + n = P.fromInteger $ natVal (Proxy :: Proxy n) instance KnownNat n => Representable (Vector n) where - type Rep (Vector n) = P.Int - tabulate = Vector P.. V.generate n0 - where - n0 = P.fromInteger $ natVal (Proxy :: Proxy n) - index (Vector xs) i = xs V.! i + type Rep (Vector n) = P.Int + tabulate = Vector P.. V.generate n + where + n = P.fromInteger $ natVal (Proxy :: Proxy n) + index (Vector xs) i = xs V.! i +instance (KnownNat n) => P.Applicative (Vector n) where + pure = pureRep + (<*>) = liftR2 ($) + +instance (KnownNat n, QC.Arbitrary a, AdditiveUnital a) => + QC.Arbitrary (Vector n a) where + arbitrary = QC.frequency [(1, P.pure zero), (9, fromList <$> QC.vector n)] + where + n = P.fromInteger $ natVal (Proxy :: Proxy n) + -- | a one-dimensional array where shape is specified at the value level --- Use this to avoid type-level hasochism by demoting a 'Vector' with 'someVector' -data SomeVector a = SomeVector Int (V.Vector a) - deriving (Functor, Eq, Foldable, Ord) +data SomeVector a = + SomeVector Int + (V.Vector a) + deriving (P.Functor, P.Eq, Foldable, P.Ord) instance HasShape SomeVector where - type Shape SomeVector = Int - shape (SomeVector sh _) = sh - ndim _ = 1 + type Shape SomeVector = Int + shape (SomeVector sh _) = sh -instance (Show a) => Show (SomeVector a) where - show (SomeVector _ v) = show (P.toList v) +instance (P.Show a) => P.Show (SomeVector a) where + show (SomeVector _ v) = show (P.toList v) +instance IsList (SomeVector a) where + type Item (SomeVector a) = a + fromList l = SomeVector (P.length l) (V.fromList l) + toList (SomeVector _ v) = V.toList v + -- ** conversion -- | convert from a 'Vector' to a 'SomeVector' -someVector :: (KnownNat r) => Vector (r::Nat) a -> SomeVector a +someVector :: (KnownNat r) => Vector (r :: Nat) a -> SomeVector a someVector v = SomeVector (shape v) (toVec v) -- | convert from a 'SomeVector' to a 'Vector' with no shape check -unsafeToVector :: SomeVector a -> Vector (r::Nat) a +unsafeToVector :: SomeVector a -> Vector (r :: Nat) a unsafeToVector (SomeVector _ v) = Vector v -- | convert from a 'SomeVector' to a 'Vector', checking shape -toVector :: forall a r. (KnownNat r) => SomeVector a -> Maybe (Vector (r::Nat) a) -toVector (SomeVector s v) = if s==n then Just $ Vector v else Nothing +toVector :: + forall a r. (KnownNat r) + => SomeVector a + -> P.Maybe (Vector (r :: Nat) a) +toVector (SomeVector s v) = + if s P.== n + then Just $ Vector v + else Nothing where n = P.fromInteger $ natVal (Proxy :: Proxy r) --- | pads with 'zero' if needed -instance (KnownNat n, AdditiveUnital a) => IsList (Vector n a) where - type Item (Vector n a) = a - fromList l = Vector $ V.fromList $ P.take n $ l P.++ P.repeat zero - where - n = P.fromInteger $ natVal (Proxy :: Proxy n) - toList (Vector v) = V.toList v +-- ** arbitrary +-- | ShapeV is used to generate sensible lengths for arbitrary instances of 'SomeVector' and 'SomeMatrix' +newtype ShapeV = ShapeV + { unshapeV :: Int + } -instance IsList (SomeVector a) where - type Item (SomeVector a) = a - fromList l = SomeVector (P.length l) (V.fromList l) - toList (SomeVector _ v) = V.toList v +instance QC.Arbitrary ShapeV where + arbitrary = + QC.frequency + [ (1, P.pure $ ShapeV 0) + , (1, P.pure $ ShapeV 1) + , (1, P.pure $ ShapeV 2) + , (1, P.pure $ ShapeV 3) + , (1, P.pure $ ShapeV 6) + , (1, P.pure $ ShapeV 20) + ] --- | used to get sensible arbitrary instances of SomeVector -newtype ShapeV = ShapeV { unshapeV :: Int } +instance (QC.Arbitrary a) => QC.Arbitrary (SomeVector a) where + arbitrary = + QC.frequency + [ (1, P.pure (SomeVector 0 V.empty)) + , ( 9 + , fromList <$> (take <$> (unshapeV <$> QC.arbitrary) P.<*> QC.vector 20)) + ] -instance Arbitrary ShapeV where - arbitrary = frequency - [ (1, P.pure $ ShapeV 0) - , (1, P.pure $ ShapeV 1) - , (1, P.pure $ ShapeV 2) - , (1, P.pure $ ShapeV 3) - , (1, P.pure $ ShapeV 6) - , (1, P.pure $ ShapeV 20) - ] +instance (KnownNat n, AdditiveMagma a) => AdditiveMagma (Vector n a) where + plus = liftR2 plus -instance (Arbitrary a) => Arbitrary (SomeVector a) where - arbitrary = frequency - [ (1, P.pure (SomeVector 0 V.empty)) - , (9, fromList <$> (take <$> (unshapeV <$> arbitrary) P.<*> vector 20)) - ] +instance (KnownNat n, AdditiveUnital a) => AdditiveUnital (Vector n a) where + zero = singleton zero + +instance (KnownNat n, AdditiveAssociative a) => + AdditiveAssociative (Vector n a) + +instance (KnownNat n, AdditiveCommutative a) => + AdditiveCommutative (Vector n a) + +instance (KnownNat n, AdditiveInvertible a) => + AdditiveInvertible (Vector n a) where + negate = fmapRep negate + +instance (KnownNat n, Additive a) => Additive (Vector n a) + +instance (KnownNat n, AdditiveGroup a) => AdditiveGroup (Vector n a) + +instance (KnownNat n, MultiplicativeMagma a) => + MultiplicativeMagma (Vector n a) where + times = liftR2 times + +instance (KnownNat n, MultiplicativeUnital a) => + MultiplicativeUnital (Vector n a) where + one = singleton one + +instance (KnownNat n, MultiplicativeAssociative a) => + MultiplicativeAssociative (Vector n a) + +instance (KnownNat n, MultiplicativeCommutative a) => + MultiplicativeCommutative (Vector n a) + +instance (KnownNat n, MultiplicativeInvertible a) => + MultiplicativeInvertible (Vector n a) where + recip = fmapRep recip + +instance (KnownNat n, Multiplicative a) => Multiplicative (Vector n a) + +instance (KnownNat n, MultiplicativeGroup a) => + MultiplicativeGroup (Vector n a) + +instance (KnownNat n, MultiplicativeMagma a, Additive a) => + Distribution (Vector n a) + +instance (KnownNat n, Semiring a) => Semiring (Vector n a) + +instance (KnownNat n, Ring a) => Ring (Vector n a) + +instance (KnownNat n, CRing a) => CRing (Vector n a) + +instance (KnownNat n, Field a) => Field (Vector n a) + +instance (KnownNat n, ExpField a) => ExpField (Vector n a) where + exp = fmapRep exp + log = fmapRep log + +instance (KnownNat n, BoundedField a) => BoundedField (Vector n a) where + isNaN f = or (fmapRep isNaN f) + +instance (KnownNat n, Signed a) => Signed (Vector n a) where + sign = fmapRep sign + abs = fmapRep abs + +instance (ExpField a) => Normed (Vector n a) a where + size r = sqrt $ foldr (+) zero $ (** (one + one)) <$> r + +instance (KnownNat n, Epsilon a) => Epsilon (Vector n a) where + nearZero f = and (fmapRep nearZero f) + aboutEqual a b = and (liftR2 aboutEqual a b) + +instance (KnownNat n, ExpField a) => Metric (Vector n a) a where + distance a b = size (a - b) + +instance (KnownNat n, Integral a) => Integral (Vector n a) where + divMod a b = (d, m) + where + x = liftR2 divMod a b + d = fmap fst x + m = fmap snd x + +instance (Semiring a, KnownNat n) => Hilbert (Vector n) a diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -1,891 +1,674 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} -{-# OPTIONS_GHC -Wall #-} - -module Main where - -import NumHask.Prelude -import NumHask.Vector -import NumHask.Matrix -import NumHask.Naperian - -import Test.Tasty (TestName, TestTree, testGroup, defaultMain, localOption) -import Test.Tasty.QuickCheck -import Test.DocTest - -main :: IO () -main = do - doctest ["src/NumHask/Examples.hs"] - defaultMain tests - -data LawArity a = - Nonary Bool | - Unary (a -> Bool) | - Binary (a -> a -> Bool) | - Ternary (a -> a -> a -> Bool) | - Ornary (a -> a -> a -> a -> Bool) | - Failiary (a -> Property) - -data LawArity2 a b = - Unary2 (a -> Bool) | - Binary2 (a -> b -> Bool) | - Ternary2 (a -> a -> b -> Bool) | - Ternary2' (a -> b -> b -> Bool) | - Failiary2 (a -> Property) - -type Law a = (TestName, LawArity a) - -type Law2 a b = (TestName, LawArity2 a b) - -testLawOf :: (Arbitrary a, Show a) => [a] -> Law a -> TestTree -testLawOf _ (name, Nonary f) = testProperty name f -testLawOf _ (name, Unary f) = testProperty name f -testLawOf _ (name, Binary f) = testProperty name f -testLawOf _ (name, Ternary f) = testProperty name f -testLawOf _ (name, Ornary f) = testProperty name f -testLawOf _ (name, Failiary f) = testProperty name f - -testLawOf2 :: (Arbitrary a, Show a, Arbitrary b, Show b) => - [(a,b)] -> Law2 a b -> TestTree -testLawOf2 _ (name, Unary2 f) = testProperty name f -testLawOf2 _ (name, Binary2 f) = testProperty name f -testLawOf2 _ (name, Ternary2 f) = testProperty name f -testLawOf2 _ (name, Ternary2' f) = testProperty name f -testLawOf2 _ (name, Failiary2 f) = testProperty name f - -tests :: TestTree -tests = - testGroup "NumHask" - [ testsInt - , testsFloat - , testsBool - , testsVInt - , testsVFloat - , testsMInt - , testsMFloat - , testsComplexFloat - ] - -testsInt :: TestTree -testsInt = testGroup "Int" - [ testGroup "Additive" $ testLawOf ([]::[Int]) <$> - additiveLaws - , testGroup "Additive Group" $ testLawOf ([]::[Int]) <$> - additiveGroupLaws - , testGroup "Multiplicative" $ testLawOf ([]::[Int]) <$> - multiplicativeLaws - , testGroup "Distribution" $ testLawOf ([]::[Int]) - <$> distributionLaws - , testGroup "Integral" $ testLawOf ([]::[Int]) <$> - integralLaws - , testGroup "Signed" $ testLawOf ([]::[Int]) <$> - signedLaws - ] - -testsFloat :: TestTree -testsFloat = testGroup "Float" - [ testGroup "Additive - Associative Fail" $ testLawOf ([]::[Float]) <$> - additiveLawsFail - , testGroup "Additive Group" $ testLawOf ([]::[Float]) <$> - additiveGroupLaws - , testGroup "Multiplicative - Associative Fail" $ - testLawOf ([]::[Float]) <$> - multiplicativeLawsFail - , testGroup "MultiplicativeGroup" $ testLawOf ([]::[Float]) <$> - multiplicativeGroupLaws - , testGroup "Distribution - Fail" $ testLawOf ([]::[Float]) <$> - distributionLawsFail - , testGroup "Signed" $ testLawOf ([]::[Float]) <$> - signedLaws - , testGroup "Bounded Field" $ testLawOf ([]::[Float]) <$> - boundedFieldLaws - , testGroup "Metric" $ testLawOf ([]::[Float]) <$> metricFloatLaws - , testGroup "Quotient Field" $ testLawOf ([]::[Float]) <$> - quotientFieldLaws - , testGroup "Exponential Field" $ testLawOf ([]::[Float]) <$> expFieldLaws - ] - -testsBool :: TestTree -testsBool = testGroup "Bool" - [ testGroup "Idempotent" $ testLawOf ([]::[Bool]) <$> - idempotentLaws - , testGroup "Additive" $ testLawOf ([]::[Bool]) <$> - additiveLaws - , testGroup "Multiplicative" $ testLawOf ([]::[Bool]) <$> - multiplicativeLaws - , testGroup "Distribution" $ testLawOf ([]::[Bool]) - <$> distributionLaws - ] - -testsComplexFloat :: TestTree -testsComplexFloat = testGroup "Complex Float" - [ testGroup "Additive - Associative Fail" $ testLawOf ([]::[Complex Float]) <$> - additiveLawsFail - , testGroup "Additive Group" $ testLawOf ([]::[Complex Float]) <$> - additiveGroupLaws - , testGroup "Multiplicative - Associative Fail" $ - testLawOf ([]::[Complex Float]) <$> - multiplicativeLawsFail - , testGroup "MultiplicativeGroup" $ testLawOf ([]::[Complex Float]) <$> - multiplicativeGroupLaws - , testGroup "Distribution - Fail" $ testLawOf ([]::[Complex Float]) <$> - distributionLawsFail - -- , testGroup "Bounded Field" $ testLawOf ([]::[Complex Float]) <$> - -- boundedFieldLaws - -- , testGroup "Exponential Field" $ testLawOf ([]::[Complex Float]) <$> expFieldLaws - , testGroup "Metric" $ testLawOf ([]::[Complex Float]) <$> metricComplexFloatLaws - ] - -testsVInt :: TestTree -testsVInt = testGroup "Vector 6 Int" - [ testGroup "Additive" $ testLawOf ([]::[Vector 6 Int]) <$> - additiveLaws - , testGroup "Additive Group" $ testLawOf ([]::[Vector 6 Int]) <$> - additiveGroupLaws - , testGroup "Multiplicative" $ testLawOf ([]::[Vector 6 Int]) <$> - multiplicativeLaws - , testGroup "Distribution" $ testLawOf ([]::[Vector 6 Int]) - <$> distributionLaws - , testGroup "Additive Module" $ testLawOf2 ([]::[(Vector 6 Int, Int)]) <$> - additiveModuleLaws - , testGroup "Additive Group Module" $ testLawOf2 ([]::[(Vector 6 Int, Int)]) <$> - additiveGroupModuleLaws - , testGroup "Multiplicative Module" $ testLawOf2 ([]::[(Vector 6 Int, Int)]) <$> - multiplicativeModuleLaws - , testGroup "Additive Basis" $ testLawOf ([]::[Vector 6 Int]) <$> - additiveBasisLaws - , testGroup "Additive Group Basis" $ testLawOf ([]::[Vector 6 Int]) <$> - additiveGroupBasisLaws - , testGroup "Multiplicative Basis" $ testLawOf ([]::[Vector 6 Int]) <$> - multiplicativeBasisLaws - ] - -testsMInt :: TestTree -testsMInt = testGroup "Matrix 4 3 Int" - [ testGroup "Additive" $ testLawOf ([]::[Matrix 4 3 Int]) <$> - additiveLaws - , testGroup "Additive Group" $ testLawOf ([]::[Matrix 4 3 Int]) <$> - additiveGroupLaws - , testGroup "Multiplicative" $ testLawOf ([]::[Matrix 4 3 Int]) <$> - multiplicativeLaws - , testGroup "Distribution" $ testLawOf ([]::[Matrix 4 3 Int]) - <$> distributionLaws - , testGroup "Additive Module" $ testLawOf2 ([]::[(Matrix 4 3 Int, Int)]) <$> - additiveModuleLaws - , testGroup "Additive Group Module" $ testLawOf2 ([]::[(Matrix 4 3 Int, Int)]) <$> - additiveGroupModuleLaws - , testGroup "Multiplicative Module" $ testLawOf2 ([]::[(Matrix 4 3 Int, Int)]) <$> - multiplicativeModuleLaws - , testGroup "Additive Basis" $ testLawOf ([]::[Matrix 4 3 Int]) <$> - additiveBasisLaws - , testGroup "Additive Group Basis" $ testLawOf ([]::[Matrix 4 3 Int]) <$> - additiveGroupBasisLaws - , testGroup "Multiplicative Basis" $ testLawOf ([]::[Matrix 4 3 Int]) <$> - multiplicativeBasisLaws - ] - -testsVFloat :: TestTree -testsVFloat = testGroup "Vector 6 Float" - [ testGroup "Additive - Associative" $ - localOption (QuickCheckTests 1000) . testLawOf ([]::[Vector 6 Float]) <$> - additiveLawsFail - , testGroup "Additive Group" $ - testLawOf ([]::[Vector 6 Float]) <$> - additiveGroupLaws - , testGroup "Multiplicative - Associative" $ - localOption (QuickCheckTests 1000) . testLawOf ([]::[Vector 6 Float]) <$> - multiplicativeLawsFail - , testGroup "MultiplicativeGroup" $ testLawOf ([]::[Vector 6 Float]) <$> - multiplicativeGroupLaws - , testGroup "Distribution" $ - localOption (QuickCheckTests 1000) . testLawOf ([]::[Vector 6 Float]) <$> - distributionLawsFail - , testGroup "Signed" $ testLawOf ([]::[Vector 6 Float]) <$> - signedLaws - , testGroup "Metric" $ testLawOf ([]::[Vector 6 Float]) <$> - metricNaperianFloatLaws - , testGroup "Exponential Field" $ testLawOf ([]::[Vector 6 Float]) <$> - expFieldNaperianLaws - , testGroup "Additive Module" $ localOption (QuickCheckTests 1000) . - testLawOf2 ([]::[(Vector 6 Float, Float)]) <$> - additiveModuleLawsFail - , testGroup "Additive Group Module" $ localOption (QuickCheckTests 1000) . - testLawOf2 ([]::[(Vector 6 Float, Float)]) <$> - additiveGroupModuleLawsFail - , testGroup "Multiplicative Module" $ localOption (QuickCheckTests 1000) . - testLawOf2 ([]::[(Vector 6 Float, Float)]) <$> - multiplicativeModuleLawsFail - , testGroup "Multiplicative Group Module" $ localOption (QuickCheckTests 1000) . - testLawOf2 ([]::[(Vector 6 Float, Float)]) <$> - multiplicativeGroupModuleLawsFail - , testGroup "Additive Basis" $ localOption (QuickCheckTests 1000) . - testLawOf ([]::[Vector 6 Float]) <$> - additiveBasisLawsFail - , testGroup "Additive Group Basis" $ testLawOf ([]::[Vector 6 Float]) <$> - additiveGroupBasisLaws - , testGroup "Multiplicative Basis" $ localOption (QuickCheckTests 1000) . - testLawOf ([]::[Vector 6 Float]) <$> - multiplicativeBasisLawsFail - , testGroup "Multiplicative Group Basis" $ testLawOf ([]::[Vector 6 Float]) <$> - multiplicativeGroupBasisLaws - , testGroup "Banach" $ testLawOf2 ([]::[(Vector 6 Float, Float)]) <$> - banachLaws - ] - -testsMFloat :: TestTree -testsMFloat = testGroup "Matrix 4 3 Float" - [ testGroup "Additive - Associative - Failure" $ - localOption (QuickCheckTests 1000) . testLawOf ([]::[Matrix 4 3 Float]) <$> - additiveLawsFail - , testGroup "Additive Group" $ testLawOf ([]::[Matrix 4 3 Float]) <$> - additiveGroupLaws - , testGroup "Multiplicative - Associative Failure" $ - localOption (QuickCheckTests 1000) . testLawOf ([]::[Matrix 4 3 Float]) <$> - multiplicativeLawsFail - , testGroup "MultiplicativeGroup" $ testLawOf ([]::[Matrix 4 3 Float]) <$> - multiplicativeGroupLaws - , testGroup "Distribution - Fail" $ - localOption (QuickCheckTests 1000) . testLawOf ([]::[Matrix 4 3 Float]) <$> - distributionLawsFail - , testGroup "Signed" $ testLawOf ([]::[Matrix 4 3 Float]) <$> - signedLaws - , testGroup "Metric" $ testLawOf ([]::[Matrix 4 3 Float]) <$> - metricNaperianFloatLaws - , testGroup "Exponential Field" $ testLawOf ([]::[Matrix 4 3 Float]) <$> - expFieldNaperianLaws - , testGroup "Additive Module" $ - localOption (QuickCheckTests 1000) . - testLawOf2 ([]::[(Matrix 4 3 Float, Float)]) <$> - additiveModuleLawsFail - , testGroup "Additive Group Module" $ - localOption (QuickCheckTests 1000) . - testLawOf2 ([]::[(Matrix 4 3 Float, Float)]) <$> - additiveGroupModuleLawsFail - , testGroup "Multiplicative Module" $ - localOption (QuickCheckTests 1000) . - testLawOf2 ([]::[(Matrix 4 3 Float, Float)]) <$> - multiplicativeModuleLawsFail - , testGroup "Multiplicative Group Module" $ - localOption (QuickCheckTests 1000) . - testLawOf2 ([]::[(Matrix 4 3 Float, Float)]) <$> - multiplicativeGroupModuleLawsFail - , testGroup "Additive Basis" $ - localOption (QuickCheckTests 1000) . - testLawOf ([]::[Matrix 4 3 Float]) <$> - additiveBasisLawsFail - , testGroup "Additive Group Basis" $ - localOption (QuickCheckTests 1000) . - testLawOf ([]::[Matrix 4 3 Float]) <$> - additiveGroupBasisLaws - , testGroup "Multiplicative Basis" $ localOption (QuickCheckTests 1000) . - testLawOf ([]::[Matrix 4 3 Float]) <$> - multiplicativeBasisLawsFail - , testGroup "Multiplicative Group Basis" $ testLawOf ([]::[Matrix 4 3 Float]) <$> - multiplicativeGroupBasisLaws - ] - -idempotentLaws :: - ( Eq a - , Additive a - , Multiplicative a - ) => [Law a] -idempotentLaws = - [ ( "idempotent: a + a == a" - , Unary (\a -> a + a == a)) - , ( "idempotent: a * a == a" - , Unary (\a -> a * a == a)) - ] - -additiveLaws :: - ( Eq a - , Additive a - ) => [Law a] -additiveLaws = - [ ( "associative: (a + b) + c = a + (b + c)" - , Ternary (\a b c -> (a + b) + c == a + (b + c))) - , ("left id: zero + a = a", Unary (\a -> zero + a == a)) - , ("right id: a + zero = a", Unary (\a -> a + zero == a)) - , ("commutative: a + b == b + a", Binary (\a b -> a + b == b + a)) - ] - -additiveLawsApprox :: - ( Eq a - , Additive a - , Epsilon a - ) => [Law a] -additiveLawsApprox = - [ ( "associative: (a + b) + c ≈ a + (b + c)" - , Ternary (\a b c -> (a + b) + c ≈ a + (b + c))) - , ("left id: zero + a = a", Unary (\a -> zero + a == a)) - , ("right id: a + zero = a", Unary (\a -> a + zero == a)) - , ("commutative: a + b == b + a", Binary (\a b -> a + b == b + a)) - ] - -additiveLawsFail :: - ( Eq a - , Additive a - , Show a - , Arbitrary a - ) => [Law a] -additiveLawsFail = - [ ( "associative: (a + b) + c = a + (b + c)" - , Failiary $ expectFailure . (\a b c -> (a + b) + c == a + (b + c))) - , ("left id: zero + a = a", Unary (\a -> zero + a == a)) - , ("right id: a + zero = a", Unary (\a -> a + zero == a)) - , ("commutative: a + b == b + a", Binary (\a b -> a + b == b + a)) - ] - -additiveGroupLaws :: - ( Eq a - , AdditiveGroup a - ) => [Law a] -additiveGroupLaws = - [ ("minus: a - a = zero", Unary (\a -> (a - a) == zero)) - , ("negate minus: negate a == zero - a", Unary (\a -> negate a == zero - a)) - , ("negate cancel: negate a + a == zero", Unary (\a -> negate a + a == zero)) - ] - -multiplicativeLaws :: - ( Eq a - , Multiplicative a - ) => [Law a] -multiplicativeLaws = - [ ( "associative: (a * b) * c = a * (b * c)" - , Ternary (\a b c -> (a * b) * c == a * (b * c))) - , ("left id: one * a = a", Unary (\a -> one * a == a)) - , ("right id: a * one = a", Unary (\a -> a * one == a)) - , ("commutative: a * b == b * a", Binary (\a b -> a * b == b * a)) - ] - -multiplicativeLawsApprox :: - ( Eq a - , Epsilon a - , Multiplicative a - ) => [Law a] -multiplicativeLawsApprox = - [ ("associative: (a * b) * c ≈ a * (b * c)" - , Ternary (\a b c -> (a * b) * c ≈ a * (b * c))) - , ("left id: one * a = a", Unary (\a -> one * a == a)) - , ("right id: a * one = a", Unary (\a -> a * one == a)) - , ("commutative: a * b == b * a", Binary (\a b -> a * b == b * a)) - ] - -multiplicativeLawsFail :: - ( Eq a - , Show a - , Arbitrary a - , Multiplicative a - ) => [Law a] -multiplicativeLawsFail = - [ ("associative: (a * b) * c = a * (b * c)" - , Failiary $ expectFailure . (\a b c -> (a * b) * c == a * (b * c))) - , ("left id: one * a = a", Unary (\a -> one * a == a)) - , ("right id: a * one = a", Unary (\a -> a * one == a)) - , ("commutative: a * b == b * a", Binary (\a b -> a * b == b * a)) - ] - -multiplicativeGroupLaws :: - ( Epsilon a - , Eq a - , MultiplicativeGroup a - ) => [Law a] -multiplicativeGroupLaws = - [ ( "divide: a == zero || a / a ≈ one", Unary (\a -> a == zero || (a / a) ≈ one)) - , ( "recip divide: recip a == one / a", Unary (\a -> a == zero || recip a == one / a)) - , ( "recip left: a == zero || recip a * a ≈ one" - , Unary (\a -> a == zero || recip a * a ≈ one)) - , ( "recip right: a == zero || a * recip a ≈ one" - , Unary (\a -> a == zero || a * recip a ≈ one)) - ] - -distributionLaws :: - ( Eq a - , Distribution a - ) => [Law a] -distributionLaws = - [ ("annihilation: a * zero == zero", Unary (\a -> a `times` zero == zero)) - , ("left distributivity: a * (b + c) == a * b + a * c" - , Ternary (\a b c -> a `times` (b + c) == a `times` b + a `times` c)) - , ("right distributivity: (a + b) * c == a * c + b * c" - , Ternary (\a b c -> (a + b) `times` c == a `times` c + b `times` c)) - ] - -distributionLawsApprox :: - ( Epsilon a - , Eq a - , Distribution a - ) => [Law a] -distributionLawsApprox = - [ ("annihilation: a * zero == zero", Unary (\a -> a `times` zero == zero)) - , ("left distributivity: a * (b + c) ≈ a * b + a * c" - , Ternary (\a b c -> a `times` (b + c) ≈ a `times` b + a `times` c)) - , ("right distributivity: (a + b) * c ≈ a * c + b * c" - , Ternary (\a b c -> (a + b) `times` c ≈ a `times` c + b `times` c)) - ] - -distributionLawsFail :: - ( Show a - , Arbitrary a - , Epsilon a - , Eq a - , Distribution a - ) => [Law a] -distributionLawsFail = - [ ("annihilation: a * zero == zero", Unary (\a -> a `times` zero == zero)) - , ("left distributivity: a * (b + c) = a * b + a * c" - , Failiary $ expectFailure . - (\a b c -> a `times` (b + c) == a `times` b + a `times` c)) - , ("right distributivity: (a + b) * c = a * c + b * c" - , Failiary $ expectFailure . (\a b c -> (a + b) `times` c == a `times` c + b `times` c)) - ] - -signedLaws :: - ( Eq a - , Signed a - ) => [Law a] -signedLaws = - [ ("sign a * abs a == a", Unary (\a -> sign a `times` abs a == a)) - ] - -integralLaws :: - ( Eq a - , Integral a - , FromInteger a - , ToInteger a - ) => [Law a] -integralLaws = - [ ( "integral divmod: b == zero || b * (a `div` b) + (a `mod` b) == a" - , Binary (\a b -> b == zero || b `times` (a `div` b) + (a `mod` b) == a)) - , ( "fromIntegral a = a" - , Unary (\a -> fromIntegral a == a)) - ] - -boundedFieldLaws :: - ( Eq a - , BoundedField a - ) => [Law a] -boundedFieldLaws = - [ ("infinity laws" - , Unary (\a -> - ((one :: Float)/zero + infinity == infinity) && - (infinity + a == infinity) && - isNaN ((infinity :: Float) - infinity) && - isNaN ((infinity :: Float) / infinity) && - isNaN (nan + a) && - (zero :: Float)/zero /= nan)) - ] - -prettyPositive :: (Epsilon a, Ord a) => a -> Bool -prettyPositive a = not (nearZero a) && a > zero - -kindaPositive :: (Epsilon a, Ord a) => a -> Bool -kindaPositive a = nearZero a || a > zero - -metricNaperianFloatLaws :: - ( Metric (r Float) Float - ) => [Law (r Float)] -metricNaperianFloatLaws = - [ ( "positive" - , Binary (\a b -> distance a b >= (zero::Float))) - , ( "zero if equal" - , Unary (\a -> distance a a == (zero::Float))) - , ( "associative" - , Binary (\a b -> distance a b ≈ (distance b a :: Float))) - , ( "triangle rule - sum of distances > distance" - , Ternary - (\a b c -> - kindaPositive - (distance a c + distance b c - (distance a b :: Float)) && - kindaPositive - (distance a b + distance b c - (distance a c :: Float)) && - kindaPositive - (distance a b + distance a c - (distance b c :: Float)))) - ] - -metricFloatLaws :: - ( - ) => [Law Float] -metricFloatLaws = - [ ( "positive" - , Binary (\a b -> (distance a b :: Float) >= zero)) - , ("zero if equal" - , Unary (\a -> (distance a a :: Float) == zero)) - , ( "associative" - , Binary (\a b -> (distance a b :: Float) ≈ (distance b a :: Float))) - , ( "triangle rule - sum of distances > distance" - , Ternary (\a b c -> - (abs a > 10.0) || - (abs b > 10.0) || - (abs c > 10.0) || - kindaPositive (distance a c + distance b c - (distance a b :: Float)) && - kindaPositive (distance a b + distance b c - (distance a c :: Float)) && - kindaPositive (distance a b + distance a c - (distance b c :: Float)))) - ] - -metricComplexFloatLaws :: - ( - ) => [Law (Complex Float)] -metricComplexFloatLaws = - [ ( "positive" - , Binary (\a b -> (distance a b :: Float) >= zero)) - , - ("zero if equal" - , Unary (\a -> (distance a a :: Float) == zero)) - , ( "associative" - , Binary (\a b -> (distance a b :: Float) ≈ (distance b a :: Float))) - , ( "triangle rule - sum of distances > distance" - , Ternary (\a b c -> - (size a > (10.0 :: Float)) || - (size b > (10.0 :: Float)) || - (size c > (10.0 :: Float)) || - kindaPositive (distance a c + distance b c - (distance a b :: Float)) && - kindaPositive (distance a b + distance b c - (distance a c :: Float)) && - kindaPositive (distance a b + distance a c - (distance b c :: Float)))) - - ] - -quotientFieldLaws :: - ( Ord a - , Field a - , QuotientField a - , FromInteger a - ) => [Law a] -quotientFieldLaws = - [ ("x-1 < floor <= x <= ceiling < x+1" - , Unary (\a -> - ((a - one) < fromIntegral (floor a)) && - (fromIntegral (floor a) <= a) && - (a <= fromIntegral (ceiling a)) && - (fromIntegral (ceiling a) < a + one))) - , ("round == floor (x + 1/2)" - , Unary (\a -> round a == floor (a + one/(one+one)) - )) - ] - -expFieldLaws :: - ( ExpField a - , Epsilon a - , Fractional a - , Ord a - ) => [Law a] -expFieldLaws = - [ ("sqrt . (**2) ≈ id" - , Unary (\a -> not (prettyPositive a) || (a > 10.0) || - (sqrt . (**(one+one)) $ a) ≈ a && - ((**(one+one)) . sqrt $ a) ≈ a)) - , ("log . exp ≈ id" - , Unary (\a -> not (prettyPositive a) || (a > 10.0) || - (log . exp $ a) ≈ a && - (exp . log $ a) ≈ a)) - , ("for +ive b, a != 0,1: a ** logBase a b ≈ b" - , Binary (\a b -> - ( not (prettyPositive b) || - not (nearZero (a - zero)) || - (a == one) || - (a == zero && nearZero (logBase a b)) || - (a ** logBase a b ≈ b)))) - ] - -expFieldNaperianLaws :: - ( ExpField (r a) - , Foldable r - , ExpField a - , Epsilon a - , Epsilon (r a) - , Fractional a - , Ord a - ) => [Law (r a)] -expFieldNaperianLaws = - [ ("sqrt . (**2) ≈ id" - , Unary (\a -> not (all prettyPositive a) || any (>10.0) a || - (sqrt . (**(one+one)) $ a) ≈ a && - ((**(one+one)) . sqrt $ a) ≈ a)) - , ("log . exp ≈ id" - , Unary (\a -> not (all prettyPositive a) || any (>10.0) a || - (log . exp $ a) ≈ a && - (exp . log $ a) ≈ a)) - , ("for +ive b, a != 0,1: a ** logBase a b ≈ b" - , Binary (\a b -> - ( not (all prettyPositive b) || - not (all nearZero a) || - all (==one) a || - (all (==zero) a && all nearZero (logBase a b)) || - (a ** logBase a b ≈ b)))) - ] - -additiveModuleLaws :: - ( Eq (r a) - , Epsilon a - , Epsilon (r a) - , AdditiveModule r a - ) => [Law2 (r a) a] -additiveModuleLaws = - [ - ("additive module associative: (a + b) .+ c ≈ a + (b .+ c)" - , Ternary2 (\a b c -> (a + b) .+ c ≈ a + (b .+ c))) - , ("additive module commutative: (a + b) .+ c ≈ (a .+ c) + b" - , Ternary2 (\a b c -> (a + b) .+ c ≈ (a .+ c) + b)) - , ("additive module unital: a .+ zero == a" - , Unary2 (\a -> a .+ zero == a)) - , ("module additive equivalence: a .+ b ≈ b +. a" - , Binary2 (\a b -> a .+ b ≈ b +. a)) - ] - -additiveModuleLawsFail :: - ( Eq (r a) - , Show a - , Arbitrary a - , Show (r a) - , Arbitrary (r a) - , Epsilon a - , Additive (r a) - , AdditiveModule r a - ) => [Law2 (r a) a] -additiveModuleLawsFail = - [ - ("additive module associative: (a + b) .+ c == a + (b .+ c)" - , Failiary2 $ expectFailure . (\a b c -> (a + b) .+ c == a + (b .+ c))) - , ("additive module commutative: (a + b) .+ c == (a .+ c) + b" - , Failiary2 $ expectFailure . (\a b c -> (a + b) .+ c == (a .+ c) + b)) - , ("additive module unital: a .+ zero == a" - , Unary2 (\a -> a .+ zero == a)) - , ("module additive equivalence: a .+ b == b +. a" - , Binary2 (\a b -> a .+ b == b +. a)) - ] - -additiveGroupModuleLaws :: - ( Eq (r a) - , Epsilon a - , Epsilon (r a) - , Naperian r - , AdditiveGroupModule r a - ) => [Law2 (r a) a] -additiveGroupModuleLaws = - [ - ("additive group module associative: (a + b) .- c ≈ a + (b .- c)" - , Ternary2 (\a b c -> (a + b) .- c ≈ a + (b .- c))) - , ("additive group module commutative: (a + b) .- c ≈ (a .- c) + b" - , Ternary2 (\a b c -> (a + b) .- c ≈ (a .- c) + b)) - , ("additive group module unital: a .- zero == a" - , Unary2 (\a -> a .- zero == a)) - , ("additive group module basis unital: a .- zero ≈ pureRep a" - , Binary2 (\a b -> b -. (a-a) ≈ pureRep b)) - , ("module additive group equivalence: a .- b ≈ negate b +. a" - , Binary2 (\a b -> a .- b ≈ negate b +. a)) - ] - -additiveGroupModuleLawsFail :: - ( Eq (r a) - , Show a - , Arbitrary a - , Show (r a) - , Arbitrary (r a) - , Epsilon a - , Epsilon (r a) - , Naperian r - , AdditiveGroupModule r a - ) => [Law2 (r a) a] -additiveGroupModuleLawsFail = - [ - ("additive group module associative: (a + b) .- c == a + (b .- c)" - , Failiary2 $ expectFailure . (\a b c -> (a + b) .- c == a + (b .- c))) - , ("additive group module commutative: (a + b) .- c == (a .- c) + b" - , Failiary2 $ expectFailure . (\a b c -> (a + b) .- c == (a .- c) + b)) - , ("additive group module unital: a .- zero == a" - , Unary2 (\a -> a .- zero == a)) - , ("additive group module basis unital: a .- zero == pureRep a" - , Binary2 (\a b -> b -. (a-a) == pureRep b)) - , ("module additive group equivalence: a .- b ≈ negate b +. a" - , Binary2 (\a b -> a .- b ≈ negate b +. a)) - ] - -multiplicativeModuleLaws :: - ( Eq (r a) - , Epsilon a - , Epsilon (r a) - , Multiplicative (r a) - , MultiplicativeModule r a - ) => [Law2 (r a) a] -multiplicativeModuleLaws = - [ ("multiplicative module associative: (a * b) .* c ≈ a * (b .* c)" - , Ternary2 (\a b c -> (a * b) .* c ≈ a * (b .* c))) - , ("multiplicative module commutative: (a * b) .* c ≈ (a .* c) * b" - , Ternary2 (\a b c -> (a * b) .* c ≈ a * (b .* c))) - , ("multiplicative module unital: a .* one == a" - , Unary2 (\a -> a .* one == a)) - , ("module right distribution: (a + b) .* c ≈ (a .* c) + (b .* c)" - , Ternary2 (\a b c -> (a + b) .* c ≈ (a .* c) + (b .* c))) - , ("module left distribution: c *. (a + b) ≈ (c *. a) + (c *. b)" - , Ternary2 (\a b c -> c *. (a + b) ≈ (c *. a) + (c *. b))) - , ("annihilation: a .* zero == zero", Unary2 (\a -> a .* zero == zero)) - , ("module multiplicative equivalence: a .* b ≈ b *. a" - , Binary2 (\a b -> a .* b ≈ b *. a)) - ] - -multiplicativeModuleLawsFail :: - ( Eq (r a) - , Epsilon a - , Epsilon (r a) - , Show a - , Arbitrary a - , Show (r a) - , Arbitrary (r a) - , Multiplicative (r a) - , MultiplicativeModule r a - ) => [Law2 (r a) a] -multiplicativeModuleLawsFail = - [ ("multiplicative module associative: (a * b) .* c == a * (b .* c)" - , Failiary2 $ expectFailure . (\a b c -> (a * b) .* c == a * (b .* c))) - , ("multiplicative module commutative: (a * b) .* c == (a .* c) * b" - , Failiary2 $ expectFailure . (\a b c -> (a * b) .* c == a * (b .* c))) - , ("multiplicative module unital: a .* one == a" - , Unary2 (\a -> a .* one == a)) - , ("module right distribution: (a + b) .* c == (a .* c) + (b .* c)" - , Failiary2 $ expectFailure . (\a b c -> (a + b) .* c == (a .* c) + (b .* c))) - , ("module left distribution: c *. (a + b) == (c *. a) + (c *. b)" - , Failiary2 $ expectFailure . (\a b c -> c *. (a + b) == (c *. a) + (c *. b))) - , ("annihilation: a .* zero == zero", Unary2 (\a -> a .* zero == zero)) - , ("module multiplicative equivalence: a .* b ≈ b *. a" - , Binary2 (\a b -> a .* b ≈ b *. a)) - ] - -multiplicativeGroupModuleLaws :: - ( Eq (r a) - , Eq a - , Epsilon a - , Epsilon (r a) - , Naperian r - , MultiplicativeGroup (r a) - , MultiplicativeGroupModule r a - ) => [Law2 (r a) a] -multiplicativeGroupModuleLaws = - [ - ("multiplicative group module associative: (a * b) ./ c ≈ a * (b ./ c)" - , Ternary2 (\a b c -> c==zero || (a * b) ./ c ≈ a * (b ./ c))) - , ("multiplicative group module commutative: (a * b) ./ c ≈ (a ./ c) * b" - , Ternary2 (\a b c -> c==zero || (a * b) ./ c ≈ (a ./ c) * b)) - , ("multiplicative group module unital: a ./ one == a" - , Unary2 (\a -> nearZero a || a ./ one == a)) - , ("multiplicative group module basis unital: a /. one ≈ pureRep a" - , Binary2 (\a b -> a==zero || b /. (a/a) ≈ pureRep b)) - , ("module multiplicative group equivalence: a ./ b ≈ recip b *. a" - , Binary2 (\a b -> b==zero || a ./ b ≈ recip b *. a)) - ] - -multiplicativeGroupModuleLawsFail :: - ( Eq a - , Show a - , Arbitrary a - , Eq (r a) - , Show (r a) - , Arbitrary (r a) - , Epsilon a - , Epsilon (r a) - , MultiplicativeGroup (r a) - , MultiplicativeGroupModule r a - ) => [Law2 (r a) a] -multiplicativeGroupModuleLawsFail = - [ - ("multiplicative group module associative: (a * b) ./ c == a * (b ./ c)" - , Failiary2 $ expectFailure . - (\a b c -> c==zero || (a * b) ./ c == a * (b ./ c))) - , ("multiplicative group module commutative: (a * b) ./ c == (a ./ c) * b" - , Failiary2 $ expectFailure . - (\a b c -> c==zero || (a * b) ./ c == (a ./ c) * b)) - , ("multiplicative group module unital: a ./ one == a" - , Unary2 (\a -> nearZero a || a ./ one == a)) - , ("multiplicative group module basis unital: a /. one == pureRep a" - , Failiary2 $ expectFailure . - (\a b -> a==zero || b /. (a/a) == pureRep b)) - , ("module multiplicative group equivalence: a ./ b ≈ recip b *. a" - , Binary2 (\a b -> b==zero || a ./ b ≈ recip b *. a)) - ] - -additiveBasisLaws :: - ( Eq (r a) - , Epsilon (r a) - , AdditiveBasis r a - ) => [Law (r a)] -additiveBasisLaws = - [ ( "associative: (a .+. b) .+. c ≈ a .+. (b .+. c)" - , Ternary (\a b c -> (a .+. b) .+. c ≈ a .+. (b .+. c))) - , ("left id: zero .+. a = a", Unary (\a -> zero .+. a == a)) - , ("right id: a .+. zero = a", Unary (\a -> a .+. zero == a)) - , ("commutative: a .+. b == b .+. a", Binary (\a b -> a .+. b == b .+. a)) - ] - -additiveBasisLawsFail :: - ( Eq (r a) - , Arbitrary (r a) - , Show (r a) - , Epsilon (r a) - , AdditiveBasis r a - ) => [Law (r a)] -additiveBasisLawsFail = - [ ( "associative: (a .+. b) .+. c ≈ a .+. (b .+. c)" - , Failiary $ expectFailure . - (\a b c -> (a .+. b) .+. c ≈ a .+. (b .+. c))) - , ("left id: zero .+. a = a", Unary (\a -> zero .+. a == a)) - , ("right id: a .+. zero = a", Unary (\a -> a .+. zero == a)) - , ("commutative: a .+. b == b .+. a", Binary (\a b -> a .+. b == b .+. a)) - ] - -additiveGroupBasisLaws :: - ( Eq (r a) - , AdditiveGroupBasis r a - ) => [Law (r a)] -additiveGroupBasisLaws = - [ ("minus: a .-. a = pureRep zero", Unary (\a -> (a .-. a) == pureRep zero)) - ] - -multiplicativeBasisLaws :: - ( Eq (r a) - , Multiplicative (r a) - , MultiplicativeBasis r a - ) => [Law (r a)] -multiplicativeBasisLaws = - [ ("associative: (a .*. b) .*. c == a .*. (b .*. c)" - , Ternary (\a b c -> (a .*. b) .*. c == a .*. (b .*. c))) - , ("left id: one .*. a = a", Unary (\a -> one .*. a == a)) - , ("right id: a .*. one = a", Unary (\a -> a .*. one == a)) - , ("commutative: a .*. b == b .*. a", Binary (\a b -> a .*. b == b * a)) - ] - -multiplicativeBasisLawsFail :: - ( Eq (r a) - , Show (r a) - , Arbitrary (r a) - , Multiplicative (r a) - , MultiplicativeBasis r a - ) => [Law (r a)] -multiplicativeBasisLawsFail = - [ ("associative: (a .*. b) .*. c == a .*. (b .*. c)" - , Failiary $ expectFailure . (\a b c -> (a .*. b) .*. c == a .*. (b .*. c))) - , ("left id: one .*. a = a", Unary (\a -> one .*. a == a)) - , ("right id: a .*. one = a", Unary (\a -> a .*. one == a)) - , ("commutative: a .*. b == b .*. a", Binary (\a b -> a .*. b == b * a)) - ] - -multiplicativeGroupBasisLaws :: - ( Eq (r a) - , Epsilon a - , Epsilon (r a) - , Naperian r - , MultiplicativeGroupBasis r a - ) => [Law (r a)] -multiplicativeGroupBasisLaws = - [ ("minus: a ./. a ≈ pureRep one", Unary (\a -> a==pureRep zero || (a ./. a) ≈ pureRep one)) - ] - -banachLaws :: - ( Eq (r a) - , Epsilon b - , MultiplicativeGroup b - , Banach r a - , Normed (r a) b - ) => [Law2 (r a) b] -banachLaws = - [ -- Banach - ( "size (normalize a) ≈ one" - , Binary2 (\a b -> a==pureRep zero || size (normalize a) ≈ (b/b))) - ] +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE NegativeLiterals #-} +{-# OPTIONS_GHC -Wall #-} + +-- | testing IEEE numbers is a special kind of hell, and one that I reserve for days when I can hardly think, so please forgive the horrible hackery contained within this file. +-- +-- This suite sometimes fails, having been hand-crafty towards balancing reasonably approximate equality versus unbounded failure (given enough trials). +module Main where + +import NumHask.Prelude + +import Test.DocTest +import Test.Tasty + (TestName, TestTree, defaultMain, localOption, testGroup) +import Test.Tasty.QuickCheck hiding ((><)) + +main :: IO () +main = do + doctest ["src/NumHask/Examples.hs"] + defaultMain tests + +data LawArity a + = Nonary Bool + | Unary (a -> Bool) + | Binary (a -> a -> Bool) + | Ternary (a -> a -> a -> Bool) + | Ornary (a -> a -> a -> a -> Bool) + | Failiary (a -> Property) + +data LawArity2 a b + = Unary2 (a -> Bool) + | Binary2 (a -> b -> Bool) + | Ternary2 (a -> a -> b -> Bool) + | Ternary2' (a -> b -> b -> Bool) + | Ternary2'' (a -> a -> a -> Bool) + | Quad31 (a -> a -> a -> b -> Bool) + | Quad22 (a -> a -> b -> b -> Bool) + | Failiary2 (a -> Property) + +type Law a = (TestName, LawArity a) + +type Law2 a b = (TestName, LawArity2 a b) + +testLawOf :: (Arbitrary a, Show a) => [a] -> Law a -> TestTree +testLawOf _ (name, Nonary f) = testProperty name f +testLawOf _ (name, Unary f) = testProperty name f +testLawOf _ (name, Binary f) = testProperty name f +testLawOf _ (name, Ternary f) = testProperty name f +testLawOf _ (name, Ornary f) = testProperty name f +testLawOf _ (name, Failiary f) = testProperty name f + +testLawOf2 :: + (Arbitrary a, Show a, Arbitrary b, Show b) + => [(a, b)] + -> Law2 a b + -> TestTree +testLawOf2 _ (name, Unary2 f) = testProperty name f +testLawOf2 _ (name, Binary2 f) = testProperty name f +testLawOf2 _ (name, Ternary2 f) = testProperty name f +testLawOf2 _ (name, Ternary2' f) = testProperty name f +testLawOf2 _ (name, Ternary2'' f) = testProperty name f +testLawOf2 _ (name, Quad22 f) = testProperty name f +testLawOf2 _ (name, Quad31 f) = testProperty name f +testLawOf2 _ (name, Failiary2 f) = testProperty name f + +tests :: TestTree +tests = + testGroup + "NumHask" + [ testsInt + , testsFloat + , testsBool + , testsVInt + , testsVFloat + , testsMInt + , testsMFloat + , testsComplexFloat + ] + +testsInt :: TestTree +testsInt = + testGroup + "Int" + [ testGroup "Additive" $ testLawOf ([] :: [Int]) <$> additiveLaws + , testGroup "Additive Group" $ testLawOf ([] :: [Int]) <$> additiveGroupLaws + , testGroup "Multiplicative" $ + testLawOf ([] :: [Int]) <$> multiplicativeLaws + , testGroup "Distribution" $ testLawOf ([] :: [Int]) <$> distributionLaws + , testGroup "Integral" $ testLawOf ([] :: [Int]) <$> integralLaws + , testGroup "Signed" $ testLawOf ([] :: [Int]) <$> signedLaws + ] + +testsFloat :: TestTree +testsFloat = + testGroup + "Float" + [ testGroup "Additive - Associative Fail" $ + testLawOf ([] :: [Float]) <$> additiveLawsFail + , testGroup "Additive Group" $ + testLawOf ([] :: [Float]) <$> additiveGroupLaws + , testGroup "Multiplicative - Associative Fail" $ + testLawOf ([] :: [Float]) <$> multiplicativeLawsFail + , testGroup "MultiplicativeGroup" $ + testLawOf ([] :: [Float]) <$> multiplicativeGroupLaws + , testGroup "Distribution - Fail" $ + testLawOf ([] :: [Float]) <$> distributionLawsFail + , testGroup "Signed" $ testLawOf ([] :: [Float]) <$> signedLaws + , testGroup "Bounded Field" $ + testLawOf ([] :: [Float]) <$> boundedFieldFloatLaws + , testGroup "Metric" $ testLawOf ([] :: [Float]) <$> metricFloatLaws + , testGroup "Quotient Field" $ + testLawOf ([] :: [Float]) <$> quotientFieldLaws + , testGroup "Exponential Field" $ testLawOf ([] :: [Float]) <$> expFieldLaws + ] + +testsBool :: TestTree +testsBool = + testGroup + "Bool" + [ testGroup "Idempotent" $ testLawOf ([] :: [Bool]) <$> idempotentLaws + , testGroup "Additive" $ testLawOf ([] :: [Bool]) <$> additiveLaws + , testGroup "Multiplicative" $ + testLawOf ([] :: [Bool]) <$> multiplicativeLaws + , testGroup "Distribution" $ testLawOf ([] :: [Bool]) <$> distributionLaws + ] + +testsComplexFloat :: TestTree +testsComplexFloat = + testGroup + "Complex Float" + [ testGroup "Additive - Associative Fail" $ + testLawOf ([] :: [Complex Float]) <$> additiveLawsFail + , testGroup "Additive Group" $ + testLawOf ([] :: [Complex Float]) <$> additiveGroupLaws + , testGroup "Multiplicative - Associative Fail" $ + testLawOf ([] :: [Complex Float]) <$> multiplicativeLawsFail + , testGroup "MultiplicativeGroup" $ + testLawOf ([] :: [Complex Float]) <$> multiplicativeGroupLaws + , testGroup "Distribution - Fail" $ + testLawOf ([] :: [Complex Float]) <$> distributionLawsFail + , testGroup "Exponential Field" $ + testLawOf ([] :: [Complex Float]) <$> expFieldComplexLooseLaws 10 + , testGroup "Metric" $ + testLawOf ([] :: [Complex Float]) <$> metricComplexFloatLaws + ] + +testsVInt :: TestTree +testsVInt = + testGroup + "Vector 6 Int" + [ testGroup "Additive" $ testLawOf ([] :: [Vector 6 Int]) <$> additiveLaws + , testGroup "Additive Group" $ + testLawOf ([] :: [Vector 6 Int]) <$> additiveGroupLaws + , testGroup "Multiplicative" $ + testLawOf ([] :: [Vector 6 Int]) <$> multiplicativeLaws + , testGroup "Distribution" $ + testLawOf ([] :: [Vector 6 Int]) <$> distributionLaws + , testGroup "Additive Module" $ + testLawOf2 ([] :: [(Vector 6 Int, Int)]) <$> additiveModuleLaws + , testGroup "Additive Group Module" $ + testLawOf2 ([] :: [(Vector 6 Int, Int)]) <$> additiveGroupModuleLaws + , testGroup "Multiplicative Module" $ + testLawOf2 ([] :: [(Vector 6 Int, Int)]) <$> multiplicativeModuleLaws + , testGroup "Hilbert" $ + testLawOf2 ([] :: [(Vector 6 Int, Int)]) <$> hilbertLaws + , testGroup "Tensor product" $ + testLawOf2 ([] :: [(Vector 6 Int, Int)]) <$> tensorProductLaws + , testGroup "Additive Basis" $ + testLawOf ([] :: [Vector 6 Int]) <$> additiveBasisLaws + , testGroup "Additive Group Basis" $ + testLawOf ([] :: [Vector 6 Int]) <$> additiveGroupBasisLaws + , testGroup "Multiplicative Basis" $ + testLawOf ([] :: [Vector 6 Int]) <$> multiplicativeBasisLaws + ] + +testsMInt :: TestTree +testsMInt = + testGroup + "Matrix 4 3 Int" + [ testGroup "Additive" $ testLawOf ([] :: [Matrix 4 3 Int]) <$> additiveLaws + , testGroup "Additive Group" $ + testLawOf ([] :: [Matrix 4 3 Int]) <$> additiveGroupLaws + , testGroup "Multiplicative" $ + testLawOf ([] :: [Matrix 3 3 Int]) <$> multiplicativeMonoidalLaws + , testGroup "Additive Module" $ + testLawOf2 ([] :: [(Matrix 4 3 Int, Int)]) <$> additiveModuleLaws + , testGroup "Additive Group Module" $ + testLawOf2 ([] :: [(Matrix 4 3 Int, Int)]) <$> additiveGroupModuleLaws + , testGroup "Multiplicative Module" $ + testLawOf2 ([] :: [(Matrix 4 3 Int, Int)]) <$> multiplicativeModuleLaws + , testGroup "Hilbert" $ + testLawOf2 ([] :: [(Matrix 4 3 Int, Int)]) <$> hilbertLaws + , testGroup "Tensor product" $ + testLawOf2 ([] :: [(Matrix 4 3 Int, Int)]) <$> tensorProductLaws + , testGroup "Additive Basis" $ + testLawOf ([] :: [Matrix 4 3 Int]) <$> additiveBasisLaws + , testGroup "Additive Group Basis" $ + testLawOf ([] :: [Matrix 4 3 Int]) <$> additiveGroupBasisLaws + , testGroup "Multiplicative Basis" $ + testLawOf ([] :: [Matrix 4 3 Int]) <$> multiplicativeBasisLaws + ] + +testsVFloat :: TestTree +testsVFloat = + testGroup + "Vector 6 Float" + [ testGroup "MultiplicativeGroup" $ + testLawOf ([] :: [Vector 6 Float]) <$> multiplicativeGroupLaws + , testGroup "Signed" $ testLawOf ([] :: [Vector 6 Float]) <$> signedLaws + , testGroup "Metric" $ + testLawOf ([] :: [Vector 6 Float]) <$> metricNaperianFloatLaws + , testGroup "Exponential Field" $ + testLawOf ([] :: [Vector 6 Float]) <$> expFieldNaperianLaws + , testGroup "Multiplicative Group Module" $ + localOption (QuickCheckTests 1000) . + testLawOf2 ([] :: [(Vector 6 Float, Float)]) <$> + multiplicativeGroupModuleLawsFail + , testGroup "Multiplicative Group Basis" $ + testLawOf ([] :: [Vector 6 Float]) <$> multiplicativeGroupBasisLaws + ] + +testsMFloat :: TestTree +testsMFloat = + testGroup + "Matrix 4 3 Float" + [ testGroup "Multiplicative Group Module" $ + localOption (QuickCheckTests 1000) . + testLawOf2 ([] :: [(Matrix 4 3 Float, Float)]) <$> + multiplicativeGroupModuleLawsFail + , testGroup "Multiplicative Group Basis" $ + testLawOf ([] :: [Matrix 4 3 Float]) <$> multiplicativeGroupBasisLaws + ] + +-- idempotent +idempotentLaws :: (Eq a, Additive a, Multiplicative a) => [Law a] +idempotentLaws = + [ ("idempotent: a + a == a", Unary (\a -> a + a == a)) + , ("idempotent: a * a == a", Unary (\a -> a * a == a)) + ] + +-- additive +additiveLaws :: (Eq a, Additive a) => [Law a] +additiveLaws = + [ ( "associative: (a + b) + c = a + (b + c)" + , Ternary (\a b c -> (a + b) + c == a + (b + c))) + , ("left id: zero + a = a", Unary (\a -> zero + a == a)) + , ("right id: a + zero = a", Unary (\a -> a + zero == a)) + , ("commutative: a + b == b + a", Binary (\a b -> a + b == b + a)) + ] + +additiveLawsFail :: (Eq a, Additive a, Show a, Arbitrary a) => [Law a] +additiveLawsFail = + [ ( "associative: (a + b) + c = a + (b + c)" + , Failiary $ expectFailure . (\a b c -> (a + b) + c == a + (b + c))) + , ("left id: zero + a = a", Unary (\a -> zero + a == a)) + , ("right id: a + zero = a", Unary (\a -> a + zero == a)) + , ("commutative: a + b == b + a", Binary (\a b -> a + b == b + a)) + ] + +additiveGroupLaws :: (Eq a, AdditiveGroup a) => [Law a] +additiveGroupLaws = + [ ("minus: a - a = zero", Unary (\a -> (a - a) == zero)) + , ("negate minus: negate a == zero - a", Unary (\a -> negate a == zero - a)) + , ( "negate left cancel: negate a + a == zero" + , Unary (\a -> negate a + a == zero)) + , ( "negate right cancel: negate a + a == zero" + , Unary (\a -> a + negate a == zero)) + ] + +-- multiplicative +multiplicativeLaws :: (Eq a, Multiplicative a) => [Law a] +multiplicativeLaws = + [ ( "associative: (a * b) * c = a * (b * c)" + , Ternary (\a b c -> (a * b) * c == a * (b * c))) + , ("left id: one * a = a", Unary (\a -> one * a == a)) + , ("right id: a * one = a", Unary (\a -> a * one == a)) + , ("commutative: a * b == b * a", Binary (\a b -> a * b == b * a)) + ] + +multiplicativeMonoidalLaws :: + (Eq a, MultiplicativeUnital a, MultiplicativeAssociative a) => [Law a] +multiplicativeMonoidalLaws = + [ ( "associative: (a * b) * c = a * (b * c)" + , Ternary (\a b c -> (a `times` b) `times` c == a `times` (b `times` c))) + , ("left id: one `times` a = a", Unary (\a -> one `times` a == a)) + , ("right id: a `times` one = a", Unary (\a -> a `times` one == a)) + ] + +multiplicativeLawsFail :: + (Eq a, Show a, Arbitrary a, Multiplicative a) => [Law a] +multiplicativeLawsFail = + [ ( "associative: (a * b) * c = a * (b * c)" + , Failiary $ expectFailure . (\a b c -> (a * b) * c == a * (b * c))) + , ("left id: one * a = a", Unary (\a -> one * a == a)) + , ("right id: a * one = a", Unary (\a -> a * one == a)) + , ("commutative: a * b == b * a", Binary (\a b -> a * b == b * a)) + ] + +multiplicativeGroupLaws :: (Epsilon a, Eq a, MultiplicativeGroup a) => [Law a] +multiplicativeGroupLaws = + [ ( "divide: a == zero || a / a ≈ one" + , Unary (\a -> a == zero || (a / a) ≈ one)) + , ( "recip divide: recip a == one / a" + , Unary (\a -> a == zero || recip a == one / a)) + , ( "recip left: a == zero || recip a * a ≈ one" + , Unary (\a -> a == zero || recip a * a ≈ one)) + , ( "recip right: a == zero || a * recip a ≈ one" + , Unary (\a -> a == zero || a * recip a ≈ one)) + ] + +-- distribution +distributionLaws :: (Eq a, Distribution a) => [Law a] +distributionLaws = + [ ( "left annihilation: a * zero == zero" + , Unary (\a -> a `times` zero == zero)) + , ( "right annihilation: zero * a == zero" + , Unary (\a -> zero `times` a == zero)) + , ( "left distributivity: a * (b + c) == a * b + a * c" + , Ternary (\a b c -> a `times` (b + c) == a `times` b + a `times` c)) + , ( "right distributivity: (a + b) * c == a * c + b * c" + , Ternary (\a b c -> (a + b) `times` c == a `times` c + b `times` c)) + ] + +distributionLawsFail :: + (Show a, Arbitrary a, Epsilon a, Eq a, Distribution a) => [Law a] +distributionLawsFail = + [ ( "left annihilation: a * zero == zero" + , Unary (\a -> a `times` zero == zero)) + , ( "right annihilation: a * zero == zero" + , Unary (\a -> zero `times` a == zero)) + , ( "left distributivity: a * (b + c) = a * b + a * c" + , Failiary $ + expectFailure . (\a b c -> a `times` (b + c) == a `times` b + a `times` c)) + , ( "right distributivity: (a + b) * c = a * c + b * c" + , Failiary $ + expectFailure . (\a b c -> (a + b) `times` c == a `times` c + b `times` c)) + ] + +-- integral +integralLaws :: (Eq a, Integral a, FromInteger a, ToInteger a) => [Law a] +integralLaws = + [ ( "integral divmod: b == zero || b * (a `div` b) + (a `mod` b) == a" + , Binary (\a b -> b == zero || b `times` (a `div` b) + (a `mod` b) == a)) + , ("fromIntegral a = a", Unary (\a -> fromIntegral a == a)) + ] + +-- metric +signedLaws :: (Eq a, Signed a) => [Law a] +signedLaws = [("sign a * abs a == a", Unary (\a -> sign a `times` abs a == a))] + +metricFloatLaws :: () => [Law Float] +metricFloatLaws = + [ ("positive", Binary (\a b -> (distance a b :: Float) >= zero)) + , ("zero if equal", Unary (\a -> (distance a a :: Float) == zero)) + , ( "associative" + , Binary (\a b -> (distance a b :: Float) ≈ (distance b a :: Float))) + , ( "triangle rule - sum of distances > distance" + , Ternary + (\a b c -> + (abs a > 10.0) || + (abs b > 10.0) || + (abs c > 10.0) || + not + (veryNegative + (distance a c + distance b c - (distance a b :: Float))) && + not + (veryNegative + (distance a b + distance b c - (distance a c :: Float))) && + not + (veryNegative + (distance a b + distance a c - (distance b c :: Float))))) + ] + +metricComplexFloatLaws :: () => [Law (Complex Float)] +metricComplexFloatLaws = + [ ("positive", Binary (\a b -> (distance a b :: Float) >= zero)) + , ("zero if equal", Unary (\a -> (distance a a :: Float) == zero)) + , ( "associative" + , Binary (\a b -> (distance a b :: Float) ≈ (distance b a :: Float))) + , ( "triangle rule - sum of distances > distance" + , Ternary + (\a b c -> + (size a > (10.0 :: Float)) || + (size b > (10.0 :: Float)) || + (size c > (10.0 :: Float)) || + not + (veryNegative + (distance a c + distance b c - (distance a b :: Float))) && + not + (veryNegative + (distance a b + distance b c - (distance a c :: Float))) && + not + (veryNegative + (distance a b + distance a c - (distance b c :: Float))))) + ] + +metricNaperianFloatLaws :: (Metric (r Float) Float) => [Law (r Float)] +metricNaperianFloatLaws = + [ ("positive", Binary (\a b -> distance a b >= (zero :: Float))) + , ("zero if equal", Unary (\a -> distance a a == (zero :: Float))) + , ("associative", Binary (\a b -> distance a b ≈ (distance b a :: Float))) + , ( "triangle rule - sum of distances > distance" + , Ternary + (\a b c -> + not + (veryNegative + (distance a c + distance b c - (distance a b :: Float))) && + not + (veryNegative + (distance a b + distance b c - (distance a c :: Float))) && + not + (veryNegative + (distance a b + distance a c - (distance b c :: Float))))) + ] + +-- field +boundedFieldFloatLaws :: [Law Float] +boundedFieldFloatLaws = + [ ( "infinity laws" + , Unary + (\a -> + ((one :: Float) / zero + infinity == infinity) && + (infinity + a == infinity) && + isNaN ((infinity :: Float) - infinity) && + isNaN ((infinity :: Float) / infinity) && + isNaN (nan + a) && (zero :: Float) / zero /= nan)) + ] + +quotientFieldLaws :: (Ord a, Field a, QuotientField a, FromInteger a) => [Law a] +quotientFieldLaws = + [ ( "a - one < floor a <= a <= ceiling a < a + one" + , Unary + (\a -> + ((a - one) < fromIntegral (floor a)) && + (fromIntegral (floor a) <= a) && + (a <= fromIntegral (ceiling a)) && + (fromIntegral (ceiling a) < a + one))) + , ( "round a == floor (a + one/(one+one))" + , Unary (\a -> round a == floor (a + one / (one + one)))) + ] + +expFieldLaws :: + (ExpField a, Signed a, Epsilon a, Fractional a, Ord a) => [Law a] +expFieldLaws = + [ ( "sqrt . (**(one+one)) ≈ id" + , Unary + (\a -> + not (veryPositive a) || + (a > 10.0) || + (sqrt . (** (one + one)) $ a) ≈ a && + ((** (one + one)) . sqrt $ a) ≈ a)) + , ( "log . exp ≈ id" + , Unary + (\a -> + not (veryPositive a) || + (a > 10.0) || (log . exp $ a) ≈ a && (exp . log $ a) ≈ a)) + , ( "for +ive b, a != 0,1: a ** logBase a b ≈ b" + , Binary + (\a b -> + (not (veryPositive b) || + not (nearZero (a - zero)) || + (a == one) || + (a == zero && nearZero (logBase a b)) || (a ** logBase a b ≈ b)))) + ] + +expFieldComplexLooseLaws :: Float -> [Law (Complex Float)] +expFieldComplexLooseLaws _ = + [ ( "sqrt . (**(one+one)) ≈ id test contains a stack overflow" + , Unary (const True)) + , ("log . exp test contains a stack overflow", Unary (const True)) + , ( "for +ive b, a != 0,1: a ** logBase a b ≈ b" + , Binary + (\a b@(rb :+ ib) -> + (not (rb > zero && ib > zero) || + not (nearZero (a - zero)) || + (a == one) || + (a == zero && nearZero (logBase a b)) || (a ** logBase a b ≈ b)))) + ] + +expFieldNaperianLaws :: + ( ExpField (r a) + , Foldable r + , ExpField a + , Epsilon a + , Signed a + , Epsilon (r a) + , Fractional a + , Ord a + ) + => [Law (r a)] +expFieldNaperianLaws = + [ ( "sqrt . (**2) ≈ id" + , Unary + (\a -> + not (all veryPositive a) || + any (> 10.0) a || + (sqrt . (** (one + one)) $ a) ≈ a && + ((** (one + one)) . sqrt $ a) ≈ a)) + , ( "log . exp ≈ id" + , Unary + (\a -> + not (all veryPositive a) || + any (> 10.0) a || (log . exp $ a) ≈ a && (exp . log $ a) ≈ a)) + , ( "for +ive b, a != 0,1: a ** logBase a b ≈ b" + , Binary + (\a b -> + (not (all veryPositive b) || + not (all nearZero a) || + all (== one) a || + (all (== zero) a && all nearZero (logBase a b)) || + (a ** logBase a b ≈ b)))) + ] + +-- module +additiveModuleLaws :: + (Eq (r a), Epsilon a, Epsilon (r a), AdditiveModule r a) => [Law2 (r a) a] +additiveModuleLaws = + [ ( "additive module associative: (a + b) .+ c ≈ a + (b .+ c)" + , Ternary2 (\a b c -> (a + b) .+ c ≈ a + (b .+ c))) + , ( "additive module commutative: (a + b) .+ c ≈ (a .+ c) + b" + , Ternary2 (\a b c -> (a + b) .+ c ≈ (a .+ c) + b)) + , ("additive module unital: a .+ zero == a", Unary2 (\a -> a .+ zero == a)) + , ( "module additive equivalence: a .+ b ≈ b +. a" + , Binary2 (\a b -> a .+ b ≈ b +. a)) + ] + +additiveGroupModuleLaws :: + (Eq (r a), Epsilon a, Epsilon (r a), AdditiveGroupModule r a) + => [Law2 (r a) a] +additiveGroupModuleLaws = + [ ( "additive group module associative: (a + b) .- c ≈ a + (b .- c)" + , Ternary2 (\a b c -> (a + b) .- c ≈ a + (b .- c))) + , ( "additive group module commutative: (a + b) .- c ≈ (a .- c) + b" + , Ternary2 (\a b c -> (a + b) .- c ≈ (a .- c) + b)) + , ( "additive group module unital: a .- zero == a" + , Unary2 (\a -> a .- zero == a)) + , ( "module additive group equivalence: a .- b ≈ negate b +. a" + , Binary2 (\a b -> a .- b ≈ negate b +. a)) + ] + +multiplicativeModuleLaws :: + (Eq (r a), Epsilon a, Epsilon (r a), MultiplicativeModule r a) + => [Law2 (r a) a] +multiplicativeModuleLaws = + [ ( "multiplicative module unital: a .* one == a" + , Unary2 (\a -> a .* one == a)) + , ( "module right distribution: (a + b) .* c ≈ (a .* c) + (b .* c)" + , Ternary2 (\a b c -> (a + b) .* c ≈ (a .* c) + (b .* c))) + , ( "module left distribution: c *. (a + b) ≈ (c *. a) + (c *. b)" + , Ternary2 (\a b c -> c *. (a + b) ≈ (c *. a) + (c *. b))) + , ("annihilation: a .* zero == zero", Unary2 (\a -> a .* zero == zero)) + , ( "module multiplicative equivalence: a .* b ≈ b *. a" + , Binary2 (\a b -> a .* b ≈ b *. a)) + ] + +multiplicativeGroupModuleLawsFail :: + ( Eq a + , Show a + , Arbitrary a + , Eq (r a) + , Show (r a) + , Arbitrary (r a) + , Epsilon a + , Epsilon (r a) + , MultiplicativeGroupModule r a + ) + => [Law2 (r a) a] +multiplicativeGroupModuleLawsFail = + [ ( "multiplicative group module unital: a ./ one == a" + , Unary2 (\a -> nearZero a || a ./ one == a)) + , ( "module multiplicative group equivalence: a ./ b ≈ recip b *. a" + , Binary2 (\a b -> b == zero || a ./ b ≈ recip b *. a)) + ] + +banachLaws :: + ( Ord a + , Fractional a + , Signed a + , Foldable r + , Fractional b + , Eq (r a) + , Epsilon b + , Epsilon (r a) + , Metric (r a) b + , MultiplicativeGroup b + , Banach r a + , Normed (r a) b + ) + => [Law2 (r a) b] +banachLaws = + [ ( "normalize a .* size a ≈ one" + , Unary2 + (\a -> + a == singleton zero || + (any ((> 10.0) . abs) a || (normalize a .* size a) ≈ a))) + ] + +hilbertLaws :: + (Eq (r a), Eq a, Multiplicative a, Epsilon a, Epsilon (r a), Hilbert r a) + => [Law2 (r a) a] +hilbertLaws = + [ ("commutative a <.> b ≈ b <.> a", Ternary2 (\a b _ -> a <.> b ≈ b <.> a)) + , ( "distributive over addition a <.> (b + c) == a <.> b + a <.> c" + , Ternary2'' (\a b c -> a <.> (b + c) ≈ a <.> b + a <.> c)) + , ( "bilinear a <.> (s *. b + c) == s * (a <.> b) + a <.> c" + , Quad31 (\a b c s -> a <.> (s *. b + c) == s * (a <.> b) + a <.> c)) + , ( "scalar multiplication (s0 *. a) <.> (s1 *. b) == s0 * s1 * (a <.> b)" + , Quad22 (\a b s0 s1 -> (s0 *. a) <.> (s1 *. b) == s0 * s1 * (a <.> b))) + ] + +tensorProductLaws :: + ( Eq (r (r a)) + , Additive (r (r a)) + , Eq (r a) + , Eq a + , TensorProduct (r a) + , Epsilon a + , Epsilon (r a) + , Representable r + ) + => [Law2 (r a) a] +tensorProductLaws = + [ ( "left distribution over addition a>< b" + , Ternary2'' (\a b c -> a >< b + c >< b == (a + c) >< b)) + , ( "right distribution over addition a>< (b+c)" + , Ternary2'' (\a b c -> a >< b + a >< c == a >< (b + c))) + -- , ( "left module tensor correspondance a *. (b> a *. (b> (a> [Law (r a)] +additiveBasisLaws = + [ ( "associative: (a .+. b) .+. c ≈ a .+. (b .+. c)" + , Ternary (\a b c -> (a .+. b) .+. c ≈ a .+. (b .+. c))) + , ("left id: zero .+. a = a", Unary (\a -> zero .+. a == a)) + , ("right id: a .+. zero = a", Unary (\a -> a .+. zero == a)) + , ("commutative: a .+. b == b .+. a", Binary (\a b -> a .+. b == b .+. a)) + ] + +additiveGroupBasisLaws :: (Eq (r a), AdditiveGroupBasis r a) => [Law (r a)] +additiveGroupBasisLaws = + [ ( "minus: a .-. a = singleton zero" + , Unary (\a -> (a .-. a) == singleton zero)) + ] + +multiplicativeBasisLaws :: (Eq (r a), MultiplicativeBasis r a) => [Law (r a)] +multiplicativeBasisLaws = + [ ( "associative: (a .*. b) .*. c == a .*. (b .*. c)" + , Ternary (\a b c -> (a .*. b) .*. c == a .*. (b .*. c))) + , ("left id: singleton one .*. a = a", Unary (\a -> singleton one .*. a == a)) + , ( "right id: a .*. singleton one = a" + , Unary (\a -> a .*. singleton one == a)) + , ("commutative: a .*. b == b .*. a", Binary (\a b -> a .*. b == b .*. a)) + ] + +multiplicativeGroupBasisLaws :: + ( Eq (r a) + , Epsilon a + , Epsilon (r a) + , Singleton r + , MultiplicativeGroupBasis r a + ) + => [Law (r a)] +multiplicativeGroupBasisLaws = + [ ( "basis divide: a ./. a ≈ singleton one" + , Unary (\a -> a == singleton zero || (a ./. a) ≈ singleton one)) + ]