module Control.Imperative.Vector.Dynamic
(
Vector
, MonadVector
, VectorElem
, VectorEntity
, HasVector
, Item
, NestedList
, Size(..)
, Dim(..)
, dim1
, dim2
, dim3
, new
, newSized
, newSized'
, Control.Imperative.Vector.Dynamic.length
, size
, fromList
, toList
, push
, pop
, unshift
, shift
) where
import Control.Imperative.Internal
import Control.Imperative.Vector.Base
import Control.Monad (liftM)
import qualified Control.Monad as M
import Control.Monad.Base
import Control.Monad.Primitive (PrimMonad)
import Data.Nat
import Data.Vector.Dynamic
newtype Vector m n a = V (MultiDim m n a)
class Monad m => HasVector s v m | s -> v, s -> m where
getVector :: s -> m v
instance Monad m => HasVector (Vector m n a) (Vector m n a) m where
getVector = return
instance Monad m => HasVector (Ref m (Vector m n a)) (Vector m n a) m where
getVector = get
data MultiDim m (n :: Nat) a where
D1 :: DynamicVector m a -> MultiDim m (S Z) a
DN :: DynamicVector m (MultiDim m (S n) a) -> MultiDim m (S (S n)) a
instance (VectorElem a, PrimMonad m) => Indexable (Vector m (S Z) a) where
type Element (Vector m (S Z) a) = Ref m a
type IndexType (Vector m (S Z) a) = Int
(!) (V (D1 v)) i = Ref
{ get = readDyn v i
, set = writeDyn v i
}
instance PrimMonad m => Indexable (Vector m (S (S n)) a) where
type Element (Vector m (S (S n)) a) = Ref m (Vector m (S n) a)
type IndexType (Vector m (S (S n)) a) = Int
(!) (V (DN v)) i = Ref
{ get = liftM V $ readDyn v i
, set = \(V w) -> writeDyn v i w
}
instance (VectorElem a, PrimMonad m) => Indexable (Ref m (Vector m (S Z) a)) where
type Element (Ref m (Vector m (S Z) a)) = Ref m a
type IndexType (Ref m (Vector m (S Z) a)) = Int
r ! i = Ref
{ get = get r >>= \(V (D1 v)) -> readDyn v i
, set = \x -> get r >>= \(V (D1 v)) -> writeDyn v i x
}
instance PrimMonad m => Indexable (Ref m (Vector m (S (S n)) a)) where
type Element (Ref m (Vector m (S (S n)) a)) = Ref m (Vector m (S n) a)
type IndexType (Ref m (Vector m (S (S n)) a)) = Int
r ! i = Ref
{ get = get r >>= \(V (DN v)) -> liftM V $ readDyn v i
, set = \(V w) -> get r >>= \(V (DN v)) -> writeDyn v i w
}
new
:: (VectorElem a, MonadVector m, SingNat (S n))
=> proxy (S n)
-> m (Vector (BaseEff m) (S n) a)
new (_ :: proxy (S n)) = liftBase $ liftM V $ case (singNat :: SNat (S n)) of
SS SZ -> M.liftM D1 $ newDyn 0
SS (SS _) -> M.liftM DN $ newDyn 0
newSized :: (VectorElem a, MonadVector m) => Size (S n) -> m (Vector (BaseEff m) (S n) a)
newSized = liftBase . liftM V . go
where
go :: (VectorElem a, PrimMonad m) => Size (S n) -> m (MultiDim m (S n) a)
go (n :*: One) = liftM D1 $ newDyn n
go (n :*: r@(_ :*: _)) = do
v <- newDyn n
M.forM_ [0..n1] $ \i -> do
w <- go r
writeDyn v i w
return $ DN v
newSized' :: (VectorElem a, MonadVector m) => Size (S n) -> a -> m (Vector (BaseEff m) (S n) a)
newSized' r = liftBase . liftM V . go r
where
go :: (VectorElem a, PrimMonad m) => Size (S n) -> a -> m (MultiDim m (S n) a)
go (n :*: One) x = liftM D1 $ newDyn' n x
go (n :*: rest@(_ :*: _)) x = do
v <- newDyn n
M.forM_ [0..n1] $ \i -> do
w <- go rest x
writeDyn v i w
return $ DN v
fromList
:: (VectorElem a, MonadVector m, SingNat (S d))
=> proxy (S d)
-> NestedList (S d) a
-> m (Vector (BaseEff m) (S d) a)
fromList (_ :: proxy (S d)) = liftBase . liftM V . go (singNat :: SNat (S d))
where
go :: (PrimMonad f, VectorElem b) => SNat (S n) -> NestedList (S n) b -> f (MultiDim f (S n) b)
go (SS SZ) xs = do
v <- newDyn 0
M.forM_ xs $ \x -> pushDyn v x
return (D1 v)
go (SS n@(SS _)) xs = do
v <- newDyn 0
M.forM_ xs $ \ys -> do
w <- go n ys
pushDyn v w
return (DN v)
toList :: (VectorElem a, HasVector s (Vector (BaseEff m) (S n) a) (BaseEff m), MonadVector m) => s -> m (NestedList (S n) a)
toList s = liftBase $ getVector s >>= \(V dv) -> go dv
where
go :: (VectorElem a, PrimMonad m) => MultiDim m n a -> m (NestedList n a)
go (D1 v) = toListDyn v
go (DN v) = toListDyn v >>= M.mapM go
size :: (VectorElem a, HasVector s (Vector (BaseEff m) (S n) a) (BaseEff m), MonadVector m) => s -> m Int
size s = liftBase $ getVector s >>= \(V dv) -> case dv of
D1 v -> sizeDyn v
DN v -> sizeDyn v
length :: (VectorElem a, HasVector s (Vector (BaseEff m) (S n) a) (BaseEff m), MonadVector m) => s -> m Int
length = size
type family Item a where
Item (Vector m (S Z) a) = a
Item (Vector m (S (S n)) a) = Vector m (S n) a
push :: (VectorElem a, HasVector s (Vector (BaseEff m) (S n) a) (BaseEff m), MonadVector m) => s -> Item (Vector (BaseEff m) (S n) a) -> m ()
push s x = liftBase $ getVector s >>= \(V dv) -> case dv of
D1 v -> pushDyn v x
DN v -> let (V w) = x in pushDyn v w
pop :: (VectorElem a, HasVector s (Vector (BaseEff m) (S n) a) (BaseEff m), MonadVector m) => s -> m (Item (Vector (BaseEff m) (S n) a))
pop s = liftBase $ getVector s >>= \(V dv) -> case dv of
D1 v -> popDyn v
DN v -> liftM V $ popDyn v
unshift :: (VectorElem a, HasVector s (Vector (BaseEff m) (S n) a) (BaseEff m), MonadVector m) => s -> Item (Vector (BaseEff m) (S n) a) -> m ()
unshift s x = liftBase $ getVector s >>= \(V dv) -> case dv of
D1 v -> unshiftDyn v x
DN v -> let (V w) = x in unshiftDyn v w
shift :: (VectorElem a, HasVector s (Vector (BaseEff m) (S n) a) (BaseEff m), MonadVector m) => s -> m (Item (Vector (BaseEff m) (S n) a))
shift s = liftBase $ getVector s >>= \(V dv) -> case dv of
D1 v -> shiftDyn v
DN v -> liftM V $ shiftDyn v