summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--examples/Hello.hs12
-rw-r--r--examples/HelloJson.hs12
-rw-r--r--lambdacube-gl.cabal7
-rw-r--r--src/LambdaCube/GL.hs13
-rw-r--r--src/LambdaCube/GL/Backend.hs7
-rw-r--r--src/LambdaCube/GL/Data.hs5
-rw-r--r--src/LambdaCube/GL/Input.hs56
-rw-r--r--src/LambdaCube/GL/Mesh.hs168
-rw-r--r--src/LambdaCube/GL/Type.hs47
-rw-r--r--src/LambdaCube/GL/Util.hs5
10 files changed, 104 insertions, 228 deletions
diff --git a/examples/Hello.hs b/examples/Hello.hs
index 1dfc547..89553d0 100644
--- a/examples/Hello.hs
+++ b/examples/Hello.hs
@@ -1,7 +1,7 @@
1{-# LANGUAGE PackageImports, LambdaCase, OverloadedStrings #-} 1{-# LANGUAGE PackageImports, LambdaCase, OverloadedStrings #-}
2import "GLFW-b" Graphics.UI.GLFW as GLFW 2import "GLFW-b" Graphics.UI.GLFW as GLFW
3import qualified Data.Map as Map 3import qualified Data.Map as Map
4import qualified Data.Vector.Storable as SV 4import qualified Data.Vector as V
5 5
6import LambdaCube.GL as LambdaCubeGL -- renderer 6import LambdaCube.GL as LambdaCubeGL -- renderer
7import LambdaCube.GL.Mesh as LambdaCubeGL 7import LambdaCube.GL.Mesh as LambdaCubeGL
@@ -69,21 +69,19 @@ main = do
69triangleA :: LambdaCubeGL.Mesh 69triangleA :: LambdaCubeGL.Mesh
70triangleA = Mesh 70triangleA = Mesh
71 { mAttributes = Map.fromList 71 { mAttributes = Map.fromList
72 [ ("position", A_V2F $ SV.fromList [V2 1 1, V2 1 (-1), V2 (-1) (-1)]) 72 [ ("position", A_V2F $ V.fromList [V2 1 1, V2 1 (-1), V2 (-1) (-1)])
73 , ("uv", A_V2F $ SV.fromList [V2 1 1, V2 0 1, V2 0 0]) 73 , ("uv", A_V2F $ V.fromList [V2 1 1, V2 0 1, V2 0 0])
74 ] 74 ]
75 , mPrimitive = P_Triangles 75 , mPrimitive = P_Triangles
76 , mGPUData = Nothing
77 } 76 }
78 77
79triangleB :: LambdaCubeGL.Mesh 78triangleB :: LambdaCubeGL.Mesh
80triangleB = Mesh 79triangleB = Mesh
81 { mAttributes = Map.fromList 80 { mAttributes = Map.fromList
82 [ ("position", A_V2F $ SV.fromList [V2 1 1, V2 (-1) (-1), V2 (-1) 1]) 81 [ ("position", A_V2F $ V.fromList [V2 1 1, V2 (-1) (-1), V2 (-1) 1])
83 , ("uv", A_V2F $ SV.fromList [V2 1 1, V2 0 0, V2 1 0]) 82 , ("uv", A_V2F $ V.fromList [V2 1 1, V2 0 0, V2 1 0])
84 ] 83 ]
85 , mPrimitive = P_Triangles 84 , mPrimitive = P_Triangles
86 , mGPUData = Nothing
87 } 85 }
88 86
89initWindow :: String -> Int -> Int -> IO Window 87initWindow :: String -> Int -> Int -> IO Window
diff --git a/examples/HelloJson.hs b/examples/HelloJson.hs
index 45821f7..081fd93 100644
--- a/examples/HelloJson.hs
+++ b/examples/HelloJson.hs
@@ -1,7 +1,7 @@
1{-# LANGUAGE PackageImports, LambdaCase, OverloadedStrings #-} 1{-# LANGUAGE PackageImports, LambdaCase, OverloadedStrings #-}
2import "GLFW-b" Graphics.UI.GLFW as GLFW 2import "GLFW-b" Graphics.UI.GLFW as GLFW
3import qualified Data.Map as Map 3import qualified Data.Map as Map
4import qualified Data.Vector.Storable as SV 4import qualified Data.Vector as V
5 5
6import LambdaCube.GL as LambdaCubeGL -- renderer 6import LambdaCube.GL as LambdaCubeGL -- renderer
7import LambdaCube.GL.Mesh as LambdaCubeGL 7import LambdaCube.GL.Mesh as LambdaCubeGL
@@ -67,21 +67,19 @@ main = do
67triangleA :: LambdaCubeGL.Mesh 67triangleA :: LambdaCubeGL.Mesh
68triangleA = Mesh 68triangleA = Mesh
69 { mAttributes = Map.fromList 69 { mAttributes = Map.fromList
70 [ ("position", A_V2F $ SV.fromList [V2 1 1, V2 1 (-1), V2 (-1) (-1)]) 70 [ ("position", A_V2F $ V.fromList [V2 1 1, V2 1 (-1), V2 (-1) (-1)])
71 , ("uv", A_V2F $ SV.fromList [V2 1 1, V2 0 1, V2 0 0]) 71 , ("uv", A_V2F $ V.fromList [V2 1 1, V2 0 1, V2 0 0])
72 ] 72 ]
73 , mPrimitive = P_Triangles 73 , mPrimitive = P_Triangles
74 , mGPUData = Nothing
75 } 74 }
76 75
77triangleB :: LambdaCubeGL.Mesh 76triangleB :: LambdaCubeGL.Mesh
78triangleB = Mesh 77triangleB = Mesh
79 { mAttributes = Map.fromList 78 { mAttributes = Map.fromList
80 [ ("position", A_V2F $ SV.fromList [V2 1 1, V2 (-1) (-1), V2 (-1) 1]) 79 [ ("position", A_V2F $ V.fromList [V2 1 1, V2 (-1) (-1), V2 (-1) 1])
81 , ("uv", A_V2F $ SV.fromList [V2 1 1, V2 0 0, V2 1 0]) 80 , ("uv", A_V2F $ V.fromList [V2 1 1, V2 0 0, V2 1 0])
82 ] 81 ]
83 , mPrimitive = P_Triangles 82 , mPrimitive = P_Triangles
84 , mGPUData = Nothing
85 } 83 }
86 84
87initWindow :: String -> Int -> Int -> IO Window 85initWindow :: String -> Int -> Int -> IO Window
diff --git a/lambdacube-gl.cabal b/lambdacube-gl.cabal
index 6c05a40..7e06a27 100644
--- a/lambdacube-gl.cabal
+++ b/lambdacube-gl.cabal
@@ -1,5 +1,5 @@
1name: lambdacube-gl 1name: lambdacube-gl
2version: 0.3.0.0 2version: 0.4.0.0
3-- synopsis: 3-- synopsis:
4-- description: 4-- description:
5homepage: lambdacube3d.com 5homepage: lambdacube3d.com
@@ -31,9 +31,8 @@ library
31 bytestring >=0.10 && <0.11, 31 bytestring >=0.10 && <0.11,
32 vector >=0.11 && <0.12, 32 vector >=0.11 && <0.12,
33 vector-algorithms >=0.7 && <0.8, 33 vector-algorithms >=0.7 && <0.8,
34 binary >=0.7 && <0.8, 34 JuicyPixels >=3.2.7 && <3.3,
35 JuicyPixels >=3.2.6.4 && <3.3,
36 OpenGLRaw >=3.0 && <3.1, 35 OpenGLRaw >=3.0 && <3.1,
37 lambdacube-ir == 0.1.* 36 lambdacube-ir == 0.2.*
38 hs-source-dirs: src 37 hs-source-dirs: src
39 default-language: Haskell2010 38 default-language: Haskell2010
diff --git a/src/LambdaCube/GL.hs b/src/LambdaCube/GL.hs
index 258d2ba..2b5c814 100644
--- a/src/LambdaCube/GL.hs
+++ b/src/LambdaCube/GL.hs
@@ -1,4 +1,6 @@
1module LambdaCube.GL ( 1module LambdaCube.GL (
2 -- Schema
3 module LambdaCube.PipelineSchema,
2 -- IR 4 -- IR
3 V2(..),V3(..),V4(..), 5 V2(..),V3(..),V4(..),
4 -- Array, Buffer, Texture 6 -- Array, Buffer, Texture
@@ -9,7 +11,6 @@ module LambdaCube.GL (
9 IndexStream(..), 11 IndexStream(..),
10 Stream(..), 12 Stream(..),
11 StreamSetter, 13 StreamSetter,
12 StreamType(..),
13 FetchPrimitive(..), 14 FetchPrimitive(..),
14 InputType(..), 15 InputType(..),
15 Primitive(..), 16 Primitive(..),
@@ -20,20 +21,20 @@ module LambdaCube.GL (
20 sizeOfArrayType, 21 sizeOfArrayType,
21 toStreamType, 22 toStreamType,
22 compileBuffer, 23 compileBuffer,
24 disposeBuffer,
23 updateBuffer, 25 updateBuffer,
24 bufferSize, 26 bufferSize,
25 arraySize, 27 arraySize,
26 arrayType, 28 arrayType,
27 uploadTexture2DToGPU, 29 uploadTexture2DToGPU,
28 uploadTexture2DToGPU', 30 uploadTexture2DToGPU',
31 disposeTexture,
29 32
30 -- GL: Renderer, Storage, Object 33 -- GL: Renderer, Storage, Object
31 GLUniformName, 34 GLUniformName,
32 GLRenderer, 35 GLRenderer,
33 GLStorage, 36 GLStorage,
34 Object, 37 Object,
35 PipelineSchema(..),
36 ObjectArraySchema(..),
37 schema, 38 schema,
38 schemaFromPipeline, 39 schemaFromPipeline,
39 allocRenderer, 40 allocRenderer,
@@ -96,5 +97,7 @@ import LambdaCube.GL.Type
96import LambdaCube.GL.Backend 97import LambdaCube.GL.Backend
97import LambdaCube.GL.Data 98import LambdaCube.GL.Data
98import LambdaCube.GL.Input 99import LambdaCube.GL.Input
99import IR 100import LambdaCube.IR
100import Linear 101import LambdaCube.Linear
102import LambdaCube.PipelineSchema
103import LambdaCube.PipelineSchemaUtil
diff --git a/src/LambdaCube/GL/Backend.hs b/src/LambdaCube/GL/Backend.hs
index 677e925..bb45fbd 100644
--- a/src/LambdaCube/GL/Backend.hs
+++ b/src/LambdaCube/GL/Backend.hs
@@ -24,9 +24,10 @@ import Foreign
24import Foreign.C.String 24import Foreign.C.String
25 25
26-- LC IR imports 26-- LC IR imports
27import Linear 27import LambdaCube.PipelineSchema
28import IR hiding (streamType) 28import LambdaCube.Linear
29import qualified IR as IR 29import LambdaCube.IR hiding (streamType)
30import qualified LambdaCube.IR as IR
30 31
31import LambdaCube.GL.Type 32import LambdaCube.GL.Type
32import LambdaCube.GL.Util 33import LambdaCube.GL.Util
diff --git a/src/LambdaCube/GL/Data.hs b/src/LambdaCube/GL/Data.hs
index 4ebe33c..3e0f963 100644
--- a/src/LambdaCube/GL/Data.hs
+++ b/src/LambdaCube/GL/Data.hs
@@ -23,6 +23,9 @@ import LambdaCube.GL.Type
23import LambdaCube.GL.Util 23import LambdaCube.GL.Util
24 24
25-- Buffer 25-- Buffer
26disposeBuffer :: Buffer -> IO ()
27disposeBuffer (Buffer _ bo) = withArray [bo] $ glDeleteBuffers 1
28
26compileBuffer :: [Array] -> IO Buffer 29compileBuffer :: [Array] -> IO Buffer
27compileBuffer arrs = do 30compileBuffer arrs = do
28 let calcDesc (offset,setters,descs) (Array arrType cnt setter) = 31 let calcDesc (offset,setters,descs) (Array arrType cnt setter) =
@@ -55,6 +58,8 @@ arrayType :: Buffer -> Int -> ArrayType
55arrayType buf arrIdx = arrType $! bufArrays buf V.! arrIdx 58arrayType buf arrIdx = arrType $! bufArrays buf V.! arrIdx
56 59
57-- Texture 60-- Texture
61disposeTexture :: TextureData -> IO ()
62disposeTexture (TextureData to) = withArray [to] $ glDeleteTextures 1
58 63
59-- FIXME: Temporary implemenation 64-- FIXME: Temporary implemenation
60uploadTexture2DToGPU :: DynamicImage -> IO TextureData 65uploadTexture2DToGPU :: DynamicImage -> IO TextureData
diff --git a/src/LambdaCube/GL/Input.hs b/src/LambdaCube/GL/Input.hs
index 7e4ba74..9ceb35f 100644
--- a/src/LambdaCube/GL/Input.hs
+++ b/src/LambdaCube/GL/Input.hs
@@ -1,4 +1,4 @@
1{-# LANGUAGE FlexibleContexts #-} 1{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances #-}
2module LambdaCube.GL.Input where 2module LambdaCube.GL.Input where
3 3
4import Control.Applicative 4import Control.Applicative
@@ -22,12 +22,13 @@ import qualified Data.ByteString.Char8 as SB
22 22
23import Graphics.GL.Core33 23import Graphics.GL.Core33
24 24
25import IR as IR 25import LambdaCube.IR as IR
26import Linear as IR 26import LambdaCube.Linear as IR
27import LambdaCube.PipelineSchema
27import LambdaCube.GL.Type as T 28import LambdaCube.GL.Type as T
28import LambdaCube.GL.Util 29import LambdaCube.GL.Util
29 30
30import qualified IR as IR 31import qualified LambdaCube.IR as IR
31 32
32schemaFromPipeline :: IR.Pipeline -> PipelineSchema 33schemaFromPipeline :: IR.Pipeline -> PipelineSchema
33schemaFromPipeline a = PipelineSchema (Map.fromList sl) (foldl Map.union Map.empty ul) 34schemaFromPipeline a = PipelineSchema (Map.fromList sl) (foldl Map.union Map.empty ul)
@@ -392,29 +393,38 @@ uniformFTexture2D n is = case Map.lookup n is of
392 Just (SFTexture2D fun) -> fun 393 Just (SFTexture2D fun) -> fun
393 _ -> nullSetter n "FTexture2D" 394 _ -> nullSetter n "FTexture2D"
394 395
395a @: b = tell [(a,b)]
396defObjectArray n p m = mapM_ tell [PipelineSchema (Map.singleton n $ ObjectArraySchema p $ Map.singleton a t) mempty | (a,t) <- execWriter m]
397defUniforms m = tell $ PipelineSchema mempty $ Map.fromList $ execWriter m
398makeSchema a = execWriter a :: PipelineSchema
399
400unionObjectArraySchema (ObjectArraySchema a1 b1) (ObjectArraySchema a2 b2) =
401 ObjectArraySchema (if a1 == a2 then a1 else error $ "object array schema primitive mismatch " ++ show (a1,a2))
402 (Map.unionWith (\a b -> if a == b then a else error $ "object array schema attribute type mismatch " ++ show (a,b)) b1 b2)
403
404instance Monoid PipelineSchema where
405 mempty = PipelineSchema mempty mempty
406 mappend (PipelineSchema a1 b1) (PipelineSchema a2 b2) =
407 PipelineSchema (Map.unionWith unionObjectArraySchema a1 a2) (Map.unionWith (\a b -> if a == b then a else error $ "schema type mismatch " ++ show (a,b)) b1 b2)
408
409type UniM = Writer [GLStorage -> IO ()] 396type UniM = Writer [GLStorage -> IO ()]
410 397
411class UniformSetter a where 398class UniformSetter a where
412 (@=) :: GLUniformName -> IO a -> UniM () 399 (@=) :: GLUniformName -> IO a -> UniM ()
413 400
414instance UniformSetter Float where 401setUniM setUni n act = tell [\s -> let f = setUni n (uniformSetter s) in f =<< act]
415 n @= act = tell [\s -> let f = uniformFloat n (uniformSetter s) in f =<< act] 402
416 403instance UniformSetter Bool where (@=) = setUniM uniformBool
417instance UniformSetter TextureData where 404instance UniformSetter V2B where (@=) = setUniM uniformV2B
418 n @= act = tell [\s -> let f = uniformFTexture2D n (uniformSetter s) in f =<< act] 405instance UniformSetter V3B where (@=) = setUniM uniformV3B
406instance UniformSetter V4B where (@=) = setUniM uniformV4B
407instance UniformSetter Word32 where (@=) = setUniM uniformWord
408instance UniformSetter V2U where (@=) = setUniM uniformV2U
409instance UniformSetter V3U where (@=) = setUniM uniformV3U
410instance UniformSetter V4U where (@=) = setUniM uniformV4U
411instance UniformSetter Int32 where (@=) = setUniM uniformInt
412instance UniformSetter V2I where (@=) = setUniM uniformV2I
413instance UniformSetter V3I where (@=) = setUniM uniformV3I
414instance UniformSetter V4I where (@=) = setUniM uniformV4I
415instance UniformSetter Float where (@=) = setUniM uniformFloat
416instance UniformSetter V2F where (@=) = setUniM uniformV2F
417instance UniformSetter V3F where (@=) = setUniM uniformV3F
418instance UniformSetter V4F where (@=) = setUniM uniformV4F
419instance UniformSetter M22F where (@=) = setUniM uniformM22F
420instance UniformSetter M23F where (@=) = setUniM uniformM23F
421instance UniformSetter M24F where (@=) = setUniM uniformM24F
422instance UniformSetter M32F where (@=) = setUniM uniformM32F
423instance UniformSetter M33F where (@=) = setUniM uniformM33F
424instance UniformSetter M34F where (@=) = setUniM uniformM34F
425instance UniformSetter M42F where (@=) = setUniM uniformM42F
426instance UniformSetter M43F where (@=) = setUniM uniformM43F
427instance UniformSetter M44F where (@=) = setUniM uniformM44F
428instance UniformSetter TextureData where (@=) = setUniM uniformFTexture2D
419 429
420updateUniforms storage m = sequence_ $ let l = map ($ storage) $ execWriter m in l 430updateUniforms storage m = sequence_ $ let l = map ($ storage) $ execWriter m in l
diff --git a/src/LambdaCube/GL/Mesh.hs b/src/LambdaCube/GL/Mesh.hs
index f8521dd..0c56f26 100644
--- a/src/LambdaCube/GL/Mesh.hs
+++ b/src/LambdaCube/GL/Mesh.hs
@@ -1,20 +1,19 @@
1{-# LANGUAGE TupleSections #-} 1{-# LANGUAGE TupleSections, RecordWildCards #-}
2module LambdaCube.GL.Mesh ( 2module LambdaCube.GL.Mesh (
3 loadMesh',
4 loadMesh,
5 saveMesh,
6 addMeshToObjectArray, 3 addMeshToObjectArray,
7 uploadMeshToGPU, 4 uploadMeshToGPU,
5 disposeMesh,
8 updateMesh, 6 updateMesh,
9 Mesh(..), 7 Mesh(..),
10 MeshPrimitive(..), 8 MeshPrimitive(..),
11 MeshAttribute(..), 9 MeshAttribute(..),
12 GPUData 10 GPUMesh,
11 meshData
13) where 12) where
14 13
14import Data.Maybe
15import Control.Applicative 15import Control.Applicative
16import Control.Monad 16import Control.Monad
17import Data.Binary
18import Foreign.Ptr 17import Foreign.Ptr
19import Data.Int 18import Data.Int
20import Foreign.Storable 19import Foreign.Storable
@@ -22,80 +21,51 @@ import Foreign.Marshal.Utils
22import System.IO.Unsafe 21import System.IO.Unsafe
23import Data.Map (Map) 22import Data.Map (Map)
24import qualified Data.Map as Map 23import qualified Data.Map as Map
25import qualified Data.Vector.Storable as V 24import qualified Data.Vector as V
25import qualified Data.Vector.Storable as SV
26import qualified Data.Vector.Storable.Mutable as MV 26import qualified Data.Vector.Storable.Mutable as MV
27import qualified Data.ByteString.Char8 as SB 27import qualified Data.ByteString.Char8 as SB
28import qualified Data.ByteString.Lazy as LB 28import qualified Data.ByteString.Lazy as LB
29 29
30import LambdaCube.GL 30import LambdaCube.GL
31import LambdaCube.GL.Type as T 31import LambdaCube.GL.Type as T
32import IR as IR 32import LambdaCube.IR as IR
33import Linear as IR 33import LambdaCube.Linear as IR
34 34import LambdaCube.Mesh
35fileVersion :: Int32
36fileVersion = 1
37
38data MeshAttribute
39 = A_Float (V.Vector Float)
40 | A_V2F (V.Vector V2F)
41 | A_V3F (V.Vector V3F)
42 | A_V4F (V.Vector V4F)
43 | A_M22F (V.Vector M22F)
44 | A_M33F (V.Vector M33F)
45 | A_M44F (V.Vector M44F)
46 | A_Int (V.Vector Int32)
47 | A_Word (V.Vector Word32)
48
49data MeshPrimitive
50 = P_Points
51 | P_TriangleStrip
52 | P_Triangles
53 | P_TriangleStripI (V.Vector Int32)
54 | P_TrianglesI (V.Vector Int32)
55
56data Mesh
57 = Mesh
58 { mAttributes :: Map String MeshAttribute
59 , mPrimitive :: MeshPrimitive
60 , mGPUData :: Maybe GPUData
61 }
62 35
63data GPUData 36data GPUData
64 = GPUData 37 = GPUData
65 { dPrimitive :: Primitive 38 { dPrimitive :: Primitive
66 , dStreams :: Map String (Stream Buffer) 39 , dStreams :: Map String (Stream Buffer)
67 , dIndices :: Maybe (IndexStream Buffer) 40 , dIndices :: Maybe (IndexStream Buffer)
41 , dBuffers :: [Buffer]
68 } 42 }
69 43
70loadMesh' :: String -> IO Mesh 44data GPUMesh
71loadMesh' n = decode <$> LB.readFile n 45 = GPUMesh
72 46 { meshData :: Mesh
73loadMesh :: String -> IO Mesh 47 , gpuData :: GPUData
74loadMesh n = uploadMeshToGPU =<< loadMesh' n 48 }
75
76saveMesh :: String -> Mesh -> IO ()
77saveMesh n m = LB.writeFile n (encode m)
78 49
79addMeshToObjectArray :: GLStorage -> String -> [String] -> Mesh -> IO Object 50addMeshToObjectArray :: GLStorage -> String -> [String] -> GPUMesh -> IO Object
80addMeshToObjectArray input slotName objUniNames (Mesh _ _ (Just (GPUData prim streams indices))) = do 51addMeshToObjectArray input slotName objUniNames (GPUMesh _ (GPUData prim streams indices _)) = do
81 -- select proper attributes 52 -- select proper attributes
82 let Just (ObjectArraySchema slotPrim slotStreams) = Map.lookup slotName $! objectArrays $! schema input 53 let Just (ObjectArraySchema slotPrim slotStreams) = Map.lookup slotName $! objectArrays $! schema input
83 filterStream n _ = Map.member n slotStreams 54 filterStream n _ = Map.member n slotStreams
84 addObject input slotName prim indices (Map.filterWithKey filterStream streams) objUniNames 55 addObject input slotName prim indices (Map.filterWithKey filterStream streams) objUniNames
85addMeshToObjectArray _ _ _ _ = fail "addMeshToObjectArray: only compiled mesh with GPUData is supported"
86 56
87withV w a f = w a (\p -> f $ castPtr p) 57withV w a f = w a (\p -> f $ castPtr p)
88 58
89meshAttrToArray :: MeshAttribute -> Array 59meshAttrToArray :: MeshAttribute -> Array
90meshAttrToArray (A_Float v) = Array ArrFloat (1 * V.length v) $ withV V.unsafeWith v 60meshAttrToArray (A_Float v) = Array ArrFloat (1 * V.length v) $ withV SV.unsafeWith $ V.convert v
91meshAttrToArray (A_V2F v) = Array ArrFloat (2 * V.length v) $ withV V.unsafeWith v 61meshAttrToArray (A_V2F v) = Array ArrFloat (2 * V.length v) $ withV SV.unsafeWith $ V.convert v
92meshAttrToArray (A_V3F v) = Array ArrFloat (3 * V.length v) $ withV V.unsafeWith v 62meshAttrToArray (A_V3F v) = Array ArrFloat (3 * V.length v) $ withV SV.unsafeWith $ V.convert v
93meshAttrToArray (A_V4F v) = Array ArrFloat (4 * V.length v) $ withV V.unsafeWith v 63meshAttrToArray (A_V4F v) = Array ArrFloat (4 * V.length v) $ withV SV.unsafeWith $ V.convert v
94meshAttrToArray (A_M22F v) = Array ArrFloat (4 * V.length v) $ withV V.unsafeWith v 64meshAttrToArray (A_M22F v) = Array ArrFloat (4 * V.length v) $ withV SV.unsafeWith $ V.convert v
95meshAttrToArray (A_M33F v) = Array ArrFloat (9 * V.length v) $ withV V.unsafeWith v 65meshAttrToArray (A_M33F v) = Array ArrFloat (9 * V.length v) $ withV SV.unsafeWith $ V.convert v
96meshAttrToArray (A_M44F v) = Array ArrFloat (16 * V.length v) $ withV V.unsafeWith v 66meshAttrToArray (A_M44F v) = Array ArrFloat (16 * V.length v) $ withV SV.unsafeWith $ V.convert v
97meshAttrToArray (A_Int v) = Array ArrInt32 (1 * V.length v) $ withV V.unsafeWith v 67meshAttrToArray (A_Int v) = Array ArrInt32 (1 * V.length v) $ withV SV.unsafeWith $ V.convert v
98meshAttrToArray (A_Word v) = Array ArrWord32 (1 * V.length v) $ withV V.unsafeWith v 68meshAttrToArray (A_Word v) = Array ArrWord32 (1 * V.length v) $ withV SV.unsafeWith $ V.convert v
99 69
100meshAttrToStream :: Buffer -> Int -> MeshAttribute -> Stream Buffer 70meshAttrToStream :: Buffer -> Int -> MeshAttribute -> Stream Buffer
101meshAttrToStream b i (A_Float v) = Stream Attribute_Float b i 0 (V.length v) 71meshAttrToStream b i (A_Float v) = Stream Attribute_Float b i 0 (V.length v)
@@ -108,8 +78,8 @@ meshAttrToStream b i (A_M44F v) = Stream Attribute_M44F b i 0 (V.length v)
108meshAttrToStream b i (A_Int v) = Stream Attribute_Int b i 0 (V.length v) 78meshAttrToStream b i (A_Int v) = Stream Attribute_Int b i 0 (V.length v)
109meshAttrToStream b i (A_Word v) = Stream Attribute_Word b i 0 (V.length v) 79meshAttrToStream b i (A_Word v) = Stream Attribute_Word b i 0 (V.length v)
110 80
111updateMesh :: Mesh -> [(String,MeshAttribute)] -> Maybe MeshPrimitive -> IO () 81updateMesh :: GPUMesh -> [(String,MeshAttribute)] -> Maybe MeshPrimitive -> IO ()
112updateMesh (Mesh dMA dMP (Just (GPUData _ dS dI))) al mp = do 82updateMesh (GPUMesh (Mesh dMA dMP) (GPUData _ dS dI _)) al mp = do
113 -- check type match 83 -- check type match
114 let arrayChk (Array t1 s1 _) (Array t2 s2 _) = t1 == t2 && s1 == s2 84 let arrayChk (Array t1 s1 _) (Array t2 s2 _) = t1 == t2 && s1 == s2
115 ok = and [Map.member n dMA && arrayChk (meshAttrToArray a1) (meshAttrToArray a2) | (n,a1) <- al, let Just a2 = Map.lookup n dMA] 85 ok = and [Map.member n dMA && arrayChk (meshAttrToArray a1) (meshAttrToArray a2) | (n,a1) <- al, let Just a2 = Map.lookup n dMA]
@@ -129,10 +99,10 @@ updateMesh (Mesh dMA dMP (Just (GPUData _ dS dI))) al mp = do
129 (a,b) -> a == b 99 (a,b) -> a == b
130-} 100-}
131 101
132uploadMeshToGPU :: Mesh -> IO Mesh 102uploadMeshToGPU :: Mesh -> IO GPUMesh
133uploadMeshToGPU (Mesh attrs mPrim Nothing) = do 103uploadMeshToGPU mesh@(Mesh attrs mPrim) = do
134 let mkIndexBuf v = do 104 let mkIndexBuf v = do
135 iBuf <- compileBuffer [Array ArrWord32 (V.length v) $ withV V.unsafeWith v] 105 iBuf <- compileBuffer [Array ArrWord32 (V.length v) $ withV SV.unsafeWith $ V.convert v]
136 return $! Just $! IndexStream iBuf 0 0 (V.length v) 106 return $! Just $! IndexStream iBuf 0 0 (V.length v)
137 vBuf <- compileBuffer [meshAttrToArray a | a <- Map.elems attrs] 107 vBuf <- compileBuffer [meshAttrToArray a | a <- Map.elems attrs]
138 (indices,prim) <- case mPrim of 108 (indices,prim) <- case mPrim of
@@ -142,75 +112,7 @@ uploadMeshToGPU (Mesh attrs mPrim Nothing) = do
142 P_TriangleStripI v -> (,TriangleStrip) <$> mkIndexBuf v 112 P_TriangleStripI v -> (,TriangleStrip) <$> mkIndexBuf v
143 P_TrianglesI v -> (,TriangleList) <$> mkIndexBuf v 113 P_TrianglesI v -> (,TriangleList) <$> mkIndexBuf v
144 let streams = Map.fromList $! zipWith (\i (n,a) -> (n,meshAttrToStream vBuf i a)) [0..] (Map.toList attrs) 114 let streams = Map.fromList $! zipWith (\i (n,a) -> (n,meshAttrToStream vBuf i a)) [0..] (Map.toList attrs)
145 gpuData = GPUData prim streams indices 115 return $! GPUMesh mesh (GPUData prim streams indices (vBuf:[iBuf | IndexStream iBuf _ _ _ <- maybeToList indices]))
146 return $! Mesh attrs mPrim (Just gpuData)
147
148uploadMeshToGPU mesh = return mesh
149
150sblToV :: Storable a => [SB.ByteString] -> V.Vector a
151sblToV ls = v
152 where
153 offs o (s:xs) = (o,s):offs (o + SB.length s) xs
154 offs _ [] = []
155 cnt = sum (map SB.length ls) `div` (sizeOf $ V.head v)
156 v = unsafePerformIO $ do
157 mv <- MV.new cnt
158 MV.unsafeWith mv $ \dst -> forM_ (offs 0 ls) $ \(o,s) ->
159 SB.useAsCStringLen s $ \(src,len) -> moveBytes (plusPtr dst o) src len
160 V.unsafeFreeze mv
161
162vToSB :: Storable a => V.Vector a -> SB.ByteString
163vToSB v = unsafePerformIO $ do
164 let len = V.length v * sizeOf (V.head v)
165 V.unsafeWith v $ \p -> SB.packCStringLen (castPtr p,len)
166
167instance Storable a => Binary (V.Vector a) where
168 put v = put $ vToSB v
169 get = do s <- get ; return $ sblToV [s]
170
171instance Binary MeshAttribute where
172 put (A_Float a) = putWord8 0 >> put a
173 put (A_V2F a) = putWord8 1 >> put a
174 put (A_V3F a) = putWord8 2 >> put a
175 put (A_V4F a) = putWord8 3 >> put a
176 put (A_M22F a) = putWord8 4 >> put a
177 put (A_M33F a) = putWord8 5 >> put a
178 put (A_M44F a) = putWord8 6 >> put a
179 put (A_Int a) = putWord8 7 >> put a
180 put (A_Word a) = putWord8 8 >> put a
181 get = do
182 tag_ <- getWord8
183 case tag_ of
184 0 -> A_Float <$> get
185 1 -> A_V2F <$> get
186 2 -> A_V3F <$> get
187 3 -> A_V4F <$> get
188 4 -> A_M22F <$> get
189 5 -> A_M33F <$> get
190 6 -> A_M44F <$> get
191 7 -> A_Int <$> get
192 8 -> A_Word <$> get
193 _ -> fail "no parse"
194
195instance Binary MeshPrimitive where
196 put P_Points = putWord8 0
197 put P_TriangleStrip = putWord8 1
198 put P_Triangles = putWord8 2
199 put (P_TriangleStripI a) = putWord8 3 >> put a
200 put (P_TrianglesI a) = putWord8 4 >> put a
201 get = do
202 tag_ <- getWord8
203 case tag_ of
204 0 -> return P_Points
205 1 -> return P_TriangleStrip
206 2 -> return P_Triangles
207 3 -> P_TriangleStripI <$> get
208 4 -> P_TrianglesI <$> get
209 _ -> fail "no parse"
210 116
211instance Binary Mesh where 117disposeMesh :: GPUMesh -> IO ()
212 put (Mesh a b _) = put (Map.toList a) >> put b 118disposeMesh (GPUMesh _ GPUData{..}) = mapM_ disposeBuffer dBuffers
213 get = do
214 a <- get
215 b <- get
216 return $! Mesh (Map.fromList a) b Nothing
diff --git a/src/LambdaCube/GL/Type.hs b/src/LambdaCube/GL/Type.hs
index 8f4bdd7..376fdf1 100644
--- a/src/LambdaCube/GL/Type.hs
+++ b/src/LambdaCube/GL/Type.hs
@@ -14,8 +14,9 @@ import Data.ByteString
14 14
15import Graphics.GL.Core33 15import Graphics.GL.Core33
16 16
17import Linear 17import LambdaCube.Linear
18import IR 18import LambdaCube.IR
19import LambdaCube.PipelineSchema
19 20
20type GLUniformName = ByteString 21type GLUniformName = ByteString
21 22
@@ -66,21 +67,6 @@ data ArrayDesc
66 - independent from pipeline 67 - independent from pipeline
67 - per object features: enable/disable visibility, set render ordering 68 - per object features: enable/disable visibility, set render ordering
68-} 69-}
69
70data ObjectArraySchema
71 = ObjectArraySchema
72 { primitive :: FetchPrimitive
73 , attributes :: Map String StreamType
74 }
75 deriving Show
76
77data PipelineSchema
78 = PipelineSchema
79 { objectArrays :: Map String ObjectArraySchema
80 , uniforms :: Map String InputType
81 }
82 deriving Show
83
84data GLUniform = forall a. Storable a => GLUniform !InputType !(IORef a) 70data GLUniform = forall a. Storable a => GLUniform !InputType !(IORef a)
85 71
86instance Show GLUniform where 72instance Show GLUniform where
@@ -322,33 +308,6 @@ sizeOfArrayType ArrHalf = 2
322data Array -- array type, element count (NOT byte size!), setter 308data Array -- array type, element count (NOT byte size!), setter
323 = Array ArrayType Int BufferSetter 309 = Array ArrayType Int BufferSetter
324 310
325-- dev hint: this should be InputType
326-- we restrict StreamType using type class
327-- subset of InputType, describes a stream type (in GPU side)
328data StreamType
329 = Attribute_Word
330 | Attribute_V2U
331 | Attribute_V3U
332 | Attribute_V4U
333 | Attribute_Int
334 | Attribute_V2I
335 | Attribute_V3I
336 | Attribute_V4I
337 | Attribute_Float
338 | Attribute_V2F
339 | Attribute_V3F
340 | Attribute_V4F
341 | Attribute_M22F
342 | Attribute_M23F
343 | Attribute_M24F
344 | Attribute_M32F
345 | Attribute_M33F
346 | Attribute_M34F
347 | Attribute_M42F
348 | Attribute_M43F
349 | Attribute_M44F
350 deriving (Show,Eq,Ord)
351
352toStreamType :: InputType -> Maybe StreamType 311toStreamType :: InputType -> Maybe StreamType
353toStreamType Word = Just Attribute_Word 312toStreamType Word = Just Attribute_Word
354toStreamType V2U = Just Attribute_V2U 313toStreamType V2U = Just Attribute_V2U
diff --git a/src/LambdaCube/GL/Util.hs b/src/LambdaCube/GL/Util.hs
index c8449eb..28ab935 100644
--- a/src/LambdaCube/GL/Util.hs
+++ b/src/LambdaCube/GL/Util.hs
@@ -43,8 +43,9 @@ import Data.Map (Map)
43import qualified Data.Map as Map 43import qualified Data.Map as Map
44 44
45import Graphics.GL.Core33 45import Graphics.GL.Core33
46import Linear 46import LambdaCube.Linear
47import IR 47import LambdaCube.IR
48import LambdaCube.PipelineSchema
48import LambdaCube.GL.Type 49import LambdaCube.GL.Type
49 50
50setSampler :: GLint -> Int32 -> IO () 51setSampler :: GLint -> Int32 -> IO ()