LambdaCube/GL/HMatrix.hs


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67

{-# 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)

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
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
-}