Merge pull request #21 from leftaroundabout/devel/generic-instances

Give the classes default implementations, using GHC generics

src/Data/AdditiveGroup.hs

@@ -1,4 +1,8 @@
 {-# LANGUAGE TypeOperators, CPP #-}
+{-# LANGUAGE FlexibleInstances  #-}
+{-# LANGUAGE FlexibleContexts   #-}
+{-# LANGUAGE DefaultSignatures   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 ----------------------------------------------------------------------
 -- |
 -- Module      :   Data.AdditiveGroup
@@ -31,16 +35,26 @@ import Foreign.C.Types (CSChar, CInt, CShort, CLong, CLLong, CIntMax, CFloat, CD
 
 import Data.MemoTrie
 
+import Data.VectorSpace.Generic
+import qualified GHC.Generics as Gnrx
+import GHC.Generics (Generic, (:*:)(..))
+
 infixl 6 ^+^, ^-^
 
 -- | Additive group @v@.
 class AdditiveGroup v where
   -- | The zero element: identity for '(^+^)'
   zeroV :: v
+  default zeroV :: (Generic v, AdditiveGroup (VRep v)) => v
+  zeroV = Gnrx.to (zeroV :: VRep v)
   -- | Add vectors
   (^+^) :: v -> v -> v
+  default (^+^) :: (Generic v, AdditiveGroup (VRep v)) => v -> v -> v
+  v ^+^ v' = Gnrx.to (Gnrx.from v ^+^ Gnrx.from v' :: VRep v)
   -- | Additive inverse
   negateV :: v -> v
+  default negateV :: (Generic v, AdditiveGroup (VRep v)) => v -> v
+  negateV v = Gnrx.to (negateV $ Gnrx.from v :: VRep v)
   -- | Group subtraction
   (^-^) :: v -> v -> v
   v ^-^ v' = v ^+^ negateV v'
@@ -205,3 +219,21 @@ instance AdditiveGroup a => AdditiveGroup (Sum a) where
 -- argument = flip (.)
 
 -- g ~> f = result g . argument f
+
+
+
+instance AdditiveGroup a => AdditiveGroup (Gnrx.Rec0 a s) where
+  zeroV = Gnrx.K1 zeroV
+  negateV (Gnrx.K1 v) = Gnrx.K1 $ negateV v
+  Gnrx.K1 v ^+^ Gnrx.K1 w = Gnrx.K1 $ v ^+^ w
+  Gnrx.K1 v ^-^ Gnrx.K1 w = Gnrx.K1 $ v ^-^ w
+instance AdditiveGroup (f p) => AdditiveGroup (Gnrx.M1 i c f p) where
+  zeroV = Gnrx.M1 zeroV
+  negateV (Gnrx.M1 v) = Gnrx.M1 $ negateV v
+  Gnrx.M1 v ^+^ Gnrx.M1 w = Gnrx.M1 $ v ^+^ w
+  Gnrx.M1 v ^-^ Gnrx.M1 w = Gnrx.M1 $ v ^-^ w
+instance (AdditiveGroup (f p), AdditiveGroup (g p)) => AdditiveGroup ((f :*: g) p) where
+  zeroV = zeroV :*: zeroV
+  negateV (x:*:y) = negateV x :*: negateV y
+  (x:*:y) ^+^ (ξ:*:υ) = (x^+^ξ) :*: (y^+^υ)
+  (x:*:y) ^-^ (ξ:*:υ) = (x^-^ξ) :*: (y^-^υ)

src/Data/AffineSpace.hs

@@ -1,4 +1,10 @@
 {-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, TypeFamilies, CPP #-}
+{-# LANGUAGE FlexibleInstances  #-}
+{-# LANGUAGE DefaultSignatures   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators       #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE DeriveGeneric        #-}
 ----------------------------------------------------------------------
 -- |
 -- Module      :  Data.AffineSpace
@@ -22,6 +28,11 @@ import Foreign.C.Types (CSChar, CInt, CShort, CLong, CLLong, CIntMax, CFloat, CD
 import Control.Arrow(first)
 
 import Data.VectorSpace
+import Data.Basis
+
+import Data.VectorSpace.Generic
+import qualified GHC.Generics as Gnrx
+import GHC.Generics (Generic, (:*:)(..))
 
 -- Through 0.8.4, I used the following fixities.
 -- 
@@ -40,10 +51,18 @@ infix  6 .-.
 class AdditiveGroup (Diff p) => AffineSpace p where
   -- | Associated vector space
   type Diff p
+  type Diff p = GenericDiff p
   -- | Subtract points
   (.-.)  :: p -> p -> Diff p
+  default (.-.) :: ( Generic p, Diff p ~ GenericDiff p, AffineSpace (VRep p) )
+              => p -> p -> Diff p
+  p .-. q = GenericDiff
+         $ (Gnrx.from p .-. (Gnrx.from q :: VRep p))
   -- | Point plus vector
   (.+^)  :: p -> Diff p -> p
+  default (.+^) :: ( Generic p, Diff p ~ GenericDiff p, AffineSpace (VRep p) )
+              => p -> Diff p -> p
+  p .+^ GenericDiff q = Gnrx.to (Gnrx.from p .+^ q :: VRep p)
 
 -- | Point minus vector
 (.-^) :: AffineSpace p => p -> Diff p -> p
@@ -122,3 +141,58 @@ instance (AffineSpace p) => AffineSpace (a -> p) where
   type Diff (a -> p) = a -> Diff p
   (.-.)              = liftA2 (.-.)
   (.+^)              = liftA2 (.+^)
+
+
+
+newtype GenericDiff p = GenericDiff (Diff (VRep p))
+       deriving (Generic)
+
+instance AdditiveGroup (Diff (VRep p)) => AdditiveGroup (GenericDiff p)
+instance VectorSpace (Diff (VRep p)) => VectorSpace (GenericDiff p)
+instance InnerSpace (Diff (VRep p)) => InnerSpace (GenericDiff p)
+instance HasBasis (Diff (VRep p)) => HasBasis (GenericDiff p)
+
+data AffineDiffProductSpace f g p = AffineDiffProductSpace
+            !(Diff (f p)) !(Diff (g p)) deriving (Generic)
+instance (AffineSpace (f p), AffineSpace (g p))
+    => AdditiveGroup (AffineDiffProductSpace f g p)
+instance ( AffineSpace (f p), AffineSpace (g p)
+         , VectorSpace (Diff (f p)), VectorSpace (Diff (g p))
+         , Scalar (Diff (f p)) ~ Scalar (Diff (g p)) )
+    => VectorSpace (AffineDiffProductSpace f g p)
+instance ( AffineSpace (f p), AffineSpace (g p)
+         , InnerSpace (Diff (f p)), InnerSpace (Diff (g p))
+         , Scalar (Diff (f p)) ~ Scalar (Diff (g p))
+         , Num (Scalar (Diff (f p))) )
+    => InnerSpace (AffineDiffProductSpace f g p)
+instance (AffineSpace (f p), AffineSpace (g p))
+    => AffineSpace (AffineDiffProductSpace f g p) where
+  type Diff (AffineDiffProductSpace f g p) = AffineDiffProductSpace f g p
+  (.+^) = (^+^)
+  (.-.) = (^-^)
+instance ( AffineSpace (f p), AffineSpace (g p)
+         , HasBasis (Diff (f p)), HasBasis (Diff (g p))
+         , Scalar (Diff (f p)) ~ Scalar (Diff (g p)) )
+    => HasBasis (AffineDiffProductSpace f g p) where
+  type Basis (AffineDiffProductSpace f g p) = Either (Basis (Diff (f p)))
+                                                     (Basis (Diff (g p)))
+  basisValue (Left bf) = AffineDiffProductSpace (basisValue bf) zeroV
+  basisValue (Right bg) = AffineDiffProductSpace zeroV (basisValue bg)
+  decompose (AffineDiffProductSpace vf vg)
+        = map (first Left) (decompose vf) ++ map (first Right) (decompose vg)
+  decompose' (AffineDiffProductSpace vf _) (Left bf) = decompose' vf bf
+  decompose' (AffineDiffProductSpace _ vg) (Right bg) = decompose' vg bg
+
+
+instance AffineSpace a => AffineSpace (Gnrx.Rec0 a s) where
+  type Diff (Gnrx.Rec0 a s) = Diff a
+  Gnrx.K1 v .+^ w = Gnrx.K1 $ v .+^ w
+  Gnrx.K1 v .-. Gnrx.K1 w = v .-. w
+instance AffineSpace (f p) => AffineSpace (Gnrx.M1 i c f p) where
+  type Diff (Gnrx.M1 i c f p) = Diff (f p)
+  Gnrx.M1 v .+^ w = Gnrx.M1 $ v .+^ w
+  Gnrx.M1 v .-. Gnrx.M1 w = v .-. w
+instance (AffineSpace (f p), AffineSpace (g p)) => AffineSpace ((f :*: g) p) where
+  type Diff ((f:*:g) p) = AffineDiffProductSpace f g p
+  (x:*:y) .+^ AffineDiffProductSpace ξ υ = (x.+^ξ) :*: (y.+^υ)
+  (x:*:y) .-. (ξ:*:υ) = AffineDiffProductSpace (x.-.ξ) (y.-.υ)

src/Data/Basis.hs

@@ -1,5 +1,8 @@
 {-# LANGUAGE TypeOperators, TypeFamilies, UndecidableInstances
   , FlexibleInstances, MultiParamTypeClasses, CPP  #-}
+{-# LANGUAGE DefaultSignatures    #-}
+{-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE ScopedTypeVariables  #-}
 {-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
 ----------------------------------------------------------------------
 -- |
@@ -24,19 +27,35 @@ import Foreign.C.Types (CFloat, CDouble)
 
 import Data.VectorSpace
 
+import Data.VectorSpace.Generic
+import qualified GHC.Generics as Gnrx
+import GHC.Generics (Generic, (:*:)(..))
+
 -- using associated data type instead of associated type synonym to work
 -- around ghc bug <http://hackage.haskell.org/trac/ghc/ticket/3038>
 
 class VectorSpace v => HasBasis v where
   -- | Representation of the canonical basis for @v@
   type Basis v :: *
+  type Basis v = Basis (VRep v)
   -- | Interpret basis rep as a vector
   basisValue   :: Basis v -> v
+  default basisValue :: (Generic v, HasBasis (VRep v), Basis (VRep v) ~ Basis v)
+                    => Basis v -> v
+  basisValue b = Gnrx.to (basisValue b :: VRep v)
   -- | Extract coordinates
   decompose    :: v -> [(Basis v, Scalar v)]
+  default decompose :: ( Generic v, HasBasis (VRep v)
+                       , Scalar (VRep v) ~ Scalar v, Basis (VRep v) ~ Basis v )
+                    => v -> [(Basis v, Scalar v)]
+  decompose v = decompose (Gnrx.from v :: VRep v)
   -- | Experimental version.  More elegant definitions, and friendly to
   -- infinite-dimensional vector spaces.
   decompose'   :: v -> (Basis v -> Scalar v)
+  default decompose' :: ( Generic v, HasBasis (VRep v)
+                        , Scalar (VRep v) ~ Scalar v, Basis (VRep v) ~ Basis v )
+                    => v -> Basis v -> Scalar v
+  decompose' v = decompose' (Gnrx.from v :: VRep v)
 
 -- Defining property: recompose . decompose == id
 
@@ -131,3 +150,21 @@ t3 = basisValue (Right ()) :: (Float,Double)
 t4 = basisValue (Right (Left ())) :: (Float,Double,Float)
 
 -}
+
+instance HasBasis a => HasBasis (Gnrx.Rec0 a s) where
+  type Basis (Gnrx.Rec0 a s) = Basis a
+  basisValue = Gnrx.K1 . basisValue
+  decompose = decompose . Gnrx.unK1
+  decompose' = decompose' . Gnrx.unK1
+instance HasBasis (f p) => HasBasis (Gnrx.M1 i c f p) where
+  type Basis (Gnrx.M1 i c f p) = Basis (f p)
+  basisValue = Gnrx.M1 . basisValue
+  decompose = decompose . Gnrx.unM1
+  decompose' = decompose' . Gnrx.unM1
+instance (HasBasis (f p), HasBasis (g p), Scalar (f p) ~ Scalar (g p))
+         => HasBasis ((f :*: g) p) where
+  type Basis ((f:*:g) p) = Either (Basis (f p)) (Basis (g p))
+  basisValue (Left bf) = basisValue bf :*: zeroV
+  basisValue (Right bg) = zeroV :*: basisValue bg
+  decompose  (u:*:v)     = decomp2 Left u ++ decomp2 Right v
+  decompose' (u:*:v)     = decompose' u `either` decompose' v

src/Data/VectorSpace.hs

@@ -1,6 +1,9 @@
 {-# LANGUAGE MultiParamTypeClasses, TypeOperators
            , TypeFamilies, UndecidableInstances, CPP
            , FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances  #-}
+{-# LANGUAGE DefaultSignatures   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# OPTIONS_GHC -Wall #-}
 ----------------------------------------------------------------------
 -- |
@@ -38,20 +41,31 @@ import Data.Ratio
 import Data.AdditiveGroup
 import Data.MemoTrie
 
+import Data.VectorSpace.Generic
+import qualified GHC.Generics as Gnrx
+import GHC.Generics (Generic, (:*:)(..))
+
 infixr 7 *^
 
 -- | Vector space @v@.
 class AdditiveGroup v => VectorSpace v where
   type Scalar v :: *
+  type Scalar v = Scalar (VRep v)
   -- | Scale a vector
   (*^) :: Scalar v -> v -> v
+  default (*^) :: (Generic v, VectorSpace (VRep v), Scalar (VRep v) ~ Scalar v)
+                    => Scalar v -> v -> v
+  μ *^ v = Gnrx.to (μ *^ Gnrx.from v :: VRep v)
 
 infixr 7 <.>
 
 -- | Adds inner (dot) products.
 class (VectorSpace v, AdditiveGroup (Scalar v)) => InnerSpace v where
   -- | Inner/dot product
   (<.>) :: v -> v -> Scalar v
+  default (<.>) :: (Generic v, InnerSpace (VRep v), Scalar (VRep v) ~ Scalar v)
+                    => v -> v -> Scalar v
+  v<.>w = (Gnrx.from v :: VRep v) <.> Gnrx.from w
 
 infixr 7 ^/
 infixl 7 ^*
@@ -215,3 +229,24 @@ instance InnerSpace a => InnerSpace (Maybe a) where
 --   mu <.> mv = fromMaybe zeroV (liftA2 (<.>) mu mv)
 
 --   (<.>) = (fmap.fmap) (fromMaybe zeroV) (liftA2 (<.>))
+
+
+instance VectorSpace a => VectorSpace (Gnrx.Rec0 a s) where
+  type Scalar (Gnrx.Rec0 a s) = Scalar a
+  μ *^ Gnrx.K1 v = Gnrx.K1 $ μ*^v
+instance VectorSpace (f p) => VectorSpace (Gnrx.M1 i c f p) where
+  type Scalar (Gnrx.M1 i c f p) = Scalar (f p)
+  μ *^ Gnrx.M1 v = Gnrx.M1 $ μ*^v
+instance (VectorSpace (f p), VectorSpace (g p), Scalar (f p) ~ Scalar (g p))
+         => VectorSpace ((f :*: g) p) where
+  type Scalar ((f:*:g) p) = Scalar (f p)
+  μ *^ (x:*:y) = μ*^x :*: μ*^y
+
+instance InnerSpace a => InnerSpace (Gnrx.Rec0 a s) where
+  Gnrx.K1 v <.> Gnrx.K1 w = v<.>w
+instance InnerSpace (f p) => InnerSpace (Gnrx.M1 i c f p) where
+  Gnrx.M1 v <.> Gnrx.M1 w = v<.>w
+instance ( InnerSpace (f p), InnerSpace (g p)
+         , Scalar (f p) ~ Scalar (g p), Num (Scalar (f p)) )
+         => InnerSpace ((f :*: g) p) where
+  (x:*:y) <.> (ξ:*:υ) = x<.>ξ + y<.>υ

src/Data/VectorSpace/Generic.hs

@@ -0,0 +1,20 @@
+-- |
+-- Module      :   Data.VectorSpace.Generic
+-- Copyright   :  (c) Conal Elliott and Justus Sagemüller 2017
+-- License     :  BSD3
+-- 
+-- Maintainer  :  conal@conal.net, (@) jsagemue $ uni-koeln.de
+-- Stability   :  experimental
+-- 
+-- Underpinnings of the type that represents vector / affine / etc. spaces
+-- with GHC generics
+
+module Data.VectorSpace.Generic where
+
+
+import qualified GHC.Generics as Gnrx
+
+import Data.Void
+
+
+type VRep v = Gnrx.Rep v Void

vector-space.cabal

@@ -44,6 +44,8 @@ Library
                      Data.Derivative
                      Data.Cross
                      Data.AffineSpace
+  Other-Modules:     
+                     Data.VectorSpace.Generic
 
 
   -- This library relies on type families working as well as in 6.10.