diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -1,19 +1,76 @@ -language: haskell -before_install: - # Uncomment whenever hackage is down. - # - mkdir -p ~/.cabal && cp travis/config ~/.cabal/config && cabal update +# vim: nospell +# +# Basic template to test with GHC=[7.8, 7.10, 8.0]. Caches the 'stack' build +# directory to speed subsequent compilations. +# +language: generic +dist: precise - # Try installing some of the build-deps with apt-get for speed. - - travis/cabal-apt-install $mode +cache: + directories: + - $HOME/.stack + - .stack-work/install +addons: + apt: + sources: &apt_sources + - hvr-ghc + - ubuntu-toolchain-r-test + packages: &apt_packages + - libgmp-dev + - happy-1.19.5 + - alex-3.1.7 + +matrix: + include: + - env: GHC=7.8.4 CABAL=1.18 + compiler: "GHC 7.8" + addons: { apt: { sources: [ *apt_sources ], packages: [ *apt_packages, cabal-install-1.18 ] }} + + - env: GHC=7.10.3 CABAL=1.22 + compiler: "GHC 7.10" + addons: { apt: { sources: [ *apt_sources ], packages: [ *apt_packages, cabal-install-1.22 ] }} + + - env: GHC=8.0.2 CABAL=1.24 + compiler: "GHC 8.0" + addons: { apt: { sources: [ *apt_sources ], packages: [ *apt_packages, cabal-install-1.24 ] }} + + # - env: GHC=head CABAL=head + # compiler: "GHC HEAD" + # addons: { apt: { sources: [ *apt_sources ], packages: [ *apt_packages, ghc-head, cabal-install-head ] }} + + # allow_failures: + # - env: GHC=head CABAL=head + + fast_finish: true + +before_install: + - export PATH=/opt/cabal/$CABAL/bin:/opt/alex/3.1.7/bin:/opt/happy/1.19.5/bin:$HOME/.cabal/bin:$PATH + - source .travis/install-stack.sh + install: - - cabal configure $mode - - cabal build + - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" + - cabal --version + - stack --version + - | + if [ ${GHC} == head -o ! -e stack.yaml ]; then + travis_retry cabal install --only-dependencies + else + travis_retry stack build --only-dependencies --no-terminal --no-haddock-deps + fi script: - - $script - - hlint src --cpp-define HLINT + - | + if [ ${GHC} == head -o ! -e stack.yaml ]; then + cabal install + cabal haddock + else + stack build --no-terminal --haddock --no-haddock-deps + fi +after_success: + - source .travis/update-accelerate-buildbot.sh + notifications: irc: channels: @@ -22,5 +79,3 @@ template: - "\x0313linear-accelerate\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" -env: - - mode="--enable-tests" script="cabal test" diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,7 +1,7 @@ linear-accelerate ================= -This package provides orphan instances that allows you to use `linear` vector spaces on `accelerate` backends +This package provides orphan instances that allows you to use `linear` vector spaces in `accelerate`. Contact Information ------------------- diff --git a/linear-accelerate.cabal b/linear-accelerate.cabal --- a/linear-accelerate.cabal +++ b/linear-accelerate.cabal @@ -1,22 +1,21 @@ name: linear-accelerate category: Math, Algebra, Compilers/Interpreters, Concurrency, Data, Parallelism -version: 0.2 +version: 0.3 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE -author: Edward A. Kmett, Charles Durham +author: Edward A. Kmett, Charles Durham, Trevor L. McDonell maintainer: Edward A. Kmett stability: provisional homepage: http://github.com/ekmett/linear-accelerate/ bug-reports: http://github.com/ekmett/linear-accelerate/issues copyright: Copyright (C) 2014 Edward A. Kmett -synopsis: Instances to use linear vector spaces on accelerate backends -description: Instances to use linear vector spaces on accelerate backends +synopsis: Lifting linear vector spaces into Accelerate +description: Lifting linear vector spaces into Accelerate build-type: Custom extra-source-files: .travis.yml .vim.custom - travis/config CHANGELOG.markdown README.markdown @@ -24,15 +23,43 @@ type: git location: git://github.com/ekmett/linear-accelerate.git +source-repository this + type: git + tag: v0.3 + location: git://github.com/ekmett/linear-accelerate.git + +custom-setup + setup-depends: + base >= 4.5 + , Cabal >= 1.18 + , filepath >= 1.0 + library build-depends: - accelerate >= 0.15 && < 0.16, - base >= 4.5 && < 5, - lens >= 4 && < 5, - linear >= 1.10 && < 2 + base >= 4.5 && < 5 + , accelerate >= 0.16 + , distributive >= 0.2.2 && < 1 + , lens >= 4 && < 5 + , linear >= 1.10 && < 2 exposed-modules: - Linear.Accelerate + Data.Array.Accelerate.Linear + Data.Array.Accelerate.Linear.Epsilon + Data.Array.Accelerate.Linear.Matrix + Data.Array.Accelerate.Linear.Metric + Data.Array.Accelerate.Linear.Plucker + Data.Array.Accelerate.Linear.Quaternion + Data.Array.Accelerate.Linear.Type + Data.Array.Accelerate.Linear.V0 + Data.Array.Accelerate.Linear.V1 + Data.Array.Accelerate.Linear.V2 + Data.Array.Accelerate.Linear.V3 + Data.Array.Accelerate.Linear.V4 + Data.Array.Accelerate.Linear.Vector + other-modules: + Data.Array.Accelerate.Linear.Lift + ghc-options: -Wall -fwarn-tabs -O2 hs-source-dirs: src + diff --git a/src/Data/Array/Accelerate/Linear.hs b/src/Data/Array/Accelerate/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/Linear.hs @@ -0,0 +1,45 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Array.Accelerate.Linear +-- Copyright : 2014 Edward Kmett, Charles Durham, +-- 2015 Trevor L. McDonell +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : non-portable +-- +-- This module simply re-exports everything from the various modules +-- that make up the linear package, lifted to Accelerate. +---------------------------------------------------------------------------- + +module Data.Array.Accelerate.Linear ( + + module Data.Array.Accelerate.Linear.Type, + module Data.Array.Accelerate.Linear.Epsilon, + module Data.Array.Accelerate.Linear.Matrix, + module Data.Array.Accelerate.Linear.Metric, + module Data.Array.Accelerate.Linear.Plucker, + module Data.Array.Accelerate.Linear.Quaternion, + module Data.Array.Accelerate.Linear.V0, + module Data.Array.Accelerate.Linear.V1, + module Data.Array.Accelerate.Linear.V2, + module Data.Array.Accelerate.Linear.V3, + module Data.Array.Accelerate.Linear.V4, + module Data.Array.Accelerate.Linear.Vector, + +) where + +import Data.Array.Accelerate.Linear.Type +import Data.Array.Accelerate.Linear.Epsilon +import Data.Array.Accelerate.Linear.Matrix +import Data.Array.Accelerate.Linear.Metric +import Data.Array.Accelerate.Linear.Plucker +import Data.Array.Accelerate.Linear.Quaternion +import Data.Array.Accelerate.Linear.V0 +import Data.Array.Accelerate.Linear.V1 +import Data.Array.Accelerate.Linear.V2 +import Data.Array.Accelerate.Linear.V3 +import Data.Array.Accelerate.Linear.V4 +import Data.Array.Accelerate.Linear.Vector + diff --git a/src/Data/Array/Accelerate/Linear/Epsilon.hs b/src/Data/Array/Accelerate/Linear/Epsilon.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/Linear/Epsilon.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Array.Accelerate.Linear.Epsilon +-- Copyright : 2014 Edward Kmett, Charles Durham, +-- 2015 Trevor L. McDonell +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : non-portable +-- +-- Free metric spaces +---------------------------------------------------------------------------- + +module Data.Array.Accelerate.Linear.Epsilon + where + +import Data.Array.Accelerate + + +-- | Provides a fairly subjective test to see if a quantity is near zero. +-- +-- >>> nearZero (1e-11 :: Double) +-- False +-- +-- >>> nearZero (1e-17 :: Double) +-- True +-- +-- >>> nearZero (1e-5 :: Float) +-- False +-- +-- >>> nearZero (1e-7 :: Float) +-- True +-- +class Num a => Epsilon a where + -- | Determine if a quantity is near zero. + nearZero :: Exp a -> Exp Bool + +-- | @'abs' a '<=' 1e-6@ +-- +instance Epsilon Float where + nearZero a = abs a <= 1.0e-6 + +-- | @'abs' a '<=' 1e-12@ +-- +instance Epsilon Double where + nearZero a = abs a <= 1.0e-12 + +-- | @'abs' a '<=' 1e-6@ +-- +instance Epsilon CFloat where + nearZero a = abs a <= 1.0e-6 + +-- | @'abs' a '<=' 1e-12@ +-- +instance Epsilon CDouble where + nearZero a = abs a <= 1.0e-12 + diff --git a/src/Data/Array/Accelerate/Linear/Lift.hs b/src/Data/Array/Accelerate/Linear/Lift.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/Linear/Lift.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Array.Accelerate.Linear.Lift +-- Copyright : 2015 Trevor L. McDonell +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable +-- +---------------------------------------------------------------------------- + +module Data.Array.Accelerate.Linear.Lift ( liftLens, unlift' ) + where + +import Data.Array.Accelerate +import Data.Array.Accelerate.Linear.Type + + +-- Lift a 'Lens' into Accelerate terms +-- +liftLens + :: (Functor f, Unlift box s, Unlift box t, Unlift box b, Lift box a) + => ((a -> f b) -> s -> f t) -- Lens s t a b + -> (box (Plain a) -> f (box (Plain b))) + -> box (Plain s) + -> f (box (Plain t)) +liftLens l f x = lift `fmap` l (fsink1 f) (unlift x) + + +-- | Sink a unary functor from Accelerate terms +-- +fsink1 :: (Functor f, Unlift box b, Lift box a) + => (box (Plain a) -> f (box (Plain b))) + -> a + -> f b +fsink1 f = fmap unlift . f . lift + + +-- | 'unlift' through two surface types +-- +unlift' :: forall f g a. (Functor f, Box f (g a), Box g a) + => Exp (f (g a)) + -> f (g (Exp a)) +unlift' x = fmap unlift (unlift x :: f (Exp (g a))) + diff --git a/src/Data/Array/Accelerate/Linear/Matrix.hs b/src/Data/Array/Accelerate/Linear/Matrix.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/Linear/Matrix.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Array.Accelerate.Linear.Matrix +-- Copyright : 2014 Edward Kmett, Charles Durham, +-- 2015 Trevor L. McDonell +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : non-portable +-- +-- Simple matrix operations for low-dimensional primitives +---------------------------------------------------------------------------- + +module Data.Array.Accelerate.Linear.Matrix ( + + M22, M23, M24, M32, M33, M34, M42, M43, M44, + (!*!), (!+!), (!-!), (!*), (*!), (!!*), (*!!), (!!/), + transpose, + identity, + Trace(..), + +) where + +import Data.Array.Accelerate as A hiding ( transpose ) +import Data.Array.Accelerate.Data.Complex + +import Data.Array.Accelerate.Linear.Lift +import Data.Array.Accelerate.Linear.Plucker +import Data.Array.Accelerate.Linear.Quaternion +import Data.Array.Accelerate.Linear.Type +import Data.Array.Accelerate.Linear.V0 +import Data.Array.Accelerate.Linear.V1 +import Data.Array.Accelerate.Linear.V2 +import Data.Array.Accelerate.Linear.V3 +import Data.Array.Accelerate.Linear.V4 +import Data.Array.Accelerate.Linear.Vector + +import Linear.Matrix ( M22, M23, M24, M32, M33, M34, M42, M43, M44 ) +import qualified Linear.Matrix as L + +import Data.Distributive +import Data.Foldable +import Data.Traversable +import Control.Applicative +import Prelude as P + + +infixl 7 !*! +-- | Matrix product. This can compute any combination of sparse and dense multiplication. +-- +-- >>> V2 (V3 1 2 3) (V3 4 5 6) !*! V3 (V2 1 2) (V2 3 4) (V2 4 5) +-- V2 (V2 19 25) (V2 43 58) +-- +-- >>> V2 (fromList [(1,2)]) (fromList [(2,3)]) !*! fromList [(1,V3 0 0 1), (2, V3 0 0 5)] +-- V2 (V3 0 0 2) (V3 0 0 15) +-- +(!*!) :: (Functor m, Foldable t, Additive t, Additive n, A.Num a, Box2 m t a, Box2 t n a, Box2 m n a) + => Exp (m (t a)) + -> Exp (t (n a)) + -> Exp (m (n a)) +f !*! g = lift (unlift' f L.!*! unlift' g) + + +infixl 6 !+! +-- | Entry-wise matrix addition. +-- +-- >>> V2 (V3 1 2 3) (V3 4 5 6) !+! V2 (V3 7 8 9) (V3 1 2 3) +-- V2 (V3 8 10 12) (V3 5 7 9) +-- +(!+!) :: (Additive m, Additive n, A.Num a, Box2 m n a) + => Exp (m (n a)) + -> Exp (m (n a)) + -> Exp (m (n a)) +f !+! g = lift (unlift' f L.!+! unlift' g) + + +infixl 6 !-! +-- | Entry-wise matrix subtraction. +-- +-- >>> V2 (V3 1 2 3) (V3 4 5 6) !-! V2 (V3 7 8 9) (V3 1 2 3) +-- V2 (V3 (-6) (-6) (-6)) (V3 3 3 3) +-- +(!-!) :: (Additive m, Additive n, A.Num a, Box2 m n a) + => Exp (m (n a)) + -> Exp (m (n a)) + -> Exp (m (n a)) +f !-! g = lift (unlift' f L.!-! unlift' g) + + +infixl 7 !* +-- | Matrix * column vector +-- +-- >>> V2 (V3 1 2 3) (V3 4 5 6) !* V3 7 8 9 +-- V2 50 122 +-- +(!*) :: (Functor m, Foldable r, Additive r, A.Num a, Box2 m r a, Box m a) + => Exp (m (r a)) + -> Exp (r a) + -> Exp (m a) +m !* v = lift (unlift' m L.!* unlift v) + + +infixl 7 *! +-- | Row vector * matrix +-- +-- >>> V2 1 2 *! V2 (V3 3 4 5) (V3 6 7 8) +-- V3 15 18 21 + +-- (*!) :: (Metric r, Additive n, Num a) => r a -> r (n a) -> n a +-- f *! g = dot f <$> distribute g +-- +(*!) :: (Foldable t, Additive f, Additive t, A.Num a, Box t a, Box f a, Box2 t f a) + => Exp (t a) + -> Exp (t (f a)) + -> Exp (f a) +f *! g = lift (unlift f L.*! unlift' g) + + +infixl 7 *!! +-- | Scalar-matrix product +-- +-- >>> 5 *!! V2 (V2 1 2) (V2 3 4) +-- V2 (V2 5 10) (V2 15 20) +-- +(*!!) :: (Functor m, Functor r, A.Num a, Box2 m r a) + => Exp a + -> Exp (m (r a)) + -> Exp (m (r a)) +s *!! m = lift (unlift s L.*!! unlift' m) + + +infixl 7 !!* +-- | Matrix-scalar product +-- +-- >>> V2 (V2 1 2) (V2 3 4) !!* 5 +-- V2 (V2 5 10) (V2 15 20) +-- +(!!*) :: (Functor m, Functor r, A.Num a, Box2 m r a) + => Exp (m (r a)) + -> Exp a + -> Exp (m (r a)) +(!!*) = flip (*!!) + + +infixl 7 !!/ +-- | Matrix-scalar division +-- +(!!/) :: (Functor m, Functor r, A.Floating a, Box2 m r a) + => Exp (m (r a)) + -> Exp a + -> Exp (m (r a)) +m !!/ s = lift (unlift' m L.!!/ unlift s) + + +-- |The identity matrix for any dimension vector. +-- +-- >>> identity :: M44 Int +-- V4 (V4 1 0 0 0) (V4 0 1 0 0) (V4 0 0 1 0) (V4 0 0 0 1) +-- +-- >>> identity :: V3 (V3 Int) +-- V3 (V3 1 0 0) (V3 0 1 0) (V3 0 0 1) +-- +identity :: forall t a. (Traversable t, Applicative t, A.Num a, Box2 t t a) => Exp (t (t a)) +identity = lift (L.identity :: t (t (Exp a))) + + +-- | 'transpose' is just an alias for 'distribute' +-- +-- > transpose (V3 (V2 1 2) (V2 3 4) (V2 5 6)) +-- V2 (V3 1 3 5) (V3 2 4 6) +-- +transpose + :: (Distributive g, Functor f, Box2 f g a, Box2 g f a) + => Exp (f (g a)) + -> Exp (g (f a)) +transpose = lift . L.transpose . unlift' + + +class L.Trace m => Trace m where + -- | Compute the trace of a matrix + trace :: (A.Num a, Box2 m m a) => Exp (m (m a)) -> Exp a + trace = lift . L.trace . unlift' + + -- | Compute the diagonal of a matrix + diagonal :: Box2 m m a => Exp (m (m a)) -> Exp (m a) + diagonal = lift . L.diagonal . unlift' + +instance Trace Complex +instance Trace V0 +instance Trace V1 +instance Trace V2 +instance Trace V3 +instance Trace V4 +instance Trace Plucker +instance Trace Quaternion + diff --git a/src/Data/Array/Accelerate/Linear/Metric.hs b/src/Data/Array/Accelerate/Linear/Metric.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/Linear/Metric.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Array.Accelerate.Linear.Metric +-- Copyright : 2014 Edward Kmett, Charles Durham, +-- 2015 Trevor L. McDonell +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : non-portable +-- +-- Free metric spaces +---------------------------------------------------------------------------- + +module Data.Array.Accelerate.Linear.Metric + where + +import Data.Array.Accelerate as A +import Data.Array.Accelerate.Linear.Type +import Data.Array.Accelerate.Linear.Epsilon +import Data.Array.Accelerate.Linear.Vector + +import qualified Linear.Metric as L + + +-- | Free and sparse inner product/metric spaces. +-- +class L.Metric f => Metric f where + + -- | Compute the inner product of two vectors or (equivalently) convert a + -- vector @f a@ into a covector @f a -> a@. + -- + -- >>> V2 1 2 `dot` V2 3 4 + -- 11 + -- + dot :: forall a. (A.Num a, Box f a) + => Exp (f a) + -> Exp (f a) + -> Exp a + dot = lift2 (L.dot :: f (Exp a) -> f (Exp a) -> Exp a) + + -- | Compute the squared norm. The name quadrance arises from Norman J. + -- Wildberger's rational trigonometry. + -- + quadrance + :: forall a. (A.Num a, Box f a) + => Exp (f a) + -> Exp a + quadrance = lift1 (L.quadrance :: f (Exp a) -> Exp a) + + -- | Compute the 'quadrance' of the difference + -- + qd :: forall a. (A.Num a, Box f a) + => Exp (f a) + -> Exp (f a) + -> Exp a + qd = lift2 (L.qd :: f (Exp a) -> f (Exp a) -> Exp a) + + -- | Compute the distance between two vectors in a metric space + -- + distance + :: forall a. (A.Floating a, Box f a) + => Exp (f a) + -> Exp (f a) + -> Exp a + distance = lift2 (L.distance :: f (Exp a) -> f (Exp a) -> Exp a) + + -- | Compute the norm of a vector in a metric space + -- + norm :: forall a. (A.Floating a, Box f a) + => Exp (f a) + -> Exp a + norm = lift1 (L.norm :: f (Exp a) -> Exp a) + + -- | Convert a non-zero vector to unit vector. + -- + signorm + :: forall a. (A.Floating a, Box f a) + => Exp (f a) + -> Exp (f a) + signorm = lift1 (L.signorm :: f (Exp a) -> f (Exp a)) + + +type IsMetric f a = (Metric f, Box f a) + + +-- | Normalize a 'Metric' functor to have unit 'norm'. This function does not +-- change the functor if its 'norm' is 0 or 1. +-- +normalize + :: (Elt (f a), A.Floating a, IsMetric f a, Epsilon a) + => Exp (f a) + -> Exp (f a) +normalize v + = nearZero l || nearZero (1-l) + ? ( v, v ^/ sqrt l ) + where + l = quadrance v + +-- | @project u v@ computes the projection of @v@ onto @u@. +-- +project + :: forall f a. (A.Floating a, IsMetric f a) + => Exp (f a) + -> Exp (f a) + -> Exp (f a) +project = lift2 (L.project :: f (Exp a) -> f (Exp a) -> f (Exp a)) + diff --git a/src/Data/Array/Accelerate/Linear/Plucker.hs b/src/Data/Array/Accelerate/Linear/Plucker.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/Linear/Plucker.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Array.Accelerate.Linear.Plucker +-- Copyright : 2014 Edward Kmett, Charles Durham, +-- 2015 Trevor L. McDonell +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : non-portable +-- +-- Plücker coordinates for lines in 3d homogeneous space. +---------------------------------------------------------------------------- + +module Data.Array.Accelerate.Linear.Plucker ( + + Plucker(..), squaredError, (><), plucker, plucker3D, + +) where + +import Data.Array.Accelerate as A +import Data.Array.Accelerate.Smart +import Data.Array.Accelerate.Product +import Data.Array.Accelerate.Array.Sugar + +import Data.Array.Accelerate.Linear.Lift +import Data.Array.Accelerate.Linear.Metric +import Data.Array.Accelerate.Linear.Vector +import Data.Array.Accelerate.Linear.V3 +import Data.Array.Accelerate.Linear.V4 + +import Data.Typeable +import Control.Lens +import Linear.Plucker ( Plucker(..) ) +import qualified Linear.Plucker as L + + +-- | Valid Plücker coordinates @p@ will have @'squaredError' p '==' 0@ +-- +-- That said, floating point makes a mockery of this claim, so you may want to +-- use 'nearZero'. +-- +squaredError :: forall a. A.Num a => Exp (Plucker a) -> Exp a +squaredError = lift1 (L.squaredError :: Plucker (Exp a) -> Exp a) + +-- | This isn't the actual metric because this bilinear form gives rise to an +-- isotropic quadratic space +-- +infixl 5 >< +(><) :: forall a. A.Num a => Exp (Plucker a) -> Exp (Plucker a) -> Exp a +(><) = lift2 ((L.><) :: Plucker (Exp a) -> Plucker (Exp a) -> Exp a) + +-- | Given a pair of points represented by homogeneous coordinates generate +-- Plücker coordinates for the line through them, directed from the second +-- towards the first. +-- +plucker :: forall a. A.Num a => Exp (V4 a) -> Exp (V4 a) -> Exp (Plucker a) +plucker = lift2 (L.plucker :: V4 (Exp a) -> V4 (Exp a) -> Plucker (Exp a)) + +-- | Given a pair of 3D points, generate Plücker coordinates for the line +-- through them, directed from the second towards the first. +-- +plucker3D :: forall a. A.Num a => Exp (V3 a) -> Exp (V3 a) -> Exp (Plucker a) +plucker3D = lift2 (L.plucker3D :: V3 (Exp a) -> V3 (Exp a) -> Plucker (Exp a)) + + +-- Instances +-- --------- + +deriving instance Typeable Plucker + +instance Metric Plucker +instance Additive Plucker + +type instance EltRepr (Plucker a) = EltRepr (a, a, a, a, a, a) + +instance Elt a => Elt (Plucker a) where + eltType _ = eltType (undefined :: (a,a,a,a,a,a)) + toElt p = case toElt p of + (x, y, z, w, u, v) -> Plucker x y z w u v + fromElt (Plucker x y z w u v) = fromElt (x, y, z, w, u, v) + +instance cst a => IsProduct cst (Plucker a) where + type ProdRepr (Plucker a) = ProdRepr (a,a,a,a,a,a) + fromProd p (Plucker x y z w u v) = fromProd p (x, y, z, w, u, v) + toProd p t = case toProd p t of + (x, y, z, w, u, v) -> Plucker x y z w u v + prod p _ = prod p (undefined :: (a,a,a,a,a,a)) + +instance (Lift Exp a, Elt (Plain a)) => Lift Exp (Plucker a) where + type Plain (Plucker a) = Plucker (Plain a) + -- lift = Exp . Tuple . F.foldl SnocTup NilTup + lift (Plucker x y z w u v) = + Exp $ Tuple $ + NilTup `SnocTup` lift x + `SnocTup` lift y + `SnocTup` lift z + `SnocTup` lift w + `SnocTup` lift u + `SnocTup` lift v + +instance Elt a => Unlift Exp (Plucker (Exp a)) where + unlift t = Plucker + (Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Prj` t) + (Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Prj` t) + (Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` t) + (Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` t) + (Exp $ SuccTupIdx ZeroTupIdx `Prj` t) + (Exp $ ZeroTupIdx `Prj` t) + +instance (Elt a, Elt b) => Each (Exp (Plucker a)) (Exp (Plucker b)) (Exp a) (Exp b) where + each = liftLens (each :: Traversal (Plucker (Exp a)) (Plucker (Exp b)) (Exp a) (Exp b)) + diff --git a/src/Data/Array/Accelerate/Linear/Quaternion.hs b/src/Data/Array/Accelerate/Linear/Quaternion.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/Linear/Quaternion.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Array.Accelerate.Linear.Quaternion +-- Copyright : 2014 Edward Kmett, Charles Durham, +-- 2015 Trevor L. McDonell +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : non-portable +-- +-- Quaternions +---------------------------------------------------------------------------- + +module Data.Array.Accelerate.Linear.Quaternion ( + + Quaternion(..), + +) where + +import Data.Array.Accelerate +import Data.Array.Accelerate.Smart +import Data.Array.Accelerate.Product +import Data.Array.Accelerate.Array.Sugar + +import Data.Array.Accelerate.Linear.Lift +import Data.Array.Accelerate.Linear.Metric +import Data.Array.Accelerate.Linear.Vector +import Data.Array.Accelerate.Linear.V3 + +import Control.Lens +import Linear.Quaternion ( Quaternion(..) ) + + +-- Instances +-- --------- + +instance Metric Quaternion +instance Additive Quaternion + +type instance EltRepr (Quaternion a) = EltRepr (a, a, a, a) + +instance Elt a => Elt (Quaternion a) where + eltType _ = eltType (undefined :: (a,a,a,a)) + toElt p = case toElt p of + (x, y, z, w) -> Quaternion x (V3 y z w) + fromElt (Quaternion x (V3 y z w)) = fromElt (x, y, z, w) + +instance cst a => IsProduct cst (Quaternion a) where + type ProdRepr (Quaternion a) = ProdRepr (a,a,a,a) + fromProd p (Quaternion x (V3 y z w)) = fromProd p (x,y,z,w) + toProd p t = case toProd p t of + (x, y, z, w) -> Quaternion x (V3 y z w) + prod p _ = prod p (undefined :: (a,a,a,a)) + +instance (Lift Exp a, Elt (Plain a)) => Lift Exp (Quaternion a) where + type Plain (Quaternion a) = Quaternion (Plain a) + --lift = Exp . Tuple . F.foldl SnocTup NilTup + lift (Quaternion x (V3 y z w)) = Exp $ Tuple $ NilTup `SnocTup` + lift x `SnocTup` + lift y `SnocTup` + lift z `SnocTup` + lift w + +instance Elt a => Unlift Exp (Quaternion (Exp a)) where + unlift t = Quaternion (Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` t) + (V3 (Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` t) + (Exp $ SuccTupIdx ZeroTupIdx `Prj` t) + (Exp $ ZeroTupIdx `Prj` t)) + +instance (Elt a, Elt b) => Each (Exp (Quaternion a)) (Exp (Quaternion b)) (Exp a) (Exp b) where + each = liftLens (each :: Traversal (Quaternion (Exp a)) (Quaternion (Exp b)) (Exp a) (Exp b)) + diff --git a/src/Data/Array/Accelerate/Linear/Type.hs b/src/Data/Array/Accelerate/Linear/Type.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/Linear/Type.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Array.Accelerate.Linear.Type +-- Copyright : 2015 Trevor L. McDonell +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : non-portable +---------------------------------------------------------------------------- + +module Data.Array.Accelerate.Linear.Type + where + +import Data.Array.Accelerate + +type Box f a = (Unlift Exp (f (Exp a)), Plain (f (Exp a)) ~ f a) +type Box2 f g a = (Box f (g a), Box g a, Lift Exp (f (g (Exp a))), Plain (f (g (Exp a))) ~ f (g a)) + +-- type IsLens' s a = IsLens s s a a +-- type IsLens s t a b = (Lift Exp t, Lift Exp a, Unlift Exp s, Unlift Exp b) + diff --git a/src/Data/Array/Accelerate/Linear/V0.hs b/src/Data/Array/Accelerate/Linear/V0.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/Linear/V0.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Array.Accelerate.Linear.V0 +-- Copyright : 2014 Edward Kmett, Charles Durham, +-- 2015 Trevor L. McDonell +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : non-portable +-- +-- 0-D Vectors +---------------------------------------------------------------------------- + +module Data.Array.Accelerate.Linear.V0 ( + + V0(..), + +) where + +import Data.Array.Accelerate as A +import Data.Array.Accelerate.Smart +import Data.Array.Accelerate.Product +import Data.Array.Accelerate.Array.Sugar + +import Data.Array.Accelerate.Linear.Metric +import Data.Array.Accelerate.Linear.Vector + +import Linear.V0 ( V0(..) ) +import Control.Lens +import Control.Applicative +import Prelude as P + + +-- Instances +-- --------- + +instance Metric V0 +instance Additive V0 + +type instance EltRepr (V0 a) = () + +instance Elt a => Elt (V0 a) where + eltType _ = eltType () + toElt () = V0 + fromElt V0 = () + +instance IsProduct cst (V0 a) where + type ProdRepr (V0 a) = () + fromProd _ V0 = () + toProd _ () = V0 + prod _ _ = ProdRunit + +instance Lift Exp (V0 a) where + type Plain (V0 a) = () + lift V0 = Exp (Tuple NilTup) + +instance Unlift Exp (V0 a) where + unlift _ = V0 + +instance A.Num a => P.Num (Exp (V0 a)) where + _ + _ = constant V0 + _ - _ = constant V0 + _ * _ = constant V0 + abs _ = constant V0 + signum _ = constant V0 + fromInteger _ = constant V0 + +instance (Elt a, Elt b) => Each (Exp (V0 a)) (Exp (V0 b)) (Exp a) (Exp b) where + each _ _ = pure (constant V0) + diff --git a/src/Data/Array/Accelerate/Linear/V1.hs b/src/Data/Array/Accelerate/Linear/V1.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/Linear/V1.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Array.Accelerate.Linear.V1 +-- Copyright : 2014 Edward Kmett, Charles Durham, +-- 2015 Trevor L. McDonell +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : non-portable +-- +-- 1-D Vectors +---------------------------------------------------------------------------- + +module Data.Array.Accelerate.Linear.V1 ( + + V1(..), R1(..), ex, + +) where + +import Data.Array.Accelerate as A +import Data.Array.Accelerate.Smart +import Data.Array.Accelerate.Product +import Data.Array.Accelerate.Array.Sugar + +import Data.Array.Accelerate.Linear.Lift +import Data.Array.Accelerate.Linear.Metric +import Data.Array.Accelerate.Linear.Type +import Data.Array.Accelerate.Linear.Vector + +import Control.Lens +import Linear.V1 ( V1(..) ) +import qualified Linear.V1 as L +import Prelude as P + + +-- | A space that has at least 1 basis vector '_x'. +-- +class L.R1 t => R1 t where + -- | + -- >>> V1 2 ^._x + -- 2 + -- + -- >>> V1 2 & _x .~ 3 + -- V1 3 + -- + _x :: (Elt a, Box t a) => Lens' (Exp (t a)) (Exp a) + _x = liftLens (L._x :: Lens' (t (Exp a)) (Exp a)) + + +ex :: R1 t => E t +ex = E _x + + +-- Instances +-- --------- + +instance Metric V1 +instance Additive V1 +instance R1 V1 + +type instance EltRepr (V1 a) = EltRepr a + +instance Elt a => Elt (V1 a) where + eltType _ = eltType (undefined :: a) + toElt = V1 . toElt + fromElt (V1 a) = fromElt a + +instance cst a => IsProduct cst (V1 a) where + type ProdRepr (V1 a) = ((), a) + fromProd _ (V1 x) = ((), x) + toProd _ ((), x) = V1 x + prod _ _ = ProdRsnoc ProdRunit + +instance (Lift Exp a, Elt (Plain a)) => Lift Exp (V1 a) where + type Plain (V1 a) = V1 (Plain a) + lift (V1 x) = Exp . Tuple $ NilTup `SnocTup` lift x + +instance Elt a => Unlift Exp (V1 (Exp a)) where + unlift t = V1 $ Exp $ ZeroTupIdx `Prj` t + +instance A.Num a => P.Num (Exp (V1 a)) where + (+) = lift2 ((+) :: V1 (Exp a) -> V1 (Exp a) -> V1 (Exp a)) + (-) = lift2 ((-) :: V1 (Exp a) -> V1 (Exp a) -> V1 (Exp a)) + (*) = lift2 ((*) :: V1 (Exp a) -> V1 (Exp a) -> V1 (Exp a)) + negate = lift1 (negate :: V1 (Exp a) -> V1 (Exp a)) + signum = lift1 (signum :: V1 (Exp a) -> V1 (Exp a)) + abs = lift1 (signum :: V1 (Exp a) -> V1 (Exp a)) + fromInteger x = lift (fromInteger x :: V1 (Exp a)) + +instance A.Floating a => P.Fractional (Exp (V1 a)) where + (/) = lift2 ((/) :: V1 (Exp a) -> V1 (Exp a) -> V1 (Exp a)) + recip = lift1 (recip :: V1 (Exp a) -> V1 (Exp a)) + fromRational x = lift (fromRational x :: V1 (Exp a)) + +instance A.Floating a => P.Floating (Exp (V1 a)) where + pi = lift (pi :: V1 (Exp a)) + log = lift1 (log :: V1 (Exp a) -> V1 (Exp a)) + exp = lift1 (exp :: V1 (Exp a) -> V1 (Exp a)) + sin = lift1 (sin :: V1 (Exp a) -> V1 (Exp a)) + cos = lift1 (cos :: V1 (Exp a) -> V1 (Exp a)) + tan = lift1 (tan :: V1 (Exp a) -> V1 (Exp a)) + sinh = lift1 (sinh :: V1 (Exp a) -> V1 (Exp a)) + cosh = lift1 (cosh :: V1 (Exp a) -> V1 (Exp a)) + tanh = lift1 (tanh :: V1 (Exp a) -> V1 (Exp a)) + asin = lift1 (asin :: V1 (Exp a) -> V1 (Exp a)) + acos = lift1 (acos :: V1 (Exp a) -> V1 (Exp a)) + atan = lift1 (atan :: V1 (Exp a) -> V1 (Exp a)) + asinh = lift1 (asinh :: V1 (Exp a) -> V1 (Exp a)) + acosh = lift1 (acosh :: V1 (Exp a) -> V1 (Exp a)) + atanh = lift1 (atanh :: V1 (Exp a) -> V1 (Exp a)) + +instance (Elt a, Elt b) => Each (Exp (V1 a)) (Exp (V1 b)) (Exp a) (Exp b) where + each = liftLens (each :: Traversal (V1 (Exp a)) (V1 (Exp b)) (Exp a) (Exp b)) + diff --git a/src/Data/Array/Accelerate/Linear/V2.hs b/src/Data/Array/Accelerate/Linear/V2.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/Linear/V2.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Array.Accelerate.Linear.V2 +-- Copyright : 2014 Edward Kmett, Charles Durham, +-- 2015 Trevor L. McDonell +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : non-portable +-- +-- 2-D Vectors +---------------------------------------------------------------------------- + +module Data.Array.Accelerate.Linear.V2 ( + + V2(..), R1(..), R2(..), + _yx, + ex, ey, + perp, angle, + +) where + +import Data.Array.Accelerate as A +import Data.Array.Accelerate.Smart +import Data.Array.Accelerate.Product +import Data.Array.Accelerate.Array.Sugar + +import Data.Array.Accelerate.Linear.Lift +import Data.Array.Accelerate.Linear.Metric +import Data.Array.Accelerate.Linear.Type +import Data.Array.Accelerate.Linear.V1 +import Data.Array.Accelerate.Linear.Vector + +import Control.Lens +import Linear.V2 ( V2(..) ) +import qualified Linear.V2 as L +import Prelude as P + + +-- | the counter-clockwise perpendicular vector +-- +-- >>> perp $ V2 10 20 +-- V2 (-20) 10 +-- +perp :: forall a. A.Num a => Exp (V2 a) -> Exp (V2 a) +perp = lift1 (L.perp :: V2 (Exp a) -> V2 (Exp a)) + + +-- | Unit vector with given phase angle (modulo 2*'pi') +-- +angle :: A.Floating a => Exp a -> Exp (V2 a) +angle = lift . L.angle + + +-- | A space that distinguishes 2 orthogonal basis vectors '_x' and '_y', but +-- may have more. +-- +class (L.R2 t, R1 t) => R2 t where + -- | + -- >>> V2 1 2 ^._y + -- 2 + -- + -- >>> V2 1 2 & _y .~ 3 + -- V2 1 3 + -- + _y :: (Elt a, Box t a) => Lens' (Exp (t a)) (Exp a) + _y = liftLens (L._y :: Lens' (t (Exp a)) (Exp a)) + + _xy :: (Elt a, Box t a) => Lens' (Exp (t a)) (Exp (V2 a)) + _xy = liftLens (L._xy :: Lens' (t (Exp a)) (V2 (Exp a))) + + +-- | +-- >>> V2 1 2 ^. _yx +-- V2 2 1 +-- +_yx :: forall t a. (R2 t, Elt a, Box t a) => Lens' (Exp (t a)) (Exp (V2 a)) +_yx = liftLens (L._yx :: Lens' (t (Exp a)) (V2 (Exp a))) + + +ey :: R2 t => E t +ey = E _y + + +-- Instances +-- --------- + +instance Metric V2 +instance Additive V2 +instance R1 V2 +instance R2 V2 + +type instance EltRepr (V2 a) = EltRepr (a, a) + +instance Elt a => Elt (V2 a) where + eltType _ = eltType (undefined :: (a,a)) + toElt p = case toElt p of + (x, y) -> V2 x y + fromElt (V2 x y) = fromElt (x, y) + +instance cst a => IsProduct cst (V2 a) where + type ProdRepr (V2 a) = ProdRepr (a,a) + fromProd p (V2 x y) = fromProd p (x,y) + toProd p t = case toProd p t of + (x, y) -> V2 x y + prod p _ = prod p (undefined :: (a,a)) + +instance (Lift Exp a, Elt (Plain a)) => Lift Exp (V2 a) where + type Plain (V2 a) = V2 (Plain a) + lift (V2 x y) = Exp $ Tuple $ NilTup `SnocTup` lift x `SnocTup` lift y + +instance Elt a => Unlift Exp (V2 (Exp a)) where + unlift t = V2 (Exp $ SuccTupIdx ZeroTupIdx `Prj` t) + (Exp $ ZeroTupIdx `Prj` t) + +instance A.Num a => P.Num (Exp (V2 a)) where + (+) = lift2 ((+) :: V2 (Exp a) -> V2 (Exp a) -> V2 (Exp a)) + (-) = lift2 ((-) :: V2 (Exp a) -> V2 (Exp a) -> V2 (Exp a)) + (*) = lift2 ((*) :: V2 (Exp a) -> V2 (Exp a) -> V2 (Exp a)) + negate = lift1 (negate :: V2 (Exp a) -> V2 (Exp a)) + signum = lift1 (signum :: V2 (Exp a) -> V2 (Exp a)) + abs = lift1 (signum :: V2 (Exp a) -> V2 (Exp a)) + fromInteger x = lift (fromInteger x :: V2 (Exp a)) + +instance A.Floating a => P.Fractional (Exp (V2 a)) where + (/) = lift2 ((/) :: V2 (Exp a) -> V2 (Exp a) -> V2 (Exp a)) + recip = lift1 (recip :: V2 (Exp a) -> V2 (Exp a)) + fromRational x = lift (fromRational x :: V2 (Exp a)) + +instance A.Floating a => P.Floating (Exp (V2 a)) where + pi = lift (pi :: V2 (Exp a)) + log = lift1 (log :: V2 (Exp a) -> V2 (Exp a)) + exp = lift1 (exp :: V2 (Exp a) -> V2 (Exp a)) + sin = lift1 (sin :: V2 (Exp a) -> V2 (Exp a)) + cos = lift1 (cos :: V2 (Exp a) -> V2 (Exp a)) + tan = lift1 (tan :: V2 (Exp a) -> V2 (Exp a)) + sinh = lift1 (sinh :: V2 (Exp a) -> V2 (Exp a)) + cosh = lift1 (cosh :: V2 (Exp a) -> V2 (Exp a)) + tanh = lift1 (tanh :: V2 (Exp a) -> V2 (Exp a)) + asin = lift1 (asin :: V2 (Exp a) -> V2 (Exp a)) + acos = lift1 (acos :: V2 (Exp a) -> V2 (Exp a)) + atan = lift1 (atan :: V2 (Exp a) -> V2 (Exp a)) + asinh = lift1 (asinh :: V2 (Exp a) -> V2 (Exp a)) + acosh = lift1 (acosh :: V2 (Exp a) -> V2 (Exp a)) + atanh = lift1 (atanh :: V2 (Exp a) -> V2 (Exp a)) + +instance (Elt a, Elt b) => Each (Exp (V2 a)) (Exp (V2 b)) (Exp a) (Exp b) where + each = liftLens (each :: Traversal (V2 (Exp a)) (V2 (Exp b)) (Exp a) (Exp b)) + diff --git a/src/Data/Array/Accelerate/Linear/V3.hs b/src/Data/Array/Accelerate/Linear/V3.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/Linear/V3.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Array.Accelerate.Linear.V3 +-- Copyright : 2014 Edward Kmett, Charles Durham, +-- 2015 Trevor L. McDonell +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : non-portable +-- +-- 3-D Vectors +---------------------------------------------------------------------------- + +module Data.Array.Accelerate.Linear.V3 ( + + V3(..), cross, triple, + R1(..), + R2(..), + _yx, + R3(..), + _xz, _yz, _zx, _zy, + _xzy, _yxz, _yzx, _zxy, _zyx, + ex, ey, ez, + +) where + +import Data.Array.Accelerate as A +import Data.Array.Accelerate.Smart +import Data.Array.Accelerate.Product +import Data.Array.Accelerate.Array.Sugar + +import Data.Array.Accelerate.Linear.Lift +import Data.Array.Accelerate.Linear.Metric +import Data.Array.Accelerate.Linear.Type +import Data.Array.Accelerate.Linear.V1 +import Data.Array.Accelerate.Linear.V2 +import Data.Array.Accelerate.Linear.Vector + +import Control.Lens +import Linear.V3 ( V3(..) ) +import qualified Linear.V3 as L +import Prelude as P + + +-- | cross product +-- +cross :: forall a. A.Num a => Exp (V3 a) -> Exp (V3 a) -> Exp (V3 a) +cross = lift2 (L.cross :: V3 (Exp a) -> V3 (Exp a) -> V3 (Exp a)) + +-- | scalar triple product +-- +triple :: forall a. A.Num a => Exp (V3 a) -> Exp (V3 a) -> Exp (V3 a) -> Exp a +triple = lift3 (L.triple :: V3 (Exp a) -> V3 (Exp a) -> V3 (Exp a) -> Exp a) + + +-- | A space that distinguishes 3 orthogonal basis vectors: '_x', '_y', and '_z'. +-- (Although it may have more) +-- +class (L.R3 t, R2 t) => R3 t where + -- | + -- >>> V3 1 2 3 ^. _z + -- 3 + -- + _z :: forall a. (Elt a, Box t a) => Lens' (Exp (t a)) (Exp a) + _z = liftLens (L._z :: Lens' (t (Exp a)) (Exp a)) + + _xyz :: forall a. (Elt a, Box t a) => Lens' (Exp (t a)) (Exp (V3 a)) + _xyz = liftLens (L._xyz :: Lens' (t (Exp a)) (V3 (Exp a))) + + +_xz, _yz, _zx, _zy :: forall t a. (R3 t, Elt a, Box t a) => Lens' (Exp (t a)) (Exp (V2 a)) +_xz = liftLens (L._xz :: Lens' (t (Exp a)) (V2 (Exp a))) +_yz = liftLens (L._yz :: Lens' (t (Exp a)) (V2 (Exp a))) +_zx = liftLens (L._zx :: Lens' (t (Exp a)) (V2 (Exp a))) +_zy = liftLens (L._zy :: Lens' (t (Exp a)) (V2 (Exp a))) + +_xzy, _yxz, _yzx, _zxy, _zyx :: forall t a. (R3 t, Elt a, Box t a) => Lens' (Exp (t a)) (Exp (V3 a)) +_xzy = liftLens (L._xzy :: Lens' (t (Exp a)) (V3 (Exp a))) +_yxz = liftLens (L._yxz :: Lens' (t (Exp a)) (V3 (Exp a))) +_yzx = liftLens (L._yzx :: Lens' (t (Exp a)) (V3 (Exp a))) +_zxy = liftLens (L._zxy :: Lens' (t (Exp a)) (V3 (Exp a))) +_zyx = liftLens (L._zyx :: Lens' (t (Exp a)) (V3 (Exp a))) + + +ez :: R3 t => E t +ez = E _z + + +-- Instances +-- --------- + +instance Metric V3 +instance Additive V3 +instance R1 V3 +instance R2 V3 +instance R3 V3 + +type instance EltRepr (V3 a) = EltRepr (a, a, a) + +instance Elt a => Elt (V3 a) where + eltType _ = eltType (undefined :: (a,a,a)) + toElt p = case toElt p of + (x, y, z) -> V3 x y z + fromElt (V3 x y z) = fromElt (x, y, z) + +instance cst a => IsProduct cst (V3 a) where + type ProdRepr (V3 a) = ProdRepr (a,a,a) + fromProd p (V3 x y z) = fromProd p (x,y,z) + toProd p t = case toProd p t of + (x, y, z) -> V3 x y z + prod p _ = prod p (undefined :: (a,a,a)) + +instance (Lift Exp a, Elt (Plain a)) => Lift Exp (V3 a) where + type Plain (V3 a) = V3 (Plain a) + lift (V3 x y z) = Exp $ Tuple $ NilTup `SnocTup` lift x `SnocTup` lift y `SnocTup` lift z + +instance Elt a => Unlift Exp (V3 (Exp a)) where + unlift t = V3 (Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` t) + (Exp $ SuccTupIdx ZeroTupIdx `Prj` t) + (Exp $ ZeroTupIdx `Prj` t) + +instance A.Num a => P.Num (Exp (V3 a)) where + (+) = lift2 ((+) :: V3 (Exp a) -> V3 (Exp a) -> V3 (Exp a)) + (-) = lift2 ((-) :: V3 (Exp a) -> V3 (Exp a) -> V3 (Exp a)) + (*) = lift2 ((*) :: V3 (Exp a) -> V3 (Exp a) -> V3 (Exp a)) + negate = lift1 (negate :: V3 (Exp a) -> V3 (Exp a)) + signum = lift1 (signum :: V3 (Exp a) -> V3 (Exp a)) + abs = lift1 (signum :: V3 (Exp a) -> V3 (Exp a)) + fromInteger x = lift (fromInteger x :: V3 (Exp a)) + +instance A.Floating a => P.Fractional (Exp (V3 a)) where + (/) = lift2 ((/) :: V3 (Exp a) -> V3 (Exp a) -> V3 (Exp a)) + recip = lift1 (recip :: V3 (Exp a) -> V3 (Exp a)) + fromRational x = lift (fromRational x :: V3 (Exp a)) + +instance A.Floating a => P.Floating (Exp (V3 a)) where + pi = lift (pi :: V3 (Exp a)) + log = lift1 (log :: V3 (Exp a) -> V3 (Exp a)) + exp = lift1 (exp :: V3 (Exp a) -> V3 (Exp a)) + sin = lift1 (sin :: V3 (Exp a) -> V3 (Exp a)) + cos = lift1 (cos :: V3 (Exp a) -> V3 (Exp a)) + tan = lift1 (tan :: V3 (Exp a) -> V3 (Exp a)) + sinh = lift1 (sinh :: V3 (Exp a) -> V3 (Exp a)) + cosh = lift1 (cosh :: V3 (Exp a) -> V3 (Exp a)) + tanh = lift1 (tanh :: V3 (Exp a) -> V3 (Exp a)) + asin = lift1 (asin :: V3 (Exp a) -> V3 (Exp a)) + acos = lift1 (acos :: V3 (Exp a) -> V3 (Exp a)) + atan = lift1 (atan :: V3 (Exp a) -> V3 (Exp a)) + asinh = lift1 (asinh :: V3 (Exp a) -> V3 (Exp a)) + acosh = lift1 (acosh :: V3 (Exp a) -> V3 (Exp a)) + atanh = lift1 (atanh :: V3 (Exp a) -> V3 (Exp a)) + +instance (Elt a, Elt b) => Each (Exp (V3 a)) (Exp (V3 b)) (Exp a) (Exp b) where + each = liftLens (each :: Traversal (V3 (Exp a)) (V3 (Exp b)) (Exp a) (Exp b)) + +-- $liftAcc +-- +-- In theory we could support lifting these to 'Acc' array types as well, however +-- since the class associated type for that ignores one of its arguments, this requires +-- +-- @ +-- type 'Plain' ('V3' a) = 'Vector' a +-- @ +-- +-- while in order to instantiate the @'Lift' 'Exp` (V3 a)@ above we need +-- +-- @ +-- type 'Plain' ('V3' a) = V3 ('Plain' a) +-- @ +-- +-- so due to limitations in the accelerate API, we can't support both! +{-- +type instance ArrRepr (V3 a) = ArrRepr (Vector a) + +instance Elt a => Arrays (V3 a) where + arrays _ = arrays (undefined :: Vector a) + toArr arr = case toList arr of + [a,b,c] -> V3 a b c + _ -> error "shape mismatch" + fromArr = fromList (Z :. 3) . F.toList + flavour _ = error "https://github.com/AccelerateHS/accelerate/issues/263" + +instance Elt a => Lift Acc (V3 a) where + type Plain (V3 a) = Vector a + lift = lift . toArr' +--} + diff --git a/src/Data/Array/Accelerate/Linear/V4.hs b/src/Data/Array/Accelerate/Linear/V4.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/Linear/V4.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Array.Accelerate.Linear.V4 +-- Copyright : 2014 Edward Kmett, Charles Durham, +-- 2015 Trevor L. McDonell +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : non-portable +-- +-- 4-D Vectors +---------------------------------------------------------------------------- + +module Data.Array.Accelerate.Linear.V4 ( + + V4(..), vector, point, normalizePoint, + R1(..), + R2(..), + _yx, + R3(..), + _xz, _yz, _zx, _zy, + _xzy, _yxz, _yzx, _zxy, _zyx, + R4(..), + _xw, _yw, _zw, _wx, _wy, _wz, + _xyw, _xzw, _xwy, _xwz, _yxw, _yzw, _ywx, _ywz, _zxw, _zyw, _zwx, _zwy, + _wxy, _wxz, _wyx, _wyz, _wzx, _wzy, + _xywz, _xzyw, _xzwy, _xwyz, _xwzy, _yxzw , _yxwz, _yzxw, _yzwx, _ywxz, + _ywzx, _zxyw, _zxwy, _zyxw, _zywx, _zwxy, _zwyx, _wxyz, _wxzy, _wyxz, + _wyzx, _wzxy, _wzyx, + ex, ey, ez, ew, + +) where + +import Data.Array.Accelerate as A +import Data.Array.Accelerate.Smart +import Data.Array.Accelerate.Product +import Data.Array.Accelerate.Array.Sugar + +import Data.Array.Accelerate.Linear.Lift +import Data.Array.Accelerate.Linear.Metric +import Data.Array.Accelerate.Linear.Type +import Data.Array.Accelerate.Linear.V1 +import Data.Array.Accelerate.Linear.V2 +import Data.Array.Accelerate.Linear.V3 +import Data.Array.Accelerate.Linear.Vector + +import Control.Lens +import Linear.V4 ( V4(..) ) +import qualified Linear.V4 as L +import Prelude as P + + +-- | Convert a 3-dimensional affine vector into a 4-dimensional homogeneous +-- vector. +-- +vector :: forall a. A.Num a => Exp (V3 a) -> Exp (V4 a) +vector = lift1 (L.vector :: V3 (Exp a) -> V4 (Exp a)) + +-- | Convert a 3-dimensional affine point into a 4-dimensional homogeneous +-- vector. +-- +point :: forall a. A.Num a => Exp (V3 a) -> Exp (V4 a) +point = lift1 (L.point :: V3 (Exp a) -> V4 (Exp a)) + +-- | Convert 4-dimensional projective coordinates to a 3-dimensional point. This +-- operation may be denoted, @euclidean [x:y:z:w] = (x\/w, y\/w, z\/w)@ where +-- the projective, homogenous, coordinate @[x:y:z:w]@ is one of many associated +-- with a single point @(x\/w, y\/w, z\/w)@. +-- +normalizePoint :: forall a. A.Floating a => Exp (V4 a) -> Exp (V3 a) +normalizePoint = lift1 (L.normalizePoint :: V4 (Exp a) -> V3 (Exp a)) + +-- | A space that distinguishes orthogonal basis vectors '_x', '_y', '_z', and '_w'. +-- (Although it may have more.) +-- +class (L.R4 t, R3 t) => R4 t where + -- | + -- >>> V4 1 2 3 4 ^._w + -- 4 + -- + _w :: forall a. (Elt a, Box t a) => Lens' (Exp (t a)) (Exp a) + _w = liftLens (L._w :: Lens' (t (Exp a)) (Exp a)) + + _xyzw :: forall a. (Elt a, Box t a) => Lens' (Exp (t a)) (Exp (V4 a)) + _xyzw = liftLens (L._xyzw :: Lens' (t (Exp a)) (V4 (Exp a))) + + +_xw, _yw, _zw, _wx, _wy, _wz + :: forall t a. (R4 t, Elt a, Box t a) + => Lens' (Exp (t a)) (Exp (V2 a)) +_xw = liftLens (L._xw :: Lens' (t (Exp a)) (V2 (Exp a))) +_yw = liftLens (L._yw :: Lens' (t (Exp a)) (V2 (Exp a))) +_zw = liftLens (L._zw :: Lens' (t (Exp a)) (V2 (Exp a))) +_wx = liftLens (L._wx :: Lens' (t (Exp a)) (V2 (Exp a))) +_wy = liftLens (L._wy :: Lens' (t (Exp a)) (V2 (Exp a))) +_wz = liftLens (L._wz :: Lens' (t (Exp a)) (V2 (Exp a))) + +_xyw, _xzw, _xwy, _xwz, _yxw, _yzw, _ywx, _ywz, _zxw, _zyw, _zwx, _zwy, _wxy, _wxz, _wyx, _wyz, _wzx, _wzy + :: forall t a. (R4 t, Elt a, Box t a) + => Lens' (Exp (t a)) (Exp (V3 a)) +_xyw = liftLens (L._xyw :: Lens' (t (Exp a)) (V3 (Exp a))) +_xzw = liftLens (L._xzw :: Lens' (t (Exp a)) (V3 (Exp a))) +_xwy = liftLens (L._xwy :: Lens' (t (Exp a)) (V3 (Exp a))) +_xwz = liftLens (L._xwz :: Lens' (t (Exp a)) (V3 (Exp a))) +_yxw = liftLens (L._yxw :: Lens' (t (Exp a)) (V3 (Exp a))) +_yzw = liftLens (L._yzw :: Lens' (t (Exp a)) (V3 (Exp a))) +_ywx = liftLens (L._ywx :: Lens' (t (Exp a)) (V3 (Exp a))) +_ywz = liftLens (L._ywz :: Lens' (t (Exp a)) (V3 (Exp a))) +_zxw = liftLens (L._zxw :: Lens' (t (Exp a)) (V3 (Exp a))) +_zyw = liftLens (L._zyw :: Lens' (t (Exp a)) (V3 (Exp a))) +_zwx = liftLens (L._zwx :: Lens' (t (Exp a)) (V3 (Exp a))) +_zwy = liftLens (L._zwy :: Lens' (t (Exp a)) (V3 (Exp a))) +_wxy = liftLens (L._wxy :: Lens' (t (Exp a)) (V3 (Exp a))) +_wxz = liftLens (L._wxz :: Lens' (t (Exp a)) (V3 (Exp a))) +_wyx = liftLens (L._wyx :: Lens' (t (Exp a)) (V3 (Exp a))) +_wyz = liftLens (L._wyz :: Lens' (t (Exp a)) (V3 (Exp a))) +_wzx = liftLens (L._wzx :: Lens' (t (Exp a)) (V3 (Exp a))) +_wzy = liftLens (L._wzy :: Lens' (t (Exp a)) (V3 (Exp a))) + +_xywz, _xzyw, _xzwy, _xwyz, _xwzy, _yxzw , _yxwz, _yzxw, _yzwx, _ywxz , _ywzx, _zxyw, + _zxwy, _zyxw, _zywx, _zwxy, _zwyx, _wxyz, _wxzy, _wyxz, _wyzx, _wzxy, _wzyx + :: forall t a. (R4 t, Elt a, Box t a) + => Lens' (Exp (t a)) (Exp (V4 a)) +_xywz = liftLens (L._xywz :: Lens' (t (Exp a)) (V4 (Exp a))) +_xzyw = liftLens (L._xzyw :: Lens' (t (Exp a)) (V4 (Exp a))) +_xzwy = liftLens (L._xzwy :: Lens' (t (Exp a)) (V4 (Exp a))) +_xwyz = liftLens (L._xwyz :: Lens' (t (Exp a)) (V4 (Exp a))) +_xwzy = liftLens (L._xwzy :: Lens' (t (Exp a)) (V4 (Exp a))) +_yxzw = liftLens (L._yxzw :: Lens' (t (Exp a)) (V4 (Exp a))) +_yxwz = liftLens (L._yxwz :: Lens' (t (Exp a)) (V4 (Exp a))) +_yzxw = liftLens (L._yzxw :: Lens' (t (Exp a)) (V4 (Exp a))) +_yzwx = liftLens (L._yzwx :: Lens' (t (Exp a)) (V4 (Exp a))) +_ywxz = liftLens (L._ywxz :: Lens' (t (Exp a)) (V4 (Exp a))) +_ywzx = liftLens (L._ywzx :: Lens' (t (Exp a)) (V4 (Exp a))) +_zxyw = liftLens (L._zxyw :: Lens' (t (Exp a)) (V4 (Exp a))) +_zxwy = liftLens (L._zxwy :: Lens' (t (Exp a)) (V4 (Exp a))) +_zyxw = liftLens (L._zyxw :: Lens' (t (Exp a)) (V4 (Exp a))) +_zywx = liftLens (L._zywx :: Lens' (t (Exp a)) (V4 (Exp a))) +_zwxy = liftLens (L._zwxy :: Lens' (t (Exp a)) (V4 (Exp a))) +_zwyx = liftLens (L._zwyx :: Lens' (t (Exp a)) (V4 (Exp a))) +_wxyz = liftLens (L._wxyz :: Lens' (t (Exp a)) (V4 (Exp a))) +_wxzy = liftLens (L._wxzy :: Lens' (t (Exp a)) (V4 (Exp a))) +_wyxz = liftLens (L._wyxz :: Lens' (t (Exp a)) (V4 (Exp a))) +_wyzx = liftLens (L._wyzx :: Lens' (t (Exp a)) (V4 (Exp a))) +_wzxy = liftLens (L._wzxy :: Lens' (t (Exp a)) (V4 (Exp a))) +_wzyx = liftLens (L._wzyx :: Lens' (t (Exp a)) (V4 (Exp a))) + + +ew :: R4 t => E t +ew = E _w + + +-- Instances +-- --------- + +instance Metric V4 +instance Additive V4 +instance R1 V4 +instance R2 V4 +instance R3 V4 +instance R4 V4 + +type instance EltRepr (V4 a) = EltRepr (a, a, a, a) + +instance Elt a => Elt (V4 a) where + eltType _ = eltType (undefined :: (a,a,a,a)) + toElt p = case toElt p of + (x, y, z, w) -> V4 x y z w + fromElt (V4 x y z w) = fromElt (x, y, z, w) + +instance cst a => IsProduct cst (V4 a) where + type ProdRepr (V4 a) = ProdRepr (a,a,a,a) + fromProd p (V4 x y z w) = fromProd p (x,y,z,w) + toProd p t = case toProd p t of + (x, y, z, w) -> V4 x y z w + prod p _ = prod p (undefined :: (a,a,a,a)) + +instance (Lift Exp a, Elt (Plain a)) => Lift Exp (V4 a) where + type Plain (V4 a) = V4 (Plain a) + lift (V4 x y z w) = + Exp $ Tuple $ NilTup `SnocTup` lift x + `SnocTup` lift y + `SnocTup` lift z + `SnocTup` lift w + +instance Elt a => Unlift Exp (V4 (Exp a)) where + unlift t = V4 (Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` t) + (Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` t) + (Exp $ SuccTupIdx ZeroTupIdx `Prj` t) + (Exp $ ZeroTupIdx `Prj` t) + +instance A.Num a => P.Num (Exp (V4 a)) where + (+) = lift2 ((+) :: V4 (Exp a) -> V4 (Exp a) -> V4 (Exp a)) + (-) = lift2 ((-) :: V4 (Exp a) -> V4 (Exp a) -> V4 (Exp a)) + (*) = lift2 ((*) :: V4 (Exp a) -> V4 (Exp a) -> V4 (Exp a)) + negate = lift1 (negate :: V4 (Exp a) -> V4 (Exp a)) + signum = lift1 (signum :: V4 (Exp a) -> V4 (Exp a)) + abs = lift1 (signum :: V4 (Exp a) -> V4 (Exp a)) + fromInteger x = lift (fromInteger x :: V4 (Exp a)) + +instance A.Floating a => P.Fractional (Exp (V4 a)) where + (/) = lift2 ((/) :: V4 (Exp a) -> V4 (Exp a) -> V4 (Exp a)) + recip = lift1 (recip :: V4 (Exp a) -> V4 (Exp a)) + fromRational x = lift (fromRational x :: V4 (Exp a)) + +instance A.Floating a => P.Floating (Exp (V4 a)) where + pi = lift (pi :: V4 (Exp a)) + log = lift1 (log :: V4 (Exp a) -> V4 (Exp a)) + exp = lift1 (exp :: V4 (Exp a) -> V4 (Exp a)) + sin = lift1 (sin :: V4 (Exp a) -> V4 (Exp a)) + cos = lift1 (cos :: V4 (Exp a) -> V4 (Exp a)) + tan = lift1 (tan :: V4 (Exp a) -> V4 (Exp a)) + sinh = lift1 (sinh :: V4 (Exp a) -> V4 (Exp a)) + cosh = lift1 (cosh :: V4 (Exp a) -> V4 (Exp a)) + tanh = lift1 (tanh :: V4 (Exp a) -> V4 (Exp a)) + asin = lift1 (asin :: V4 (Exp a) -> V4 (Exp a)) + acos = lift1 (acos :: V4 (Exp a) -> V4 (Exp a)) + atan = lift1 (atan :: V4 (Exp a) -> V4 (Exp a)) + asinh = lift1 (asinh :: V4 (Exp a) -> V4 (Exp a)) + acosh = lift1 (acosh :: V4 (Exp a) -> V4 (Exp a)) + atanh = lift1 (atanh :: V4 (Exp a) -> V4 (Exp a)) + +instance (Elt a, Elt b) => Each (Exp (V4 a)) (Exp (V4 b)) (Exp a) (Exp b) where + each = liftLens (each :: Traversal (V4 (Exp a)) (V4 (Exp b)) (Exp a) (Exp b)) + diff --git a/src/Data/Array/Accelerate/Linear/Vector.hs b/src/Data/Array/Accelerate/Linear/Vector.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/Linear/Vector.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Array.Accelerate.Linear.Vector +-- Copyright : 2014 Edward Kmett, Charles Durham, +-- 2015 Trevor L. McDonell +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : non-portable +-- +-- Operations on free vector spaces +---------------------------------------------------------------------------- + +module Data.Array.Accelerate.Linear.Vector + where + +import Data.Array.Accelerate as A +import Data.Array.Accelerate.Linear.Type + +import Control.Lens +import Prelude as P +import qualified Linear.Vector as L + +infixl 6 ^+^, ^+, +^, ^-^, ^-, -^ +infixl 7 ^*, *^, ^/, /^ + +-- | A vector is an additive group with additional structure. +-- +-- TODO: Support both 'Exp' and 'Acc' +-- +class L.Additive f => Additive f where + + -- | The zero vector + -- + zero :: (Elt (f a), P.Num a) => Exp (f a) + zero = constant (L.zero) + + -- | Compute the sum of two vectors + -- + -- >>> V2 1 2 ^+^ V2 3 4 + -- V2 4 6 + -- + (^+^) :: forall a. (A.Num a, Box f a) + => Exp (f a) + -> Exp (f a) + -> Exp (f a) + (^+^) = lift2 ((L.^+^) :: f (Exp a) -> f (Exp a) -> f (Exp a)) + + -- | Compute the difference between two vectors + -- + -- >>> V2 4 5 - V2 3 1 + -- V2 1 4 + -- + (^-^) :: forall a. (A.Num a, Box f a) + => Exp (f a) + -> Exp (f a) + -> Exp (f a) + (^-^) = lift2 ((L.^-^) :: f (Exp a) -> f (Exp a) -> f (Exp a)) + + -- | Linearly interpolate between two vectors + -- + lerp :: forall a. (A.Num a, Box f a) + => Exp a + -> Exp (f a) + -> Exp (f a) + -> Exp (f a) + lerp = lift3 (L.lerp :: Exp a -> f (Exp a) -> f (Exp a) -> f (Exp a)) + + +type IsAdditive f a = (Additive f, Box f a) + + +-- | Basis element +-- +newtype E t = E { + el :: forall a. (Elt a, Box t a) => Lens' (Exp (t a)) (Exp a) + } + + +-- | Compute the negation of a vector +-- +-- >>> negated (V2 2 4) +-- V2 (-2) (-4) +-- +negated + :: forall f a. (Functor f, A.Num a, Box f a) + => Exp (f a) + -> Exp (f a) +negated = lift1 (L.negated :: f (Exp a) -> f (Exp a)) + +-- | Compute the left scalar product +-- +-- >>> 2 *^ V2 3 4 +-- V2 6 8 +-- +(*^) :: forall f a. (Functor f, A.Num a, Box f a) + => Exp a + -> Exp (f a) + -> Exp (f a) +(*^) = lift2 ((L.*^) :: Exp a -> f (Exp a) -> f (Exp a)) + +-- | Compute the right scalar product +-- +-- >>> V2 3 4 ^* 2 +-- V2 6 8 +-- +(^*) :: forall f a. (Functor f, A.Num a, Box f a) + => Exp (f a) + -> Exp a + -> Exp (f a) +(^*) = lift2 ((L.^*) :: f (Exp a) -> Exp a -> f (Exp a)) + +-- | Compute division by a scalar on the right +-- +-- V2 4 6 ^/ 2 +-- V2 2 3 +-- +(^/) :: forall f a. (Functor f, A.Fractional a, Box f a) + => Exp (f a) + -> Exp a + -> Exp (f a) +(^/) = lift2 ((L.^/) :: f (Exp a) -> Exp a -> f (Exp a)) + +-- | Compute division of a scalar on the left +-- +-- >>> 4 /^ V2 2 4 +-- V2 2 1 +-- +(/^) :: forall f a. (Functor f, A.Fractional a, Box f a) + => Exp a + -> Exp (f a) + -> Exp (f a) +(/^) = lift2 ((\a f -> fmap (a/) f) :: Exp a -> f (Exp a) -> f (Exp a)) + +-- | Addition with a scalar on the left +-- +-- >>> 2 +^ V2 3 4 +-- V2 5 4 +-- +(+^) :: forall f a. (Functor f, A.Num a, Box f a) + => Exp a + -> Exp (f a) + -> Exp (f a) +(+^) = lift2 ((\a f -> fmap (+a) f) :: Exp a -> f (Exp a) -> f (Exp a)) + +-- | Addition with a scalar on the right +-- +-- >>> V2 1 2 ^+ 3 +-- V2 4 3 +-- +(^+) :: forall f a. (Functor f, A.Num a, Box f a) + => Exp (f a) + -> Exp a + -> Exp (f a) +(^+) = lift2 ((\f a -> fmap (a+) f) :: f (Exp a) -> Exp a -> f (Exp a)) + +-- | Subtraction with a scalar on the left +-- +-- >>> 2 -^ V2 3 4 +-- V2 1 2 +-- +(-^) :: forall f a. (Functor f, A.Num a, Box f a) + => Exp a + -> Exp (f a) + -> Exp (f a) +(-^) = lift2 ((\a f -> fmap (A.subtract a) f) :: Exp a -> f (Exp a) -> f (Exp a)) + +-- | Subtraction with a scalar on the right +-- +-- >>> V2 1 2 ^- 3 +-- V2 (-2) (-1) +-- +(^-) :: forall f a. (Functor f, A.Num a, Box f a) + => Exp (f a) + -> Exp a + -> Exp (f a) +(^-) = lift2 ((\f a -> fmap (a-) f) :: f (Exp a) -> Exp a -> f (Exp a)) + diff --git a/src/Linear/Accelerate.hs b/src/Linear/Accelerate.hs deleted file mode 100644 --- a/src/Linear/Accelerate.hs +++ /dev/null @@ -1,294 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Linear.Accelerate () where - -import Data.Array.Accelerate -import Data.Array.Accelerate.Smart -import Data.Array.Accelerate.Tuple -import Data.Array.Accelerate.Array.Sugar -import Data.Array.Accelerate.Data.Complex () -import qualified Data.Foldable as F -import Linear ---import Linear.Plucker (Plucker(..)) - --------------------------------------------------------------------------------- --- * V0 --------------------------------------------------------------------------------- - -type instance EltRepr (V0 a) = () -type instance EltRepr' (V0 a) = () - -instance Elt a => Elt (V0 a) where - eltType _ = eltType () - toElt () = V0 - fromElt V0 = () - - eltType' _ = eltType' () - toElt' () = V0 - fromElt' V0 = () - -instance IsTuple (V0 a) where - type TupleRepr (V0 a) = () - fromTuple V0 = () - toTuple () = V0 - -instance Lift Exp (V0 a) where - type Plain (V0 a) = () - lift V0 = Exp (Tuple NilTup) - -instance Unlift Exp (V0 a) where - unlift _ = V0 - --------------------------------------------------------------------------------- --- * V1 --------------------------------------------------------------------------------- - -type instance EltRepr (V1 a) = EltRepr a -type instance EltRepr' (V1 a) = EltRepr' a - -instance Elt a => Elt (V1 a) where - eltType _ = eltType (undefined :: a) - toElt = V1 . toElt - fromElt (V1 a) = fromElt a - - eltType' _ = eltType' (undefined :: a) - toElt' = V1 . toElt' - fromElt' (V1 a) = fromElt' a - -instance IsTuple (V1 a) where - type TupleRepr (V1 a) = ((), a) - fromTuple (V1 x) = ((), x) - toTuple ((), x) = V1 x - -instance (Lift Exp a, Elt (Plain a)) => Lift Exp (V1 a) where - type Plain (V1 a) = V1 (Plain a) - lift (V1 x) = Exp . Tuple $ NilTup `SnocTup` lift x - -instance (Elt a, e ~ Exp a) => Unlift Exp (V1 e) where - unlift t = V1 $ Exp $ ZeroTupIdx `Prj` t - --------------------------------------------------------------------------------- --- * V2 --------------------------------------------------------------------------------- - -type instance EltRepr (V2 a) = EltRepr (a, a) -type instance EltRepr' (V2 a) = EltRepr' (a, a) - -instance Elt a => Elt (V2 a) where - eltType _ = eltType (undefined :: (a,a)) - toElt p = case toElt p of - (x, y) -> V2 x y - fromElt (V2 x y) = fromElt (x, y) - - eltType' _ = eltType' (undefined :: (a,a)) - toElt' p = case toElt' p of - (x, y) -> V2 x y - fromElt' (V2 x y) = fromElt' (x, y) - -instance IsTuple (V2 a) where - type TupleRepr (V2 a) = TupleRepr (a,a) - fromTuple (V2 x y) = fromTuple (x,y) - toTuple t = case toTuple t of - (x, y) -> V2 x y - -instance (Lift Exp a, Elt (Plain a)) => Lift Exp (V2 a) where - type Plain (V2 a) = V2 (Plain a) - --lift = Exp . Tuple . F.foldl SnocTup NilTup - lift (V2 x y) = Exp $ Tuple $ NilTup `SnocTup` lift x `SnocTup` lift y - -instance (Elt a, e ~ Exp a) => Unlift Exp (V2 e) where - unlift t = V2 (Exp $ SuccTupIdx ZeroTupIdx `Prj` t) - (Exp $ ZeroTupIdx `Prj` t) - --------------------------------------------------------------------------------- --- * V3 --------------------------------------------------------------------------------- - -type instance EltRepr (V3 a) = EltRepr (a, a, a) -type instance EltRepr' (V3 a) = EltRepr' (a, a, a) - -instance Elt a => Elt (V3 a) where - eltType _ = eltType (undefined :: (a,a,a)) - toElt p = case toElt p of - (x, y, z) -> V3 x y z - fromElt (V3 x y z) = fromElt (x, y, z) - - eltType' _ = eltType' (undefined :: (a,a,a)) - toElt' p = case toElt' p of - (x, y, z) -> V3 x y z - fromElt' (V3 x y z) = fromElt' (x, y, z) - -instance IsTuple (V3 a) where - type TupleRepr (V3 a) = TupleRepr (a,a,a) - fromTuple (V3 x y z) = fromTuple (x,y,z) - toTuple t = case toTuple t of - (x, y, z) -> V3 x y z - -instance (Lift Exp a, Elt (Plain a)) => Lift Exp (V3 a) where - type Plain (V3 a) = V3 (Plain a) - --lift = Exp . Tuple . F.foldl SnocTup NilTup - lift (V3 x y z) = Exp $ Tuple $ NilTup `SnocTup` lift x `SnocTup` lift y `SnocTup` lift z - -instance (Elt a, e ~ Exp a) => Unlift Exp (V3 e) where - unlift t = V3 (Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` t) - (Exp $ SuccTupIdx ZeroTupIdx `Prj` t) - (Exp $ ZeroTupIdx `Prj` t) - -type instance ArrRepr (V3 a) = ArrRepr (Vector a) -type instance ArrRepr' (V3 a) = ArrRepr' (Vector a) - -instance Elt a => Arrays (V3 a) where - arrays _ = arrays (undefined :: Vector a) - toArr ((), arr) = toArr' arr - fromArr = (,) () . fromArr' - - arrays' _ = arrays' (undefined :: Vector a) - toArr' arr = case toList arr of - [a,b,c] -> V3 a b c - _ -> error "shape mismatch" - fromArr' = fromList (Z :. 3) . F.toList - --- $liftAcc --- --- In theory we could support lifting these to 'Acc' array types as well, however --- since the class associated type for that ignores one of its arguments, this requires --- --- @ --- type 'Plain' ('V3' a) = 'Vector' a --- @ --- --- while in order to instantiate the @'Lift' 'Exp` (V3 a)@ above we need --- --- @ --- type 'Plain' ('V3' a) = V3 ('Plain' a) --- @ --- --- so due to limitations in the accelerate API, we can't support both! - -{- -instance Elt a => Lift Acc (V3 a) where - type Plain (V3 a) = Vector a - lift = lift . toArr' --} - --------------------------------------------------------------------------------- --- * V4 --------------------------------------------------------------------------------- - -type instance EltRepr (V4 a) = EltRepr (a, a, a, a) -type instance EltRepr' (V4 a) = EltRepr' (a, a, a, a) - -instance Elt a => Elt (V4 a) where - eltType _ = eltType (undefined :: (a,a,a,a)) - toElt p = case toElt p of - (x, y, z, w) -> V4 x y z w - fromElt (V4 x y z w) = fromElt (x, y, z, w) - - eltType' _ = eltType' (undefined :: (a,a,a,a)) - toElt' p = case toElt' p of - (x, y, z, w) -> V4 x y z w - fromElt' (V4 x y z w) = fromElt' (x, y, z, w) - -instance IsTuple (V4 a) where - type TupleRepr (V4 a) = TupleRepr (a,a,a,a) - fromTuple (V4 x y z w) = fromTuple (x,y,z,w) - toTuple t = case toTuple t of - (x, y, z, w) -> V4 x y z w - -instance (Lift Exp a, Elt (Plain a)) => Lift Exp (V4 a) where - type Plain (V4 a) = V4 (Plain a) - -- lift = Exp . Tuple . F.foldl SnocTup NilTup - lift (V4 x y z w) = Exp $ Tuple $ NilTup `SnocTup` - lift x `SnocTup` - lift y `SnocTup` - lift z `SnocTup` - lift w - -instance (Elt a, e ~ Exp a) => Unlift Exp (V4 e) where - unlift t = V4 (Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` t) - (Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` t) - (Exp $ SuccTupIdx ZeroTupIdx `Prj` t) - (Exp $ ZeroTupIdx `Prj` t) - --------------------------------------------------------------------------------- --- * Quaternion --------------------------------------------------------------------------------- - -type instance EltRepr (Quaternion a) = EltRepr (a, a, a, a) -type instance EltRepr' (Quaternion a) = EltRepr' (a, a, a, a) - -instance Elt a => Elt (Quaternion a) where - eltType _ = eltType (undefined :: (a,a,a,a)) - toElt p = case toElt p of - (x, y, z, w) -> Quaternion x (V3 y z w) - fromElt (Quaternion x (V3 y z w)) = fromElt (x, y, z, w) - - eltType' _ = eltType' (undefined :: (a,a,a,a)) - toElt' p = case toElt' p of - (x, y, z, w) -> Quaternion x (V3 y z w) - fromElt' (Quaternion x (V3 y z w)) = fromElt' (x, y, z, w) - -instance IsTuple (Quaternion a) where - type TupleRepr (Quaternion a) = TupleRepr (a,a,a,a) - fromTuple (Quaternion x (V3 y z w)) = fromTuple (x,y,z,w) - toTuple t = case toTuple t of - (x, y, z, w) -> Quaternion x (V3 y z w) - -instance (Lift Exp a, Elt (Plain a)) => Lift Exp (Quaternion a) where - type Plain (Quaternion a) = Quaternion (Plain a) - --lift = Exp . Tuple . F.foldl SnocTup NilTup - lift (Quaternion x (V3 y z w)) = Exp $ Tuple $ NilTup `SnocTup` - lift x `SnocTup` - lift y `SnocTup` - lift z `SnocTup` - lift w - -instance (Elt a, e ~ Exp a) => Unlift Exp (Quaternion e) where - unlift t = Quaternion (Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` t) - (V3 (Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` t) - (Exp $ SuccTupIdx ZeroTupIdx `Prj` t) - (Exp $ ZeroTupIdx `Prj` t)) - --------------------------------------------------------------------------------- --- * Plücker --------------------------------------------------------------------------------- -{- -type instance EltRepr (Plucker a) = EltRepr (a, a, a, a, a, a) -type instance EltRepr' (Plucker a) = EltRepr' (a, a, a, a, a, a) - -instance Elt a => Elt (Plucker a) where - eltType _ = eltType (undefined :: (a,a,a,a,a,a)) - toElt p = case toElt p of - (x, y, z, w, u, v) -> Plucker x y z w u v - fromElt (Plucker x y z w u v) = fromElt (x, y, z, w, u, v) - - eltType' _ = eltType' (undefined :: (a,a,a,a,a,a)) - toElt' p = case toElt' p of - (x, y, z, w, u, v) -> Plucker x y z w u v - fromElt' (Plucker x y z w u v) = fromElt' (x, y, z, w, u, v) - -instance IsTuple (Plucker a) where - type TupleRepr (Plucker a) = TupleRepr (a,a,a,a) - fromTuple (Plucker x y z w u v) = fromTuple (x, y, z, w, u, v) - toTuple t = case toTuple t of - (x, y, z, w, u, v) -> Plucker x y z w u v - -instance (Lift Exp a, Elt (Plain a)) => Lift Exp (Plucker a) where - type Plain (Plucker a) = Plucker (Plain a) - lift = Exp . Tuple . F.foldl SnocTup NilTup - -instance (Elt a, e ~ Exp a) => Unlift Exp (Plucker e) where - unlift t = Plucker - (Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Prj` t) - (Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Prj` t) - (Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` t) - (Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` t) - (Exp $ SuccTupIdx ZeroTupIdx `Prj` t) - (Exp $ ZeroTupIdx `Prj` t) --} diff --git a/travis/config b/travis/config deleted file mode 100644 --- a/travis/config +++ /dev/null @@ -1,16 +0,0 @@ --- This provides a custom ~/.cabal/config file for use when hackage is down that should work on unix --- --- This is particularly useful for travis-ci to get it to stop complaining --- about a broken build when everything is still correct on our end. --- --- This uses Luite Stegeman's mirror of hackage provided by his 'hdiff' site instead --- --- To enable this, uncomment the before_script in .travis.yml - -remote-repo: hdiff.luite.com:http://hdiff.luite.com/packages/archive -remote-repo-cache: ~/.cabal/packages -world-file: ~/.cabal/world -build-summary: ~/.cabal/logs/build.log -remote-build-reporting: anonymous -install-dirs user -install-dirs global