diff options
Diffstat (limited to 'LambdaCube/GL')
-rw-r--r-- | LambdaCube/GL/HMatrix.hs | 18 |
1 files changed, 7 insertions, 11 deletions
diff --git a/LambdaCube/GL/HMatrix.hs b/LambdaCube/GL/HMatrix.hs index 127656e..026d5c1 100644 --- a/LambdaCube/GL/HMatrix.hs +++ b/LambdaCube/GL/HMatrix.hs | |||
@@ -1,27 +1,23 @@ | |||
1 | {-# LANGUAGE PatternSynonyms #-} | ||
2 | {-# LANGUAGE FlexibleInstances #-} | 1 | {-# LANGUAGE FlexibleInstances #-} |
3 | {-# LANGUAGE MultiParamTypeClasses #-} | 2 | {-# LANGUAGE MultiParamTypeClasses #-} |
4 | module LambdaCube.GL.HMatrix where | 3 | module LambdaCube.GL.HMatrix where |
5 | 4 | ||
6 | import GHC.TypeLits | 5 | import GHC.TypeLits |
7 | 6 | import LambdaCube.GL.Input.Type | |
8 | import LambdaCube.GL.Uniform | ||
9 | import Numeric.LinearAlgebra | 7 | import Numeric.LinearAlgebra |
10 | import Numeric.LinearAlgebra.Devel | 8 | import Numeric.LinearAlgebra.Devel |
11 | 9 | ||
12 | import Graphics.Rendering.OpenGL.GL (GLboolean) | ||
13 | |||
14 | instance Uniformable (Matrix Float) where | 10 | instance Uniformable (Matrix Float) where |
15 | uniformContexts _ = contexts floatMatrices | 11 | uniformContexts _ = contexts floatMatrices |
16 | 12 | ||
17 | instance (KnownNat r, KnownNat c) => IsUniform (Matrix Float) (UMatrix r c Float) where | 13 | instance (KnownNat r, KnownNat c) => GLData (Matrix Float) (GLMatrix r c Float) where |
18 | marshalUniform abi mat = case matrixDimensions abi of | 14 | marshalUniform abi mat = case matrixDimensions abi of |
19 | (r,c) | fromIntegral (natVal r) /= rows mat -> Nothing | 15 | (r,c) | fromIntegral (natVal r) /= rows mat -> Nothing |
20 | | fromIntegral (natVal c) /= cols mat -> Nothing | 16 | | fromIntegral (natVal c) /= cols mat -> Nothing |
21 | _ -> let isRowOrder = case orderOf mat of | 17 | _ -> let isRowOrder = case orderOf mat of |
22 | RowMajor -> 1 :: GLboolean | 18 | RowMajor -> 1 |
23 | ColumnMajor -> 0 :: GLboolean | 19 | ColumnMajor -> 0 |
24 | in Just $ MarshalUMatrix | 20 | in Just $ MarshalGLMatrix |
25 | $ \f -> apply mat (\ptr -> f 1 isRowOrder ptr) (\r c sr sc ptr -> ptr) | 21 | $ \f -> apply mat (\ptr -> f 1 isRowOrder ptr) (\r c sr sc ptr -> ptr) |
26 | 22 | ||
27 | instance Uniformable (Vector Float) where | 23 | instance Uniformable (Vector Float) where |
@@ -31,10 +27,10 @@ instance Uniformable (Vector Float) where | |||
31 | supports TypeV3F | 27 | supports TypeV3F |
32 | supports TypeV4F | 28 | supports TypeV4F |
33 | 29 | ||
34 | instance KnownNat n => IsUniform (Vector Float) (USimple n Float) where | 30 | instance KnownNat n => GLData (Vector Float) (GLVector n Float) where |
35 | marshalUniform abi vec | 31 | marshalUniform abi vec |
36 | | natVal (vectorLength abi) /= fromIntegral (size vec) = Nothing | 32 | | natVal (vectorLength abi) /= fromIntegral (size vec) = Nothing |
37 | | otherwise = Just $ MarshalUSimple | 33 | | otherwise = Just $ MarshalGLVector |
38 | $ \f -> apply vec (\ptr -> f 1 ptr) (\n ptr -> ptr) | 34 | $ \f -> apply vec (\ptr -> f 1 ptr) (\n ptr -> ptr) |
39 | 35 | ||
40 | {- | 36 | {- |