Uniformable instance for hmatrix vector.

1 files changed, 18 insertions, 0 deletions

diff --git a/LambdaCube/GL/HMatrix.hs b/LambdaCube/GL/HMatrix.hs
index ff5e7a7..127656e 100644
--- a/LambdaCube/GL/HMatrix.hs
+++ b/LambdaCube/GL/HMatrix.hs
@@ -24,8 +24,26 @@ instance (KnownNat r, KnownNat c) => IsUniform (Matrix Float) (UMatrix r c Float
              in Just $ MarshalUMatrix
                      $ \f -> apply mat (\ptr -> f 1 isRowOrder ptr) (\r c sr sc ptr -> ptr)
 
+instance Uniformable (Vector Float) where
+    uniformContexts _ = contexts $ do
+        supports TypeFloat
+        supports TypeV2F
+        supports TypeV3F
+        supports TypeV4F
+
+instance KnownNat n => IsUniform (Vector Float) (USimple n Float) where
+    marshalUniform abi vec
+        | natVal (vectorLength abi) /= fromIntegral (size vec) = Nothing
+        | otherwise = Just $ MarshalUSimple
+                           $ \f -> apply vec (\ptr -> f 1 ptr) (\n ptr -> ptr)
+
 {-
 
+-- C-Haskell vector adapter
+{-# INLINE avec #-}
+avec :: Storable a => Vector a -> (f -> IO r) -> ((CInt -> Ptr a -> f) -> IO r)
+avec v f g = unsafeWith v $ \ptr -> f (g (fromIntegral (Vector.length v)) ptr)
+
 -- apply :: Storable a => Matrix a -> (f -> IO r) -> (CInt -> CInt -> CInt -> CInt -> Ptr a -> f) -> IO r
 {-# INLINE amat #-}
 amat :: Storable a => Matrix a -> (f -> IO r) -> (CInt -> CInt -> CInt -> CInt -> Ptr a -> f) -> IO r