packages feed

tower (empty) → 0.1.0

raw patch · 8 files changed

+1222/−0 lines, 8 filesdep +HUnitdep +QuickCheckdep +basesetup-changed

Dependencies added: HUnit, QuickCheck, base, protolude, smallcheck, tasty, tasty-hunit, tasty-quickcheck, tasty-smallcheck, tower, vector

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Tony Day (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Tony Day nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Tower/Algebra.hs view
@@ -0,0 +1,646 @@+{-# LANGUAGE PolyKinds #-}++-- | Algebra++module Tower.Algebra (+    -- * general group structure+    Magma(..)+  , Unital(..)+  , Associative(..)+  , Commutative(..)+  , Invertible(..)+  , Idempotent(..)+  , Homomorphic(..)+  , Monoidal(..)+  , CMonoidal(..)+  , Loop(..)+  , Group(..)+  , Abelian(..)+    -- ** Additive Structure+  , AdditiveMagma(..)+  , AdditiveUnital(..)+  , AdditiveAssociative(..)+  , AdditiveCommutative(..)+  , AdditiveInvertible(..)+  , AdditiveHomomorphic(..)+  , AdditiveMonoidal(..)+  , Additive(..)+  , AdditiveGroup(..)+    -- ** Multiplicative Structure+  , MultiplicativeMagma(..)+  , MultiplicativeUnital(..)+  , MultiplicativeAssociative(..)+  , MultiplicativeCommutative(..)+  , MultiplicativeInvertible(..)+  , MultiplicativeHomomorphic(..)+  , MultiplicativeMonoidal(..)+  , Multiplicative(..)+  , MultiplicativeGroup(..)+    -- * Distributive+  , Distributive(..)+    -- * Ring+  , Semiring(..)+  , Ring(..)+  , Field(..)+    -- * Module+  , AdditiveBasis(..)+  , AdditiveGroupBasis(..)+  , AdditiveModule(..)+  , AdditiveGroupModule(..)+  , MultiplicativeBasis(..)+  , MultiplicativeGroupBasis(..)+  , MultiplicativeModule(..)+  , MultiplicativeGroupModule(..)+    -- * Integral+  , Integral(..)+    -- * Metric+  , Metric(..)+  , Normed(..)+  , abs+  , Banach(..)+  , BoundedField(..)+  , infinity+    -- * Exponential+  , ExpRing(..)+  , (^)+  , ExpField(..)+    -- * Tensor Algebra+  , Hilbert(..)+  , TensorAlgebra(..)+  , squaredInnerProductNorm+  , innerProductNorm+  , innerProductDistance+  ) where++import qualified Protolude as P+import Protolude (Double, Float, Int)++-- * Magma structure+-- | A <https://en.wikipedia.org/wiki/Magma_(algebra) Magma> is a tuple (T,⊕) consisting of+--+-- - a type a, and+--+-- - a function (⊕) :: T -> T -> T+--+-- The mathematical laws for a magma are:+--+-- - ⊕ is defined for all possible pairs of type T, and+--+-- - ⊕ is closed in the set of all possible values of type T+--+-- or, more tersly,+--+-- > ∀ a, b ∈ T: a ⊕ b ∈ T+--+-- 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++-- | A Unital Magma+--+-- > unit ⊕ a = a+-- > a ⊕ unit = a+--+class Magma a => Unital a where unit :: a++-- | An Associative Magma+-- +-- > (a ⊕ b) ⊕ c = a ⊕ (b ⊕ c)+class Magma a => Associative a++-- | A Commutative Magma+--+-- > a ⊕ b = b ⊕ a+class Magma a => Commutative a++-- | An Invertible Magma+--+-- > ∀ a ∈ T: inv a ∈ T+--+-- law is true by construction in Haskell+--+class Magma a => Invertible a where inv :: a -> a++-- | An Idempotent Magma+--+-- > a ⊕ a = a+class Magma a => Idempotent a++-- | A Homomorphic 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++-- | A Monoidal Magma is associative and unital.+class ( Associative a+      , Unital a) =>+      Monoidal a+++-- | A CMonoidal Magma is commutative, associative and unital.+class ( Commutative a+      , Associative a+      , Unital a) =>+      CMonoidal a++-- | A Loop is unital and invertible+class ( Unital a+      , Invertible a) =>+      Loop a++-- | A Group is associative, unital and invertible+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')++-- | An Abelian Group is associative, unital, invertible and commutative+class ( Associative a+      , Unital a+      , Invertible a+      , Commutative a) =>+      Abelian a++-- * 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 for the additive magma to distinguish from '+' which, by convention, implies commutativity+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.+)++-- | AdditiveUnital+--+-- > zero `plus` a == a+-- > a `plus` 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++-- | AdditiveAssociative+--+-- > (a `plus` b) `plus` c == a `plus` (b `plus` c)+class AdditiveMagma a => AdditiveAssociative a++instance AdditiveAssociative Double+instance AdditiveAssociative Float+instance AdditiveAssociative Int++-- | AdditiveCommutative+--+-- > a `plus` b == b `plus` a+class AdditiveMagma a => AdditiveCommutative a++instance AdditiveCommutative Double+instance AdditiveCommutative Float+instance AdditiveCommutative Int++-- | AdditiveInvertible+--+-- > ∀ a ∈ A: negate a ∈ A+--+-- law is true by construction in Haskell+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++-- | AdditiveHomomorphic+--+-- > ∀ a ∈ A: plushom a ∈ B+--+-- law is true by construction in Haskell+class ( AdditiveMagma a+      , AdditiveMagma b) =>+      AdditiveHomomorphic a b where+    plushom :: a -> b++instance AdditiveMagma a => AdditiveHomomorphic a a where plushom a = a++-- | AdditiveMonoidal+class ( AdditiveUnital a+      , AdditiveAssociative a) =>+      AdditiveMonoidal a++-- | 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) =>+      Additive a where+    infixr 6 ++    (+) :: a -> a -> a+    a + b = plus a b++instance Additive Double+instance Additive Float+instance Additive Int++-- | AdditiveGroup+--+-- > a - a = zero+--+-- > negate a = zero - a+--+-- > negate a + a = zero+--+class ( Additive a+      , AdditiveInvertible a) =>+      AdditiveGroup a where+    infixr 6 -+    (-) :: a -> a -> a+    (-) a b = a `plus` negate b++instance AdditiveGroup Double+instance AdditiveGroup Float+instance AdditiveGroup Int++-- * 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++instance MultiplicativeMagma Double where times = (P.*)+instance MultiplicativeMagma Float where times = (P.*)+instance MultiplicativeMagma Int where times = (P.*)++-- | MultiplicativeUnital+--+-- > one `times` a == a+-- > a `times` 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++-- | MultiplicativeCommutative+--+-- > a `times` b == b `times` a+class MultiplicativeMagma a => MultiplicativeCommutative a++instance MultiplicativeCommutative Double+instance MultiplicativeCommutative Float+instance MultiplicativeCommutative Int++-- | MultiplicativeAssociative+--+-- > (a `times` b) `times` c == a `times` (b `times` c)+class MultiplicativeMagma a => MultiplicativeAssociative a++instance MultiplicativeAssociative Double+instance MultiplicativeAssociative Float+instance MultiplicativeAssociative Int++-- | MultiplicativeInvertible+--+-- > ∀ a ∈ A: recip a ∈ A+--+-- law is true by construction in Haskell+class MultiplicativeMagma a => MultiplicativeInvertible a where recip :: a -> a++instance MultiplicativeInvertible Double where recip = P.recip+instance MultiplicativeInvertible Float where recip = P.recip++-- | MultiplicativeHomomorphic+--+-- > ∀ a ∈ A: timeshom a ∈ B+--+-- law is true by construction in Haskell+class ( MultiplicativeMagma a+      , MultiplicativeMagma b) =>+      MultiplicativeHomomorphic a b where+    timeshom :: a -> b++instance MultiplicativeMagma a => MultiplicativeHomomorphic a a where+    timeshom a = a++-- | MultiplicativeMonoidal+class ( MultiplicativeUnital a+      , MultiplicativeAssociative a) =>+      MultiplicativeMonoidal a++-- | Multiplicative is commutative, associative and unital under multiplication+--+-- > a * b = b * a+--+-- > (a * b) * c = a * (b * c)+--+-- > one * a = a+--+-- > a * one = a+--+class ( MultiplicativeCommutative a+      , MultiplicativeUnital a+      , MultiplicativeAssociative a) =>+      Multiplicative a where+    infixr 7 *+    (*) :: a -> a -> a+    a * b = times a b++instance Multiplicative Double+instance Multiplicative Float+instance Multiplicative Int++-- | MultiplicativeGroup+--+-- > a / a = one+--+-- > recip a = one / a+--+-- > recip a * a = one+--+class ( Multiplicative a+      , MultiplicativeInvertible a) =>+      MultiplicativeGroup a where+    infixr 7 /+    (/) :: a -> a -> a+    (/) a b = a `times` recip b++instance MultiplicativeGroup Double+instance MultiplicativeGroup Float++-- | Distributive+--+-- > a . (b + c) == a . b + a . c+--+-- > (a + b) . c == a . c + b . c+--+class (+    Additive a+  , MultiplicativeMagma a+  ) => Distributive a++instance Distributive Double+instance Distributive Float+instance Distributive Int++-- | a semiring+class ( Additive a+      , MultiplicativeAssociative a+      , MultiplicativeUnital a+      , Distributive a) =>+      Semiring a++instance Semiring Double+instance Semiring Float+instance Semiring Int++-- | Ring+class ( AdditiveGroup a+      , MultiplicativeAssociative a+      , MultiplicativeUnital a+      , Distributive a) =>+      Ring a++instance Ring Double+instance Ring Float++-- | DivisionRing+class ( AdditiveGroup a+      , Multiplicative a+      , Distributive a) =>+      DivisionRing a++instance DivisionRing Double+instance DivisionRing Float++-- | Field+class ( AdditiveGroup a+      , MultiplicativeGroup a+      , Distributive a) =>+      Field a++instance Field Double+instance Field Float++-- * Additive Module Structure++-- | AdditiveBasis+-- element by element addition+class ( Additive a+      , AdditiveHomomorphic a a) =>+      AdditiveBasis a where+    infixr 7 .+.+    (.+.) :: a -> a -> a+    a .+. b = plushom a + plushom b++-- | AdditiveGroupBasis+-- element by element subtraction+class ( AdditiveGroup a+      , AdditiveHomomorphic a a) =>+      AdditiveGroupBasis a where+    infixr 7 .-.+    (.-.) :: a -> a -> a+    a .-. b = plushom a - plushom b++-- | AdditiveModule+class ( Additive a+      , Additive s+      , AdditiveHomomorphic s a) =>+      AdditiveModule s a where+    infixr 7 .++    (.+) :: AdditiveModule s a => s -> a -> a+    s .+ a = plushom s + a++    infixr 7 +.+    (+.) :: AdditiveModule s a => a -> s -> a+    a +. s = a + plushom s++-- | AdditiveGroupModule+class ( AdditiveModule s a+      , AdditiveGroup a) =>+      AdditiveGroupModule s a where+    infixr 7 .-+    (.-) :: AdditiveModule s a => s -> a -> a+    s .- a = plushom s + a++    infixr 7 -.+    (-.) :: AdditiveModule s a => a -> s -> a+    a -. s = a - plushom s++-- * Multiplicative Module Structure++-- | MultiplicativeBasis+-- element by element addition+class ( Multiplicative a+      , MultiplicativeHomomorphic a a) =>+      MultiplicativeBasis a where+    infixr 7 .*.+    (.*.) :: a -> a -> a+    a .*. b = timeshom a * timeshom b++-- | MultiplicativeGroupBasis+-- element by element subtraction+class ( MultiplicativeGroup a+      , MultiplicativeHomomorphic a a) =>+      MultiplicativeGroupBasis a where+    infixr 7 ./.+    (./.) :: a -> a -> a+    a ./. b = timeshom a / timeshom b++-- | MultiplicativeModule+class ( Multiplicative a+      , Multiplicative s+      , MultiplicativeHomomorphic s a) =>+      MultiplicativeModule s a where+    infixr 7 .*+    (.*) :: MultiplicativeModule s a => s -> a -> a+    s .* a = timeshom s * a++    infixr 7 *.+    (*.) :: MultiplicativeModule s a => a -> s -> a+    a *. s = a * timeshom s++-- | MultiplicativeGroupModule+class ( MultiplicativeModule s a+      , MultiplicativeGroup a) =>+      MultiplicativeGroupModule s a where+    infixr 7 ./+    (./) :: MultiplicativeModule s a => s -> a -> a+    s ./ a = timeshom s * a++    infixr 7 /.+    (/.) :: MultiplicativeModule s a => a -> s -> a+    a /. s = a / timeshom s++-- | Integral+--+-- > b == zero || b * (a `div` b) + (a `mod` b) == a+-- > b == zero || b * (a `quot` b) + (a `rem` b) == a+--+class (Additive a, Multiplicative a) => Integral a where++    toInteger :: a -> P.Integer++    infixl 7 `div`, `mod`++    -- | truncates towards negative infinity+    div :: a -> a -> a+    div a1 a2 = P.fst (divMod a1 a2)+    mod :: a -> a -> a+    mod a1 a2 = P.snd (divMod a1 a2)++    divMod :: a -> a -> (a,a)+ +instance Integral Int where+    toInteger = P.toInteger+    divMod = P.divMod++-- | Metric+class Metric r m where+    d :: m -> m -> r++-- | Normed+class Normed a where+    size :: a -> a++-- | abs+abs :: Normed a => a -> a+abs = size++-- | Banach+class ( MultiplicativeGroup a+      , MultiplicativeModule a a+      , MultiplicativeGroupModule a a+      , MultiplicativeInvertible a+      , Normed a) =>+      Banach a where+    normalize :: a -> a+    normalize a = a ./ size a++-- | BoundedField+class ( Field a+      , P.Bounded a) =>+      BoundedField a where+    nan :: a+    nan = zero/zero++instance P.Bounded Float where+    maxBound = one/zero+    minBound = negate (one/zero)+instance BoundedField Float++instance P.Bounded Double where+    maxBound = one/zero+    minBound = negate (one/zero)+instance BoundedField Double++-- | infinity+infinity :: BoundedField a => a+infinity = P.maxBound++-- | ExpRing+class Ring a => ExpRing a where+    logBase :: a -> a -> a++    (**) :: ExpRing a => a -> a -> a+    (**) = P.undefined++-- | (^)+(^) :: ExpRing a => a -> a -> a+(^) = (**)++-- | ExpField+class ( Field a+      , ExpRing a ) =>+      ExpField a where+    sqrt :: a -> a+    sqrt a = a**(one/one+one)++    exp :: a -> a+    log :: a -> a++-- | ><+infixr 8 ><+type family (><) (a::k1) (b::k2) :: *++-- | TensorAlgebra+class TensorAlgebra a where+    (><) :: a -> a -> (a><a)+    timesleft :: a -> (a><a) -> a+    timesright :: (a><a) -> a -> a++-- | Hilbert+class (Banach a, TensorAlgebra a, ExpField r, AdditiveGroup a) => Hilbert a r where+    infix 8 <?>+    (<?>) :: a -> a -> r++-- | squaredInnerProductNorm +squaredInnerProductNorm :: Hilbert v r => v -> r+squaredInnerProductNorm v = v <?> v++-- | innerProductNorm +innerProductNorm :: (Hilbert v r) => v -> r+innerProductNorm = sqrt P.. squaredInnerProductNorm++-- | innerProductDistance+innerProductDistance :: Hilbert v r => v -> v -> r+innerProductDistance v1 v2 = innerProductNorm (v1 - v2)
+ src/Tower/Prelude.hs view
@@ -0,0 +1,28 @@+{-# OPTIONS_GHC -Wall #-}++-- | exactly protolude hiding tower api+module Tower.Prelude (module X) where++import Protolude as X hiding+    ( (+)+    , (-)+    , (*)+    , (/)+    , zero+    , negate+    , recip+    , Integral(..)+    , Semiring(..)+    , log+    , logBase+    , exp+    , sqrt+    , (**)+    , abs+    , (^)+    , infinity+    )++import Tower.Algebra as X+import Tower.VectorA as X()+import Tower.VectorU as X
+ src/Tower/VectorA.hs view
@@ -0,0 +1,89 @@+{-# OPTIONS_GHC -fno-warn-missing-methods #-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+{-# LANGUAGE DataKinds #-}++-- | Applicative-style vector+module Tower.VectorA+    ( VectorA(..)+    )+    where++import qualified Protolude as P+import Protolude (Applicative(..), ($), (<$>), (<*>), Functor(..), Show(..), show, Eq(..), Traversable(..))+import Tower.Algebra+import GHC.TypeLits+import GHC.Show+import Test.QuickCheck++-- | a wrapped fixed-size traversable container+newtype VectorA n f a = VectorA { unvec :: (P.Traversable f, KnownNat n, Applicative f, Functor f) => f a}++instance (KnownNat n, Traversable f, Applicative f, Eq (f a)) => Eq (VectorA n f a) where+    (==) (VectorA v) (VectorA v') = v == v'++instance (KnownNat n, Traversable f, Applicative f, Show (f a)) => Show (VectorA n f a) where+    show (VectorA v) = GHC.Show.show v++instance (P.Num a, AdditiveUnital a, Arbitrary a) => Arbitrary (VectorA 5 [] a) where+    arbitrary = frequency+        [ (1, pure $ VectorA $ P.replicate 5 zero)+        , (9, pure $ VectorA [1,2,3,4,5])+        ]++data Supply s v = Supply { unSupply :: [s] -> ([s],v) }+ +instance Functor (Supply s) where +  fmap f av = Supply (\l -> let (l',v) = unSupply av l in (l',f v))+ +instance Applicative (Supply s) where+  pure v    = Supply (\l -> (l,v))+  af <*> av = Supply (\l -> let (l',f)  = unSupply af l+                                (l'',v) = unSupply av l'+                            in (l'',f v))+ +runSupply :: Supply s v -> [s] -> v+runSupply av l = P.snd $ unSupply av l+ +supply :: Supply s s+supply = Supply (\(x:xs) -> (xs,x))+ +zipWithTF :: (P.Traversable t, P.Foldable f) => (a -> b -> c) -> t a -> f b -> t c+zipWithTF g t f = runSupply  (P.traverse (\a -> g a <$> supply) t) (P.toList f)++binOp :: (a -> a -> a) -> VectorA n f a -> VectorA n f a -> VectorA n f a+binOp mag (VectorA a) (VectorA b) = VectorA $ zipWithTF mag a b++instance (AdditiveMagma a) => AdditiveMagma (VectorA n f a) where+    plus = binOp plus+instance (AdditiveAssociative a) => AdditiveAssociative (VectorA n f a)+instance (AdditiveCommutative a) => AdditiveCommutative (VectorA n f a)+instance (AdditiveUnital a, KnownNat n) => AdditiveUnital (VectorA n [] a) where+    zero = VectorA $ P.replicate n zero+      where+            n = P.fromInteger $ natVal (P.Proxy :: P.Proxy n)+instance (AdditiveInvertible a) => AdditiveInvertible (VectorA n f a) where+    negate (VectorA a) = VectorA $ negate <$> a+instance (Additive a, KnownNat n) => Additive (VectorA n [] a)+instance (AdditiveGroup a, KnownNat n) => AdditiveGroup (VectorA n [] a)+instance (AdditiveMagma a, KnownNat n) => AdditiveHomomorphic a (VectorA n [] a) where+    plushom a = VectorA $ P.replicate n a+      where+            n = P.fromInteger $ natVal (P.Proxy :: P.Proxy n)+instance (Additive a, KnownNat n) => AdditiveModule a (VectorA n [] a)++instance (MultiplicativeMagma a) => MultiplicativeMagma (VectorA n f a) where+    times = binOp times+instance (MultiplicativeAssociative a) => MultiplicativeAssociative (VectorA n f a)+instance (MultiplicativeCommutative a) => MultiplicativeCommutative (VectorA n f a)+instance (MultiplicativeUnital a, KnownNat n) => MultiplicativeUnital (VectorA n [] a) where+    one = VectorA $ P.replicate n one+      where+            n = P.fromInteger $ natVal (P.Proxy :: P.Proxy n)+instance (MultiplicativeInvertible a) => MultiplicativeInvertible (VectorA n f a) where+    recip (VectorA a) = VectorA $ recip <$> a+instance (Multiplicative a, KnownNat n) => Multiplicative (VectorA n [] a)+instance (MultiplicativeMagma a) => MultiplicativeHomomorphic a (VectorA n f a) where+    timeshom a = VectorA (pure a)+instance (Multiplicative a, KnownNat n) => MultiplicativeModule a (VectorA n [] a)++instance (Distributive a, KnownNat n) => Distributive (VectorA n [] a)
+ src/Tower/VectorU.hs view
@@ -0,0 +1,75 @@+{-# OPTIONS_GHC -fno-warn-missing-methods #-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+{-# LANGUAGE DataKinds #-}++-- | unboxed vector++module Tower.VectorU+    ( VectorU(..)+    , toVectorU+    )+    where++import qualified Protolude as P+import Protolude+    (Applicative(..), ($), (<$>), (<*>), Functor(..), Show(..), show, Eq(..))+import Tower.Algebra+import GHC.TypeLits+import Data.Vector.Unboxed as V+import Data.Proxy (Proxy(..))+import Test.QuickCheck++-- newtype VectorU n a = VectorU { unvec :: (KnownNat n, Unbox a) => Vector a}+-- | wrapped fixed-size unboxed vector+data VectorU (n :: Nat) a = VectorU { v :: Vector a} deriving (Eq, Show)++instance (KnownNat n, Arbitrary a, Unbox a, AdditiveUnital a) => Arbitrary (VectorU n a) where+    arbitrary = frequency+        [ (1, pure zero)+        , (9, toVectorU <$> arbitrary)+        ]++-- | toVectorU right pads with zeros, if necessary+-- which introduces an extra AdditiveUnital constraint+toVectorU :: forall a n . (AdditiveUnital a, Unbox a, KnownNat n) => [a] -> VectorU (n :: Nat) a+toVectorU l = VectorU $ fromList $ P.take n $ l P.++ P.repeat zero+  where+    n = P.fromInteger $ natVal (Proxy :: Proxy n)++binOp :: (Unbox a) => (a -> a -> a) -> VectorU n a -> VectorU n a -> VectorU n a+binOp mag (VectorU a) (VectorU b) = VectorU $ zipWith mag a b++instance (Unbox a, AdditiveMagma a) => AdditiveMagma (VectorU n a) where+    plus = binOp plus+instance (Unbox a, AdditiveAssociative a) => AdditiveAssociative (VectorU n a)+instance (Unbox a, AdditiveCommutative a) => AdditiveCommutative (VectorU n a)+instance (KnownNat n, Unbox a, AdditiveUnital a) => AdditiveUnital (VectorU n a) where+    zero = toVectorU []+instance (Unbox a, AdditiveInvertible a) => AdditiveInvertible (VectorU n a) where+    negate (VectorU a) = VectorU $ map negate a+instance (KnownNat n, Unbox a, Additive a) => Additive (VectorU n a)+instance (KnownNat n, Unbox a, AdditiveGroup a) => AdditiveGroup (VectorU n a)+instance (KnownNat n, Unbox a, AdditiveUnital a, AdditiveMagma a) => AdditiveHomomorphic a (VectorU n a) where+    plushom a = toVectorU $ P.repeat a+instance (KnownNat n, Unbox a, Additive a) => AdditiveModule a (VectorU n a)++instance (Unbox a, MultiplicativeMagma a) => MultiplicativeMagma (VectorU n a) where+    times = binOp times+instance (Unbox a, MultiplicativeAssociative a) => MultiplicativeAssociative (VectorU n a)+instance (Unbox a, MultiplicativeCommutative a) => MultiplicativeCommutative (VectorU n a)+instance (KnownNat n, Unbox a, AdditiveUnital a, MultiplicativeUnital a) => MultiplicativeUnital (VectorU n a) where+    one = toVectorU $ P.repeat one+instance (Unbox a, MultiplicativeInvertible a) => MultiplicativeInvertible (VectorU n a) where+    recip (VectorU a) = VectorU $ map recip a+instance (KnownNat n, Unbox a, AdditiveUnital a, Multiplicative a) => Multiplicative (VectorU n a)+instance (KnownNat n, Unbox a, AdditiveUnital a, MultiplicativeGroup a) => MultiplicativeGroup (VectorU n a)+instance (KnownNat n, Unbox a, AdditiveUnital a, MultiplicativeUnital a, MultiplicativeMagma a) => MultiplicativeHomomorphic a (VectorU n a) where+    timeshom a = toVectorU $ P.repeat one+instance (KnownNat n, Unbox a, AdditiveUnital a, Multiplicative a) => MultiplicativeModule a (VectorU n a)++instance (KnownNat n, Unbox a, Distributive a) => Distributive (VectorU n a)+instance (KnownNat n, Unbox a, Ring a) => Ring (VectorU n a)++instance (KnownNat n, Unbox a, Integral a) => Integral (VectorU n a) where+    -- toInteger (VectorU v) = VectorU $ map P.toInteger v+    divMod = P.undefined -- divMod
+ test/test.hs view
@@ -0,0 +1,205 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE DataKinds #-}++module Main where++import Protolude hiding ((+),(-),(*),(/),zero,one,negate,recip,div,mod,rem,quot, Integral(..))+import Test.Tasty (TestName, TestTree, testGroup, defaultMain)+import Test.Tasty.QuickCheck+import Tower.Algebra+import Tower.VectorU+import Tower.VectorA++data LawArity a =+    Unary (a -> Bool) |+    Binary (a -> a -> Bool) |+    Ternary (a -> a -> a -> Bool) |+    Ornary (a -> a -> a -> a -> Bool) |+    Uniary (a -> Property)++type Law a = (TestName, LawArity a)++testLawOf  :: (Arbitrary a, Show a) => [a] -> Law a -> TestTree+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, Uniary f) = testProperty name f++tests :: TestTree+tests = testGroup "everything"+    [ testGroup "Int - Additive" $ testLawOf ([]::[Int]) <$> additiveLaws+    , testGroup "Int - Additive Group" $ testLawOf ([]::[Int]) <$> additiveGroupLaws+    , testGroup "Int - Multiplicative" $ testLawOf ([]::[Int]) <$> multiplicativeLaws+    , testGroup "Int - Distributive" $ testLawOf ([]::[Int]) <$> distributiveLaws+    , testGroup "Int - Integral" $ testLawOf ([]::[Int]) <$> integralLaws+    , testGroup "Float - Additive" $ testLawOf ([]::[Float]) <$> additiveFloatLaws+    , testGroup "Float - Additive Group" $ testLawOf ([]::[Float]) <$> additiveGroupLaws+    , testGroup "Float - Multiplicative" $ testLawOf ([]::[Float]) <$> multiplicativeFloatLaws+    , testGroup "Float - MultiplicativeGroup" $ testLawOf ([]::[Float]) <$> fieldFloatLaws+    , testGroup "Float - Distributive" $ testLawOf ([]::[Float]) <$> distributiveFloatLaws+    , testGroup "UVector 5 Int - Additive" $ testLawOf ([]::[VectorU 5 Int]) <$> additiveLaws+    , testGroup "VectorU 5 Int - Additive Group" $ testLawOf ([]::[VectorU 5 Int]) <$> additiveGroupLaws+    , testGroup "VectorU 5 Int - Multiplicative" $ testLawOf ([]::[VectorU 5 Int]) <$> multiplicativeLaws+    , testGroup "VectorU 5 Int - Distributive" $ testLawOf ([]::[VectorU 5 Int]) <$> distributiveLaws+    -- , testGroup "VectorU 5 Int - Integral" $ testLawOf ([]::[VectorU 5 Int]) <$> integralLaws+    , testGroup "VectorU 5 Float - Additive" $ testLawOf ([]::[VectorU 5 Float]) <$> additiveFloatLaws+    , testGroup "VectorU 5 Float - Additive Group" $ testLawOf ([]::[VectorU 5 Float]) <$> additiveGroupLaws+    , testGroup "VectorU 5 Float - Multiplicative" $ testLawOf ([]::[VectorU 5 Float]) <$> multiplicativeFloatLaws+    , testGroup "VectorU 5 Float - MultiplicativeGroup" $ testLawOf ([]::[VectorU 5 Float]) <$> fieldFloatLaws+    , testGroup "VectorU 5 Float - Distributive" $ testLawOf ([]::[VectorU 5 Float]) <$> distributiveFloatLaws+    , testGroup "VectorA Int - Additive" $ testLawOf ([]::[VectorA 5 [] Int]) <$> additiveLaws+    , testGroup "VectorA Int - Additive Group" $ testLawOf ([]::[VectorA 5 [] Int]) <$> additiveGroupLaws+    , testGroup "VectorA Int - Multiplicative" $ testLawOf ([]::[VectorA 5 [] Int]) <$> multiplicativeLaws+    , testGroup "VectorA Int - Distributive" $ testLawOf ([]::[VectorA 5 [] Int]) <$> distributiveLaws+    ]++main :: IO ()+main = defaultMain tests++additiveLaws ::+    ( Eq a+    , Additive a+    ) => [Law a]+additiveLaws =+    [ ("associative: a + b = b + a", 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))+    ]++additiveFloatLaws ::+    ( Eq a+    , Additive a+    , Show a+    , Arbitrary a+    ) => [Law a]+additiveFloatLaws =+    [ ("associative: a + b = b + a", Uniary $ 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 = b * a", 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))+    ]+++aboutEqual :: (AdditiveGroup a, Ord a) => a -> a -> a -> Bool+aboutEqual eps a b = a - b <= eps && b - a <= eps++multiplicativeFloatLaws ::+    ( Eq a+    , Show a+    , Arbitrary a+    , Multiplicative a+    ) => [Law a]+multiplicativeFloatLaws =+    [ ("associative: a * b = b * a", Uniary $ 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))+    ]++fieldLaws ::+    ( Eq a+    , MultiplicativeGroup a+    , AdditiveGroup a+    ) => [Law a]+fieldLaws =+    [ ("divide: a == zero || a / a = one", Unary (\a -> a == zero || (a / a) == one))+    , ("recip divide: recip a == one / a", Unary (\a -> recip a == one / a))+    , ("recip left: recip a * a == one", Unary (\a -> a == zero || recip a * a == one))+    , ("recip right: a * recip a == one", Unary (\a -> a == zero || a * recip a == one))+    ]++fieldFloatLaws ::+    ( MultiplicativeGroup a+    , AdditiveGroup a+    , Eq a+    ) => [Law a]+fieldFloatLaws =+    [ ("divide: a == zero || a / a == one", Uniary $ expectFailure . (\a -> a == zero || a / a == one))+    , ("recip divide: recip a == one / a", Unary (\a -> recip a == one / a))+    , ("recip left: recip a * a == one", Uniary $ expectFailure . (\a -> a == zero || recip a * a == one))+    , ("recip right: a * recip a == one", Uniary $ expectFailure . (\a -> a == zero || a * recip a == one))+    ]++distributiveLaws ::+    ( Eq a+    , Distributive a+    , Multiplicative a+    ) => [Law a]+distributiveLaws =+    [ ("annihilation: a * zero == zero", Unary (\a -> a * zero == zero))+    , ("left distributivity: a * (b + c) == a * b + a * c", Ternary (\a b c -> a * (b + c) == a * b + a * c))+    , ("right distributivity: (a + b) * c == a * c + b * c", Ternary (\a b c -> (a + b) * c == a * c + b * c))+    ]++distributiveFloatLaws ::+    ( Eq a+    , Distributive a+    , Multiplicative a+    , Show a+    , Arbitrary a+    ) => [Law a]+distributiveFloatLaws =+    [ ("annihilation: a * zero == zero", Unary (\a -> a * zero == zero))+    , ("left distributivity: a * (b + c) == a * b + a * c", Uniary $ expectFailure . (\a b c -> a * (b + c) == a * b + a * c))+    , ("right distributivity: (a + b) * c == a * c + b * c", Uniary $ expectFailure . (\a b c -> (a + b) * c == a * c + b * c))+    ]+++integralLaws ::+    ( Eq a+    , Integral a+    ) => [Law a]+integralLaws =+    [ ("integral divmod: b == zero || b * (a `div` b) + (a `mod` b) == a", Binary (\a b -> b == zero || b * (a `div` b) + (a `mod` b) == a))+   ]++todoLaws ::+    ( -- Eq a+    -- , AdditiveModule s a+    ) => [Law a]+todoLaws =+    [ -- (a1+a2) +. s == a1 +. a2 +. s+      -- m2 s = s *. (m1 + m2) == s*.m1 + s*.m2+      -- m s1 s2 = (s1+s2)*.m == s1*.m + s2*.m+      -- s1 s2 = s1*.(s2*.m) == (s1*s2)*.m+      -- m = 1 *. m == m+      -- free modules+      -- m1 m2 = m1.*.m2 == m2.*.m1+      -- m1 m2 m3 = m1.*.(m2.*.m3) == (m1.*.m2).*.m3+      -- m = m == m.*.ones+      -- Banach+      -- v1 v2 = size (v1 - v2) == distance v1 v2+      -- v = isZero v || size (normalize v) == 1+      -- Metric+      -- v1 v2 = distance v1 v2 >= 0+      -- v1 v2 = v1 == v2 == distance v1 v2 == 0+      -- v1 v2 = distance v1 v2 == distance v2 v1+      -- m1 m2 m3 = distance m1 m2 <= distance m1 m3 + distance m2 m3+      --         && distance m1 m3 <= distance m1 m2 + distance m2 m3+      --         && distance m2 m3 <= distance m1 m3 + distance m2 m1+    ]+
+ tower.cabal view
@@ -0,0 +1,147 @@+name:+  tower+version:+  0.1.0+synopsis:+  A numeric tower+description:+  A heirarchy of classes for numbers and algebras that combine them: a numeric tower.+  .+  Performance testing, notes and examples can be found in <https://github.com/tonyday567/tower-dev tower-dev>.+  .+  The tower looks something like:+  .+  <<https://tonyday567.github.io/other/field-tower.svg>>+  .+  To use the library:+  .+  > import Tower.Prelude+  > print $ 1 + 1+category:+  mathematics+homepage:+  https://github.com/tonyday567/tower+license:+  BSD3+license-file:+  LICENSE+author:+  Tony Day+maintainer:+  tonyday567@gmail.com+copyright:+  Tony Day+build-type:+  Simple+cabal-version:+  >=1.14++library+  default-language:+    Haskell2010+  ghc-options:+  hs-source-dirs:+    src+  exposed-modules:+    Tower.Algebra,+    Tower.Prelude,+    Tower.VectorA,+    Tower.VectorU+  build-depends:+    base >= 4.7 && < 5,+    protolude,+    vector,+    QuickCheck+  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++test-suite test+  default-language:+    Haskell2010+  type:+    exitcode-stdio-1.0+  hs-source-dirs:+    test+  main-is:+    test.hs+  build-depends:+    base >= 4.7 && < 5,+    protolude,+    tasty,+    HUnit,+    tasty-hunit,+    smallcheck,+    tasty-smallcheck,+    QuickCheck,+    tasty-quickcheck,+    tower+  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++source-repository head+  type:+    git+  location:+    https://github.com/tonyday567/tower