algebraic-0.1.0.2: src/Math/Coordinate/Cartesian.hs

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Math.Coordinate.Cartesian where



import           Data.Array.Accelerate
import           Data.Array.Accelerate.Smart
import           Data.Array.Accelerate.Tuple
import           Data.Array.Accelerate.Array.Sugar
import           Data.Complex
import qualified Data.Foldable as F
import           Data.Typeable

import Control.Applicative

import Math.Coordinate.Coordinate (CoordConversion(..), ManualConversion(..), AutoConversion(..), convertCoord)
import Math.Space.Space           (Space2)

data Cartesian  = Cartesian deriving (Show)

data Point1 a   = Point1 !a deriving (Eq, Ord, Show, Read,Typeable)
data Point2 a   = Point2 !a !a deriving (Eq, Ord, Show, Read,Typeable)
data Point3 a   = Point3 !a !a !a deriving (Eq, Ord, Show, Read,Typeable)
data Point4 a   = Point4 !a !a !a !a deriving (Eq, Ord, Show, Read,Typeable)

toCartesian = convertCoord Cartesian

--------------------------------------------------------------------------------
-- Classes
--------------------------------------------------------------------------------

class CartesianCoord1 coord where
    x :: coord a -> a

class CartesianCoord1 coord => CartesianCoord2 coord where
    y :: coord a -> a

class CartesianCoord2 coord => CartesianCoord3 coord where
    z :: coord a -> a

class CartesianCoord3 coord => CartesianCoord4 coord where
    w :: coord a -> a

--------------------------------------------------------------------------------
-- Functions
--------------------------------------------------------------------------------
uncurry :: (a -> a -> b) -> Point2 a -> b
uncurry f (Point2 x y) = f x y

--------------------------------------------------------------------------------
-- Instances
--------------------------------------------------------------------------------

instance CartesianCoord1 Point1 where x (Point1 x) = x

instance CartesianCoord1 Point2 where x (Point2 x _) = x
instance CartesianCoord2 Point2 where y (Point2 _ y) = y

instance CartesianCoord1 Point3 where x (Point3 x _ _) = x
instance CartesianCoord2 Point3 where y (Point3 _ y _) = y
instance CartesianCoord3 Point3 where z (Point3 _ _ z) = z

instance CartesianCoord1 Point4 where x (Point4 x _ _ _) = x
instance CartesianCoord2 Point4 where y (Point4 _ y _ _) = y
instance CartesianCoord3 Point4 where z (Point4 _ _ z _) = z
instance CartesianCoord4 Point4 where w (Point4 _ _ _ w) = w


instance  ( CoordConversion ManualConversion Cartesian space a b
          , CoordConversion ManualConversion sys space b c) => 
          CoordConversion AutoConversion sys space a c where
    convertCoordBase _ coord space = (convertCoordBase ManualConversion coord space) . (convertCoordBase ManualConversion Cartesian space)


instance CoordConversion ManualConversion Cartesian space (Point2 a) (Point2 a) where
    convertCoordBase _ _ _ = id

--------------------------------------------------------------------------------
-- Point1
--------------------------------------------------------------------------------
instance Functor Point1 where
    fmap f (Point1 a) = Point1 (f a)

