objdemo: pass view matrix from haskell.

1 files changed, 49 insertions, 0 deletions

diff --git a/LambdaCube/GL/HMatrix.hs b/LambdaCube/GL/HMatrix.hs
new file mode 100644
index 0000000..ff5e7a7
--- /dev/null
+++ b/LambdaCube/GL/HMatrix.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module LambdaCube.GL.HMatrix where
+
+import GHC.TypeLits
+
+import LambdaCube.GL.Uniform
+import Numeric.LinearAlgebra
+import Numeric.LinearAlgebra.Devel
+
+import Graphics.Rendering.OpenGL.GL (GLboolean)
+
+instance Uniformable (Matrix Float) where
+    uniformContexts _ = contexts floatMatrices
+
+instance (KnownNat r, KnownNat c) => IsUniform (Matrix Float) (UMatrix r c Float) where
+    marshalUniform abi mat = case matrixDimensions abi of
+        (r,c) | fromIntegral (natVal r) /= rows mat -> Nothing
+              | fromIntegral (natVal c) /= cols mat -> Nothing
+        _ -> let isRowOrder = case orderOf mat of
+                        RowMajor    -> 1 :: GLboolean
+                        ColumnMajor -> 0 :: GLboolean
+             in Just $ MarshalUMatrix
+                     $ \f -> apply mat (\ptr -> f 1 isRowOrder ptr) (\r c sr sc ptr -> 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
+amat x f g = unsafeWith (xdat x) (f . g r c sr sc)
+  where
+    r  = fi (rows x)
+    c  = fi (cols x)
+    sr = fi (xRow x)
+    sc = fi (xCol x)
+
+
+apply (0 :: Matrix Float)
+  :: (b -> IO r)
+     -> (Foreign.C.Types.CInt
+     -> Foreign.C.Types.CInt
+     -> Foreign.C.Types.CInt
+     -> Foreign.C.Types.CInt
+     -> GHC.Ptr.Ptr Float
+     -> b)
+     -> IO r
+-}