module Data.Tup.Vec where
import Control.Applicative
import Data.List
import Data.Foldable
import Data.Traversable
import Data.Monoid
import Foreign.Ptr
import Foreign.Storable
import Foreign.Marshal
import Text.Show
import Data.Tup.Class
instance Tup Empty where
tupSize _ = 0
tupToList Empty = []
tupFromList [] = Empty
tupFromList (x:xs) = error "tupFromList: list length does not match"
constantTup _ = Empty
undefinedTup = Empty
instance Tup v => Tup (Cons v) where
tupSize v = 1 + tupSize (consUndefTail v)
tupToList (Cons x p) = x : tupToList p
tupFromList xxs = this where
this = case xxs of
(x:xs) -> Cons x (tupFromList xs)
[] -> err
err = error "tupFromList: list length odes not match"
constantTup x = Cons x (constantTup x)
undefinedTup = Cons undefined undefinedTup
type Vec0 = Empty
type Vec1 = Cons Vec0
type Vec2 = Cons Vec1
type Vec3 = Cons Vec2
type Vec4 = Cons Vec3
type Vec5 = Cons Vec4
type Vec6 = Cons Vec5
type Vec7 = Cons Vec6
type Vec8 = Cons Vec7
type Vec9 = Cons Vec8
data Empty a = Empty deriving (Eq,Ord,Bounded,Functor,Foldable,Traversable)
data Cons v a = Cons a (v a) deriving (Eq,Ord,Bounded,Functor,Foldable,Traversable)
consUndefTail :: Tup v => Cons v a -> v a
consUndefTail _ = undefinedTup
instance Show a => Show (Empty a) where
show Empty = "Vec0"
instance (Show a, Tup v) => Show (Cons v a) where
showsPrec d vec
= showParen (d>app_prec)
$ showString "Vec" . shows k . stuff xs
where
k = tupSize vec
xs = tupToList vec
show1 x = showsPrec (app_prec+1) x
app_prec = 10
stuff [] = id
stuff (y:ys) = showChar ' ' . show1 y . stuff ys
instance Applicative Empty where
pure x = Empty
Empty <*> Empty = Empty
instance Applicative v => Applicative (Cons v) where
pure x = Cons x (pure x)
Cons f fs <*> Cons x xs = Cons (f x) (fs <*> xs)
instance Num a => Num (Empty a) where
t1 + t2 = (+) <$> t1 <*> t2
t1 t2 = () <$> t1 <*> t2
t1 * t2 = (*) <$> t1 <*> t2
abs = fmap abs
signum = fmap signum
fromInteger = pure . fromInteger
instance (Num a, Num (v a), Tup v) => Num (Cons v a) where
t1 + t2 = (+) <$> t1 <*> t2
t1 t2 = () <$> t1 <*> t2
t1 * t2 = (*) <$> t1 <*> t2
abs = fmap abs
signum = fmap signum
fromInteger = pure . fromInteger
instance Fractional a => Fractional (Empty a) where
t1 / t2 = (/) <$> t1 <*> t2
recip = fmap recip
fromRational = pure . fromRational
instance (Fractional a, Fractional (v a), Tup v) => Fractional (Cons v a) where
t1 / t2 = (/) <$> t1 <*> t2
recip = fmap recip
fromRational = pure . fromRational
instance Monoid a => Monoid (Empty a) where
mempty = pure mempty
mappend t1 t2 = mappend <$> t1 <*> t2
instance (Monoid a, Monoid (v a), Tup v) => Monoid (Cons v a) where
mempty = pure mempty
mappend t1 t2 = mappend <$> t1 <*> t2
instance Storable a => Storable (Empty a) where
sizeOf t = tupSize t * sizeOf (tupUndef t)
alignment t = alignment (tupUndef t)
peek ptr = let { ptrUndef :: Ptr b -> b ; ptrUndef _ = undefined }
in tupFromList <$> peekArray (tupSize $ ptrUndef ptr) (castPtr ptr)
poke ptr t = pokeArray (castPtr ptr) (tupToList t)
instance (Storable a, Storable (v a), Tup v) => Storable (Cons v a) where
sizeOf t = tupSize t * sizeOf (tupUndef t)
alignment t = alignment (tupUndef t)
peek ptr = let { ptrUndef :: Ptr b -> b ; ptrUndef _ = undefined }
in tupFromList <$> peekArray (tupSize $ ptrUndef ptr) (castPtr ptr)
poke ptr t = pokeArray (castPtr ptr) (tupToList t)
vec0 :: Vec0 a
vec0 = Empty
vec1 :: a -> Vec1 a
vec1 x1 = tupFromList [x1]
vec2 :: a -> a -> Vec2 a
vec2 x1 x2 = tupFromList [x1,x2]
vec3 :: a -> a -> a -> Vec3 a
vec3 x1 x2 x3 = tupFromList [x1,x2,x3]
vec4 :: a -> a -> a -> a -> Vec4 a
vec4 x1 x2 x3 x4 = tupFromList [x1,x2,x3,x4]
vec5 :: a -> a -> a -> a -> a -> Vec5 a
vec5 x1 x2 x3 x4 x5 = tupFromList [x1,x2,x3,x4,x5]
vec6 :: a -> a -> a -> a -> a -> a -> Vec6 a
vec6 x1 x2 x3 x4 x5 x6 = tupFromList [x1,x2,x3,x4,x5,x6]
vec7 :: a -> a -> a -> a -> a -> a -> a -> Vec7 a
vec7 x1 x2 x3 x4 x5 x6 x7 = tupFromList [x1,x2,x3,x4,x5,x6,x7]
vec8 :: a -> a -> a -> a -> a -> a -> a -> a -> Vec8 a
vec8 x1 x2 x3 x4 x5 x6 x7 x8 = tupFromList [x1,x2,x3,x4,x5,x6,x7,x8]
vec9 :: a -> a -> a -> a -> a -> a -> a -> a -> a -> Vec9 a
vec9 x1 x2 x3 x4 x5 x6 x7 x8 x9 = tupFromList [x1,x2,x3,x4,x5,x6,x7,x8,x9]
vecVec :: Applicative f => f a -> f a -> f (Vec2 a)
vecVec t1 t2 = vec2 <$> t1 <*> t2
vecVec3 :: Applicative f => f a -> f a -> f a -> f (Vec3 a)
vecVec3 t1 t2 t3 = vec3 <$> t1 <*> t2 <*> t3
vecVec4 :: Applicative f => f a -> f a -> f a -> f a -> f (Vec4 a)
vecVec4 t1 t2 t3 t4 = vec4 <$> t1 <*> t2 <*> t3 <*> t4
vecVec5 :: Applicative f => f a -> f a -> f a -> f a -> f a -> f (Vec5 a)
vecVec5 t1 t2 t3 t4 t5 = vec5 <$> t1 <*> t2 <*> t3 <*> t4 <*> t5