Vector3.hs

{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts
           , UndecidableInstances, TypeOperators
           , TypeFamilies, TypeSynonymInstances
  #-}
{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
----------------------------------------------------------------------
-- |
-- Module      :  Vector3
-- Copyright   :  (c) Conal Elliott and Andy J Gill 2008
-- License     :  BSD3
-- 
-- Maintainer  :  conal@conal.net, andygill@ku.edu
-- Stability   :  experimental
-- 
-- Vectors in 3D.  Uses the OpenGL 'Vector3' type, for convenience and
-- efficiency.
----------------------------------------------------------------------

module Graphics.FieldTrip.Vector3 
  (
   Vector3(..)
  , xVector3, yVector3, zVector3
  , vector3x, vector3y, vector3z
  , vector3Spherical
  , vector3SphericalCoords
  , vector3D, unvector3D, cross3
  ) where

import Control.Applicative

import Graphics.Rendering.OpenGL (Vector3(..))

import Data.VectorSpace
import Data.MemoTrie
import Data.Basis
import Data.Derivative
import Data.Cross

import Graphics.FieldTrip.Vector2

-- type V3 = Vector3 Double

-- | The unit vector in the positive X direction.
xVector3 :: Num s => Vector3 s
xVector3 = Vector3 1 0 0

-- | The unit vector in the positive Y direction.
yVector3 :: Num s => Vector3 s
yVector3 = Vector3 0 1 0

-- | The unit vector in the positive Z direction.
zVector3 :: Num s => Vector3 s
zVector3 = Vector3 0 0 1

vector3x, vector3y, vector3z :: Vector3 s -> s
vector3x (Vector3 x _ _) = x
vector3y (Vector3 _ y _) = y
vector3z (Vector3 _ _ z) = z

-- vector3RectCoords :: Vector3 -> (R,R,R)
-- vector3RectCoords (Vector3 x y z) = (x,y,z)

-- | Vector from spherical coordinates.  See also 'vector2SphericalCoords'.
vector3Spherical :: Floating s => s -> s -> s -> Vector3 s
vector3Spherical rho theta phi =
  Vector3 (rho * sinPhi * cosTheta)
          (rho * sinPhi * sinTheta)
          (rho * cosPhi)
 where
   cosTheta = cos theta; cosPhi = cos phi
   sinTheta = sin theta; sinPhi = sin phi 

-- | Spherical coordinates of a vector.  See also 'vector2Spherical'.
vector3SphericalCoords :: (InnerSpace s s, Floating s) => Vector3 s -> (s,s,s)
vector3SphericalCoords v@(Vector3 x y z) = (rho, theta, phi)
 where
   rho   = magnitude v
   theta = atan (y/x)  -- in case (==) is not defined, as in (a:>b)
           -- if x == 0 then 0 else atan (y/x)
   phi   = acos (z / rho)

instance Functor Vector3 where
  fmap f (Vector3 x y z) = Vector3 (f x) (f y) (f z)

instance Applicative Vector3 where
  pure x = Vector3 x x x
  Vector3 f g h <*> Vector3 x y z = Vector3 (f x) (g y) (h z)


instance AdditiveGroup u => AdditiveGroup (Vector3 u) where
  zeroV                   = Vector3 zeroV zeroV zeroV
  Vector3 u v w ^+^ Vector3 u' v' w'
                          = Vector3 (u^+^u') (v^+^v') (w^+^w')
  negateV (Vector3 u v w) = Vector3 (negateV u) (negateV v) (negateV w)

instance VectorSpace u s => VectorSpace (Vector3 u) s where
  s *^ Vector3 u v w    = Vector3 (s*^u) (s*^v) (s*^w)

instance (InnerSpace u s, AdditiveGroup s)
    => InnerSpace (Vector3 u) s where
  Vector3 u v w <.> Vector3 u' v' w' = u<.>u' ^+^ v<.>v' ^+^ w<.>w'

instance HasBasis u s => HasBasis (Vector3 u) s where
  type Basis (Vector3 u) = Basis (u,u,u)
  basisValue             = toV3 . basisValue
  decompose              = decompose  . fromV3
  decompose'             = decompose' . fromV3

toV3 :: (u,u,u) -> Vector3 u
toV3 (u,v,w) = Vector3 u v w

fromV3 :: Vector3 u -> (u,u,u)
fromV3 (Vector3 u v w) = (u,v,w)

instance ( Num s, VectorSpace s s
         , HasBasis s s, HasTrie (Basis s), Basis s ~ () )
         => HasNormal (Vector2 s :> Vector3 s) where
  normalVec v = d (Left ()) `cross3` d (Right ())
   where
     d = untrie (derivative v)

-- Above doesn't seem to work in ghc 6.8.  So use explicit instances for
-- 'Float' & 'Double'.  Revisit.

-- instance HasNormal (Vector2 Float :> Vector3 Float) where
--   normalVec v = d (Left ()) `cross3` d (Right ())
--    where
--      d = untrie (derivative v)

-- instance HasNormal (Vector2 Double :> Vector3 Double) where
--   normalVec v = d (Left ()) `cross3` d (Right ())
--    where
--      d = untrie (derivative v)

instance Num s => HasCross3 (Vector3 s) where
  Vector3 ax ay az `cross3` Vector3 bx by bz =
    Vector3 (ay * bz - az * by)
            (az * bx - ax * bz)
            (ax * by - ay * bx)

-- instance (Num s, VectorSpace s s) => HasCross (Vector3 (Vector2 s :> s)) where
--   cross = unvector3F . cross . vector3F

-- vector3F :: (Applicative f) => Vector3 (f s) -> f (Vector3 s)
-- vector3F (Vector3 u v w) = liftA3 Vector3 u v w

-- unvector3F :: (Functor f) => f (Vector3 s) -> Vector3 (f s)
-- unvector3F d = Vector3 (vector3x <$> d) (vector3y <$> d) (vector3z <$> d)

-- instance (Num s, LMapDom s s) => HasNormal (Three (Vector2 s :> s)) where
--   normalVec = unvector3D . normalVec . vector3D

-- instance ( Num s, VectorSpace s s, HasBasis s s, HasTrie (Basis s)
--          , HasNormal (Vector2 s :> Vector3 s)
--          , HasBasis (Vector2 s) s, HasTrie (Basis (Vector2 s)))
--          => HasNormal (Vector3 (Vector2 s :> s)) where
--   normalVec v = d (Left ()) `cross3` d (Right ())
--    where
--      d = untrie (derivative v)

-- instance (Num s, VectorSpace s s, HasBasis s s, HasTrie (Basis s)) =>
--          HasNormal (Three (Vector2 s :> s)) where
--   normalVec = unvector3D . normalVec . vector3D

-- sigh.  try the instance above when we're on ghc-6.9

instance HasNormal (Three (Vector2 Float :> Float)) where
  normalVec = unvector3D . normalVec . vector3D

instance HasNormal (Three (Vector2 Double :> Double)) where
  normalVec = unvector3D . normalVec . vector3D

vector3D :: (VectorSpace s s, HasTrie (Basis a)) =>
            Three (a :> s) -> a :> (Vector3 s)
vector3D (u,v,w) = liftD3 Vector3 u v w

unvector3D :: (VectorSpace s s, HasTrie (Basis a)) =>
              a :> (Vector3 s) -> Three (a :> s)
unvector3D d = (vector3x <$>> d, vector3y <$>> d, vector3z <$>> d)