instance Applicative Point1 where
    pure a = Point1 a
    {-# INLINE pure #-}
    Point1 a <*> Point1 d = Point1 (a d)
    {-# INLINE (<*>) #-}

instance Num a => Num (Point1 a) where
    (+) = liftA2 (+)
    {-# INLINE (+) #-}
    (-) = liftA2 (-)
    {-# INLINE (-) #-}
    (*) = liftA2 (*)
    {-# INLINE (*) #-}
    negate = fmap negate
    {-# INLINE negate #-}
    abs = fmap abs
    {-# INLINE abs #-}
    signum = fmap signum
    {-# INLINE signum #-}
    fromInteger = pure . fromInteger
    {-# INLINE fromInteger #-}

instance Fractional a => Fractional (Point1 a) where
    recip = fmap recip
    {-# INLINE recip #-}
    (/) = liftA2 (/)
    {-# INLINE (/) #-}
    fromRational = pure . fromRational
    {-# INLINE fromRational #-}

type instance EltRepr (Point1 a) = EltRepr a
type instance EltRepr' (Point1 a) = EltRepr' a

instance Elt a => Elt (Point1 a) where
  eltType _ = eltType (undefined :: a)
  toElt = Point1 . toElt
  fromElt (Point1 a) = fromElt a

  eltType' _ = eltType' (undefined :: a)
  toElt' = Point1 . toElt'
  fromElt' (Point1 a) = fromElt' a

instance IsTuple (Point1 a) where
  type TupleRepr (Point1 a) = ((), a)
  fromTuple (Point1 x) = ((), x)
  toTuple ((), x) = Point1 x

instance (Lift Exp a, Elt (Plain a)) => Lift Exp (Point1 a) where
  type Plain (Point1 a) = Point1 (Plain a)
  lift (Point1 x) = Exp . Tuple $ NilTup `SnocTup` lift x

instance (Elt a, e ~ Exp a) => Unlift Exp (Point1 e) where
  unlift t = Point1 $ Exp $ ZeroTupIdx `Prj` t
--------------------------------------------------------------------------------
-- Point2
--------------------------------------------------------------------------------
instance Functor Point2 where
    fmap f (Point2 a b) = Point2 (f a) (f b)

instance Applicative Point2 where
    pure a = Point2 a a
    {-# INLINE pure #-}
    Point2 a b <*> Point2 d e = Point2 (a d) (b e)
    {-# INLINE (<*>) #-}

instance Num a => Num (Point2 a) where
    (+) = liftA2 (+)
    {-# INLINE (+) #-}
    (-) = liftA2 (-)
    {-# INLINE (-) #-}
    (*) = liftA2 (*)
    {-# INLINE (*) #-}
    negate = fmap negate
    {-# INLINE negate #-}
    abs = fmap abs
    {-# INLINE abs #-}
    signum = fmap signum
    {-# INLINE signum #-}
    fromInteger = pure . fromInteger
    {-# INLINE fromInteger #-}

instance Fractional a => Fractional (Point2 a) where
    recip = fmap recip
    {-# INLINE recip #-}
    (/) = liftA2 (/)
    {-# INLINE (/) #-}
    fromRational = pure . fromRational
    {-# INLINE fromRational #-}

type instance EltRepr (Point2 a)  = EltRepr (a, a)
type instance EltRepr' (Point2 a) = EltRepr' (a, a)

instance Elt a => Elt (Point2 a) where
  eltType _ = eltType (undefined :: (a,a))
  toElt p = case toElt p of
     (x, y) -> Point2 x y
  fromElt (Point2 x y) = fromElt (x, y)

  eltType' _ = eltType' (undefined :: (a,a))
  toElt' p = case toElt' p of
     (x, y) -> Point2 x y
  fromElt' (Point2 x y) = fromElt' (x, y)

instance IsTuple (Point2 a) where
  type TupleRepr (Point2 a) = TupleRepr (a,a)
  fromTuple (Point2 x y) = fromTuple (x,y)
  toTuple t = case toTuple t of
     (x, y) -> Point2 x y

instance (Lift Exp a, Elt (Plain a)) => Lift Exp (Point2 a) where
  type Plain (Point2 a) = Point2 (Plain a)
  --lift = Exp . Tuple . F.foldl SnocTup NilTup
  lift (Point2 x y) = Exp $ Tuple $ NilTup `SnocTup` lift x `SnocTup` lift y

instance (Elt a, e ~ Exp a) => Unlift Exp (Point2 e) where
  unlift t = Point2 (Exp $ SuccTupIdx ZeroTupIdx `Prj` t)
                (Exp $ ZeroTupIdx `Prj` t)

--------------------------------------------------------------------------------
-- Point3
--------------------------------------------------------------------------------
instance Functor Point3 where
    fmap f (Point3 a b c) = Point3 (f a) (f b) (f c)

instance Applicative Point3 where
    pure a = Point3 a a a
    {-# INLINE pure #-}
    Point3 a b c <*> Point3 d e f = Point3 (a d) (b e) (c f)
    {-# INLINE (<*>) #-}

instance Num a => Num (Point3 a) where
    (+) = liftA2 (+)
    {-# INLINE (+) #-}
    (-) = liftA2 (-)
    {-# INLINE (-) #-}
    (*) = liftA2 (*)
    {-# INLINE (*) #-}
    negate = fmap negate
    {-# INLINE negate #-}
    abs = fmap abs
    {-# INLINE abs #-}
    signum = fmap signum
    {-# INLINE signum #-}
    fromInteger = pure . fromInteger
    {-# INLINE fromInteger #-}

instance Fractional a => Fractional (Point3 a) where
    recip = fmap recip
    {-# INLINE recip #-}
    (/) = liftA2 (/)
    {-# INLINE (/) #-}
    fromRational = pure . fromRational
    {-# INLINE fromRational #-}

type instance EltRepr (Point3 a)  = EltRepr (a, a, a)
type instance EltRepr' (Point3 a) = EltRepr' (a, a, a)

instance Elt a => Elt (Point3 a) where
  eltType _ = eltType (undefined :: (a,a,a))
  toElt p = case toElt p of
     (x, y, z) -> Point3 x y z
  fromElt (Point3 x y z) = fromElt (x, y, z)

  eltType' _ = eltType' (undefined :: (a,a,a))
  toElt' p = case toElt' p of
     (x, y, z) -> Point3 x y z
  fromElt' (Point3 x y z) = fromElt' (x, y, z)

instance IsTuple (Point3 a) where
  type TupleRepr (Point3 a) = TupleRepr (a,a,a)
  fromTuple (Point3 x y z) = fromTuple (x,y,z)
  toTuple t = case toTuple t of
     (x, y, z) -> Point3 x y z

instance (Lift Exp a, Elt (Plain a)) => Lift Exp (Point3 a) where
  type Plain (Point3 a) = Point3 (Plain a)
  --lift = Exp . Tuple . F.foldl SnocTup NilTup
  lift (Point3 x y z) = Exp $ Tuple $ NilTup `SnocTup` lift x `SnocTup` lift y `SnocTup` lift z

instance (Elt a, e ~ Exp a) => Unlift Exp (Point3 e) where
  unlift t = Point3 (Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` t)
                (Exp $ SuccTupIdx ZeroTupIdx `Prj` t)
                (Exp $ ZeroTupIdx `Prj` t)

--------------------------------------------------------------------------------
-- Point4
--------------------------------------------------------------------------------
instance Functor Point4 where
    fmap f (Point4 a b c d) = Point4 (f a) (f b) (f c) (f d)

instance Applicative Point4 where
    pure a = Point4 a a a a
    {-# INLINE pure #-}
    Point4 a b c d <*> Point4 e f g h = Point4 (a e) (b f) (c g) (d h)
    {-# INLINE (<*>) #-}

instance Num a => Num (Point4 a) where
    (+) = liftA2 (+)
    {-# INLINE (+) #-}
    (-) = liftA2 (-)
    {-# INLINE (-) #-}
    (*) = liftA2 (*)
    {-# INLINE (*) #-}
    negate = fmap negate
    {-# INLINE negate #-}
    abs = fmap abs
    {-# INLINE abs #-}
    signum = fmap signum
    {-# INLINE signum #-}
    fromInteger = pure . fromInteger
    {-# INLINE fromInteger #-}

instance Fractional a => Fractional (Point4 a) where
    recip = fmap recip
    {-# INLINE recip #-}
    (/) = liftA2 (/)
    {-# INLINE (/) #-}
    fromRational = pure . fromRational
    {-# INLINE fromRational #-}

type instance EltRepr (Point4 a)  = EltRepr (a, a, a, a)
type instance EltRepr' (Point4 a) = EltRepr' (a, a, a, a)

instance Elt a => Elt (Point4 a) where
  eltType _ = eltType (undefined :: (a,a,a,a))
  toElt p = case toElt p of
     (x, y, z, w) -> Point4 x y z w
  fromElt (Point4 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) -> Point4 x y z w
  fromElt' (Point4 x y z w) = fromElt' (x, y, z, w)

instance IsTuple (Point4 a) where
  type TupleRepr (Point4 a) = TupleRepr (a,a,a,a)
  fromTuple (Point4 x y z w) = fromTuple (x,y,z,w)
  toTuple t = case toTuple t of
     (x, y, z, w) -> Point4 x y z w

instance (Lift Exp a, Elt (Plain a)) => Lift Exp (Point4 a) where
  type Plain (Point4 a) = Point4 (Plain a)
  --  lift = Exp . Tuple . F.foldl SnocTup NilTup
  lift (Point4 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 (Point4 e) where
  unlift t = Point4 (Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` t)
                (Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` t)
                (Exp $ SuccTupIdx ZeroTupIdx `Prj` t)
                (Exp $ ZeroTupIdx `Prj` t)