-- | Homogeneous lists with the length encoded in the type.
--
-- This can be considered as a different implementation of "Data.Tup.Tup" 
-- (one which also scales for vectors/tuples longer than 9 elements)
--
-- Example:
-- 
-- > vec3 1 2 3  :: Vec3 Int
-- > {{ 1,2,3 }} :: Vec3 Int
-- > Cons 1 (Cons 2 (Cons 3 Empty)) :: Cons (Cons (Cons Empty)) Int
--

{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable, FlexibleContexts 
  #-}
module Data.Tup.Vec where
--              MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances

--------------------------------------------------------------------------------

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

--------------------------------------------------------------------------------
-- * The @Vec@ type class

instance Tup Empty where

  tupSize _ = 0             -- important to be as lazy as possible here!

  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 (Cons _ p) = 1 + vecSize p
  tupSize v = 1 + tupSize (consUndefTail v)    -- better to be lazier!

  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 abbreviations for short vectors

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

--------------------------------------------------------------------------------
-- * The constructor types

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
  {-# INLINE pure  #-}
  {-# INLINE (<*>) #-}
  pure x = Empty
  Empty <*> Empty = Empty

instance Applicative v => Applicative (Cons v) where
  {-# INLINE pure  #-}
  {-# INLINE (<*>) #-}
  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) 

--------------------------------------------------------------------------------

{- derived by GHC

instance Eq a => Eq (Empty a) where 
  (==) Empty Empty = True

instance (Eq a, Vec v) => Eq (Cons v a) where 
  (==) u v = (vecToList u == vecToList v)

instance Ord a => Ord (Empty a) where 
  compare Empty Empty = EQ

instance (Ord a, Vec v) => Ord (Cons v a) where 
  compare u v = compare (vecToList u) (vecToList v)

-}

--------------------------------------------------------------------------------
-- * Short constructor functions

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]

--------------------------------------------------------------------------------
-- * \"veccing\"

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

--------------------------------------------------------------------------------