diff options
-rw-r--r-- | LambdaCube/GL/HMatrix.hs | 18 |
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 | |||
24 | in Just $ MarshalUMatrix | 24 | in Just $ MarshalUMatrix |
25 | $ \f -> apply mat (\ptr -> f 1 isRowOrder ptr) (\r c sr sc ptr -> ptr) | 25 | $ \f -> apply mat (\ptr -> f 1 isRowOrder ptr) (\r c sr sc ptr -> ptr) |
26 | 26 | ||
27 | instance Uniformable (Vector Float) where | ||
28 | uniformContexts _ = contexts $ do | ||
29 | supports TypeFloat | ||
30 | supports TypeV2F | ||
31 | supports TypeV3F | ||
32 | supports TypeV4F | ||
33 | |||
34 | instance KnownNat n => IsUniform (Vector Float) (USimple n Float) where | ||
35 | marshalUniform abi vec | ||
36 | | natVal (vectorLength abi) /= fromIntegral (size vec) = Nothing | ||
37 | | otherwise = Just $ MarshalUSimple | ||
38 | $ \f -> apply vec (\ptr -> f 1 ptr) (\n ptr -> ptr) | ||
39 | |||
27 | {- | 40 | {- |
28 | 41 | ||
42 | -- C-Haskell vector adapter | ||
43 | {-# INLINE avec #-} | ||
44 | avec :: Storable a => Vector a -> (f -> IO r) -> ((CInt -> Ptr a -> f) -> IO r) | ||
45 | avec v f g = unsafeWith v $ \ptr -> f (g (fromIntegral (Vector.length v)) ptr) | ||
46 | |||
29 | -- apply :: Storable a => Matrix a -> (f -> IO r) -> (CInt -> CInt -> CInt -> CInt -> Ptr a -> f) -> IO r | 47 | -- apply :: Storable a => Matrix a -> (f -> IO r) -> (CInt -> CInt -> CInt -> CInt -> Ptr a -> f) -> IO r |
30 | {-# INLINE amat #-} | 48 | {-# INLINE amat #-} |
31 | amat :: Storable a => Matrix a -> (f -> IO r) -> (CInt -> CInt -> CInt -> CInt -> Ptr a -> f) -> IO r | 49 | amat :: Storable a => Matrix a -> (f -> IO r) -> (CInt -> CInt -> CInt -> CInt -> Ptr a -> f) -> IO r |