module Data.Vector.Fixed.Cont (
Dim
, Vector(..)
, VectorN
, length
, ContVecT(..)
, ContVec
, N1
, N2
, N3
, N4
, N5
, N6
, cvec
, empty
, fromList
, replicate
, replicateM
, generate
, generateM
, unfoldr
, basis
, mk1
, mk2
, mk3
, mk4
, mk5
, map
, imap
, mapM
, imapM
, tail
, cons
, changeMonad
, zipWith
, izipWith
, zipWithM
, izipWithM
, runContVecT
, runContVecM
, runContVec
, head
, index
, vector
, vectorM
, foldl
, foldl1
, foldr
, ifoldl
, ifoldr
, foldM
, ifoldM
, sum
, minimum
, maximum
, and
, or
, all
, any
) where
import Control.Applicative (Applicative(..))
import Data.Complex (Complex(..))
import Data.Vector.Fixed.Internal.Arity
import Data.Vector.Fixed.Internal.Id
import Prelude hiding ( replicate,map,zipWith,maximum,minimum,and,or,any,all
, foldl,foldr,foldl1,length,sum
, head,tail,mapM,mapM_,sequence,sequence_
)
type family Dim (v :: * -> *)
class Arity (Dim v) => Vector v a where
construct :: Fun (Dim v) a (v a)
inspect :: v a -> Fun (Dim v) a b -> b
basicIndex :: v a -> Int -> a
basicIndex v i = runContVec (index i) (cvec v)
class (Vector (v n) a, Dim (v n) ~ n) => VectorN v n a
length :: forall v a. Arity (Dim v) => v a -> Int
length _ = arity (undefined :: Dim v)
newtype ContVecT m n a = ContVecT (forall r. Fun n a (m r) -> m r)
type ContVec = ContVecT Id
instance (Arity n) => Functor (ContVecT m n) where
fmap = map
instance (Arity n) => Applicative (ContVecT m n) where
pure = replicate
(<*>) = zipWith ($)
changeMonad :: (Monad p, Arity n)
=> (forall x. p x -> x)
-> ContVecT p n a -> ContVecT m n a
changeMonad run (ContVecT cont)
= ContVecT $ convertCont run return cont
convertCont :: (Arity n)
=> (b -> c)
-> (c -> b)
-> (Fun n a b -> b)
-> (Fun n a c -> c)
convertCont fB2C fC2B cont = \funC ->
fB2C $ cont (fmap fC2B funC)
cvec :: (Vector v a, Dim v ~ n, Monad m) => v a -> ContVecT m n a
cvec v = ContVecT (inspect v)
empty :: ContVecT m Z a
empty = ContVecT (\(Fun r) -> r)
fromList :: forall m n a. Arity n => [a] -> ContVecT m n a
fromList xs = ContVecT $ \(Fun fun) ->
apply step
(T_flist xs :: T_flist a n)
fun
where
step (T_flist [] ) = error "Data.Vector.Fixed.Cont.fromList: too few elements"
step (T_flist (a:as)) = (a, T_flist as)
data T_flist a n = T_flist [a]
replicate :: forall m n a. (Arity n)
=> a -> ContVecT m n a
replicate a = ContVecT $ \(Fun fun) ->
apply (\T_replicate -> (a, T_replicate))
(T_replicate :: T_replicate n)
fun
replicateM :: forall m n a. (Arity n, Monad m)
=> m a -> ContVecT m n a
replicateM act = ContVecT $ \(Fun fun) ->
applyM (\T_replicate -> do { a <- act; return (a, T_replicate) } )
(T_replicate :: T_replicate n)
fun
data T_replicate n = T_replicate
generate :: forall m n a. (Arity n) => (Int -> a) -> ContVecT m n a
generate f = ContVecT $ \(Fun fun) ->
apply (\(T_generate n) -> (f n, T_generate (n + 1)))
(T_generate 0 :: T_generate n)
fun
generateM :: forall m n a. (Monad m, Arity n)
=> (Int -> m a) -> ContVecT m n a
generateM f = ContVecT $ \(Fun fun) ->
applyM (\(T_generate n) -> do { a <- f n; return (a, T_generate (n + 1)) } )
(T_generate 0 :: T_generate n)
fun
newtype T_generate n = T_generate Int
unfoldr :: forall m n b a. Arity n => (b -> (a,b)) -> b -> ContVecT m n a
unfoldr f b0 = ContVecT $ \(Fun fun) ->
apply (\(T_unfoldr b) -> let (a,b') = f b in (a, T_unfoldr b'))
(T_unfoldr b0 :: T_unfoldr b n)
fun
newtype T_unfoldr b n = T_unfoldr b
basis :: forall m n a. (Num a, Arity n) => Int -> ContVecT m n a
basis n0 = ContVecT $ \(Fun fun) ->
apply (\(T_basis n) -> ((if n == 0 then 1 else 0) :: a, T_basis (n 1)))
(T_basis n0 :: T_basis n)
fun
newtype T_basis n = T_basis Int
mk1 :: a -> ContVecT m N1 a
mk1 a1 = ContVecT $ \(Fun f) -> f a1
mk2 :: a -> a -> ContVecT m N2 a
mk2 a1 a2 = ContVecT $ \(Fun f) -> f a1 a2
mk3 :: a -> a -> a -> ContVecT m N3 a
mk3 a1 a2 a3 = ContVecT $ \(Fun f) -> f a1 a2 a3
mk4 :: a -> a -> a -> a -> ContVecT m N4 a
mk4 a1 a2 a3 a4 = ContVecT $ \(Fun f) -> f a1 a2 a3 a4
mk5 :: a -> a -> a -> a -> a -> ContVecT m N5 a
mk5 a1 a2 a3 a4 a5 = ContVecT $ \(Fun f) -> f a1 a2 a3 a4 a5
map :: (Arity n) => (a -> b) -> ContVecT m n a -> ContVecT m n b
map = imap . const
imap :: (Arity n) => (Int -> a -> b) -> ContVecT m n a -> ContVecT m n b
imap f (ContVecT contA) = ContVecT $
contA . imapF f
mapM :: (Arity n, Monad m) => (a -> m b) -> ContVecT m n a -> ContVecT m n b
mapM = imapM . const
imapM :: (Arity n, Monad m) => (Int -> a -> m b) -> ContVecT m n a -> ContVecT m n b
imapM f (ContVecT contA) = ContVecT $
contA . imapFM f
imapF :: forall n a b r. Arity n
=> (Int -> a -> b) -> Fun n b r -> Fun n a r
imapF f (Fun funB) = Fun $
accum (\(T_map i g) b -> T_map (i+1) (g (f i b)))
(\(T_map _ r) -> r)
( T_map 0 funB :: T_map b r n)
imapFM :: forall m n a b r. (Arity n, Monad m)
=> (Int -> a -> m b) -> Fun n b (m r) -> Fun n a (m r)
imapFM f (Fun h) = Fun $
accumM (\(T_map i g) a -> do b <- f i a
return $ T_map (i + 1) (g b))
(\(T_map _ g) -> g)
(return $ T_map 0 h :: m (T_map b (m r) n))
data T_map a r n = T_map Int (Fn n a r)
tail :: ContVecT m (S n) a
-> ContVecT m n a
tail (ContVecT cont) = ContVecT $ \(Fun f) -> cont (Fun $ \_ -> f)
cons :: a -> ContVecT m n a -> ContVecT m (S n) a
cons a (ContVecT cont) = ContVecT $ \(Fun f) -> cont $ Fun $ f a
zipWith :: (Arity n) => (a -> b -> c)
-> ContVecT m n a -> ContVecT m n b -> ContVecT m n c
zipWith = izipWith . const
izipWith :: (Arity n) => (Int -> a -> b -> c)
-> ContVecT m n a -> ContVecT m n b -> ContVecT m n c
izipWith f (ContVecT contA) (ContVecT contB) = ContVecT $ \funC ->
contA $ fmap contB $ izipWithF f funC
zipWithM :: (Arity n, Monad m) => (a -> b -> m c)
-> ContVecT m n a -> ContVecT m n b -> ContVecT m n c
zipWithM = izipWithM . const
izipWithM :: (Arity n, Monad m) => (Int -> a -> b -> m c)
-> ContVecT m n a -> ContVecT m n b -> ContVecT m n c
izipWithM f (ContVecT contA) (ContVecT contB) = ContVecT $ \funC ->
contA $ fmap contB $ izipWithFM f funC
izipWithF :: forall n a b c r. (Arity n)
=> (Int -> a -> b -> c) -> Fun n c r -> Fun n a (Fun n b r)
izipWithF f (Fun g0) =
fmap (\v -> Fun $ accum
(\(T_izip i (a:as) g) b -> T_izip (i+1) as (g $ f i a b)
)
(\(T_izip _ _ x) -> x)
(T_izip 0 v g0 :: (T_izip a c r n))
) makeList
izipWithFM :: forall m n a b c r. (Arity n, Monad m)
=> (Int -> a -> b -> m c) -> Fun n c (m r) -> Fun n a (Fun n b (m r))
izipWithFM f (Fun g0) =
fmap (\v -> Fun $ accumM
(\(T_izip i (a:as) g) b -> do x <- f i a b
return $ T_izip (i+1) as (g x)
)
(\(T_izip _ _ x) -> x)
(return $ T_izip 0 v g0 :: m (T_izip a c (m r) n))
) makeList
makeList :: forall n a. Arity n => Fun n a [a]
makeList = Fun $ accum
(\(T_mkList xs) x -> T_mkList (xs . (x:)))
(\(T_mkList xs) -> xs [])
(T_mkList id :: T_mkList a n)
newtype T_mkList a n = T_mkList ([a] -> [a])
data T_izip a c r n = T_izip Int [a] (Fn n c r)
runContVecT :: (Monad m, Arity n)
=> Fun n a r
-> ContVecT m n a
-> m r
runContVecT f (ContVecT c) = c $ fmap return f
runContVecM :: Arity n
=> Fun n a (m r)
-> ContVecT m n a
-> m r
runContVecM f (ContVecT c) = c f
runContVec :: Arity n
=> Fun n a r
-> ContVec n a
-> r
runContVec f (ContVecT c) = runID $ c (fmap return f)
vector :: (Vector v a, Dim v ~ n) => ContVec n a -> v a
vector = runContVec construct
vectorM :: (Vector v a, Dim v ~ n, Monad m) => ContVecT m n a -> m (v a)
vectorM = runContVecT construct
head :: forall n a. Arity (S n) => Fun (S n) a a
head = Fun $ accum (\(T_head m) a -> T_head $ case m of { Nothing -> Just a; x -> x })
(\(T_head (Just x)) -> x)
(T_head Nothing :: T_head a (S n))
data T_head a n = T_head (Maybe a)
index :: forall n a. Arity n => Int -> Fun n a a
index n
| n < 0 = error "Data.Vector.Fixed.Cont.index: index out of range"
| otherwise = Fun $ accum
(\(T_Index x) a -> T_Index $ case x of
Left 0 -> Right a
Left i -> Left (i 1)
r -> r
)
(\(T_Index x) -> case x of
Left _ -> error "Data.Vector.Fixed.index: index out of range"
Right a -> a
)
( T_Index (Left n) :: T_Index a n)
newtype T_Index a n = T_Index (Either Int a)
foldl :: forall n a b. Arity n
=> (b -> a -> b) -> b -> Fun n a b
foldl f = ifoldl (\b _ a -> f b a)
ifoldl :: forall n a b. Arity n
=> (b -> Int -> a -> b) -> b -> Fun n a b
ifoldl f b = Fun $ accum (\(T_ifoldl i r) a -> T_ifoldl (i+1) (f r i a))
(\(T_ifoldl _ r) -> r)
(T_ifoldl 0 b :: T_ifoldl b n)
foldM :: forall n m a b. (Arity n, Monad m)
=> (b -> a -> m b) -> b -> Fun n a (m b)
foldM f x
= foldl (\m a -> do{ b <- m; f b a}) (return x)
ifoldM :: forall n m a b. (Arity n, Monad m)
=> (b -> Int -> a -> m b) -> b -> Fun n a (m b)
ifoldM f x
= ifoldl (\m i a -> do{ b <- m; f b i a}) (return x)
data T_ifoldl b n = T_ifoldl !Int b
newtype T_foldl1 a n = T_foldl1 (Maybe a)
foldl1 :: forall n a. (Arity (S n))
=> (a -> a -> a) -> Fun (S n) a a
foldl1 f = Fun $ accum (\(T_foldl1 r) a -> T_foldl1 $ Just $ maybe a (flip f a) r)
(\(T_foldl1 (Just x)) -> x)
(T_foldl1 Nothing :: T_foldl1 a (S n))
foldr :: forall n a b. Arity n
=> (a -> b -> b) -> b -> Fun n a b
foldr = ifoldr . const
ifoldr :: forall n a b. Arity n
=> (Int -> a -> b -> b) -> b -> Fun n a b
ifoldr f z = Fun $
accum (\(T_ifoldr i g) a -> T_ifoldr (i+1) (g . f i a))
(\(T_ifoldr _ g) -> g z)
(T_ifoldr 0 id :: T_ifoldr b n)
data T_ifoldr b n = T_ifoldr Int (b -> b)
sum :: (Num a, Arity n) => Fun n a a
sum = foldl (+) 0
minimum :: (Ord a, Arity (S n)) => Fun (S n) a a
minimum = foldl1 min
maximum :: (Ord a, Arity (S n)) => Fun (S n) a a
maximum = foldl1 max
and :: Arity n => Fun n Bool Bool
and = foldr (&&) True
or :: Arity n => Fun n Bool Bool
or = foldr (||) False
all :: Arity n => (a -> Bool) -> Fun n a Bool
all f = foldr (\x b -> f x && b) True
any :: Arity n => (a -> Bool) -> Fun n a Bool
any f = foldr (\x b -> f x && b) True
type instance Dim Complex = N2
instance RealFloat a => Vector Complex a where
construct = Fun (:+)
inspect (x :+ y) (Fun f) = f x y
type instance Dim ((,) a) = N2
instance (b~a) => Vector ((,) b) a where
construct = Fun (,)
inspect (a,b) (Fun f) = f a b
type instance Dim ((,,) a b) = N3
instance (b~a, c~a) => Vector ((,,) b c) a where
construct = Fun (,,)
inspect (a,b,c) (Fun f) = f a b c
type instance Dim ((,,,) a b c) = N4
instance (b~a, c~a, d~a) => Vector ((,,,) b c d) a where
construct = Fun (,,,)
inspect (a,b,c,d) (Fun f) = f a b c d
type instance Dim ((,,,,) a b c d) = N5
instance (b~a, c~a, d~a, e~a) => Vector ((,,,,) b c d e) a where
construct = Fun (,,,,)
inspect (a,b,c,d,e) (Fun f) = f a b c d e
type instance Dim ((,,,,,) a b c d e) = N6
instance (b~a, c~a, d~a, e~a, f~a) => Vector ((,,,,,) b c d e f) a where
construct = Fun (,,,,,)
inspect (a,b,c,d,e,f) (Fun fun) = fun a b c d e f
type instance Dim ((,,,,,,) a b c d e f) = S N6
instance (b~a, c~a, d~a, e~a, f~a, g~a) => Vector ((,,,,,,) b c d e f g) a where
construct = Fun (,,,,,,)
inspect (a,b,c,d,e,f,g) (Fun fun) = fun a b c d e f g