summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorCsaba Hruska <csaba.hruska@gmail.com>2016-01-10 15:00:47 +0100
committerCsaba Hruska <csaba.hruska@gmail.com>2016-01-10 15:00:47 +0100
commite936d3c32c17c0d00939893fa85996c3807ed3e7 (patch)
tree7df6bab6aa7e3004b3ae292559e8163c8f736bb5
parentb4206cca604b02450505176a4ba0798d7a490034 (diff)
initial getting started example: Hello
Diffstat
-rw-r--r--SampleIR.hs246
-rw-r--r--examples/Hello.hs135
-rw-r--r--tests/sampleIR.hs3
3 files changed, 135 insertions, 249 deletions
diff --git a/SampleIR.hs b/SampleIR.hs
deleted file mode 100644
index 4d13bbd..0000000
--- a/SampleIR.hs
+++ /dev/null
@@ -1,246 +0,0 @@
1{-# LANGUAGE OverloadedStrings, PackageImports, MonadComprehensions #-}
2module SampleIR where
3
4import "GLFW-b" Graphics.UI.GLFW as GLFW
5import Data.Monoid
6import Control.Monad
7import Control.Applicative
8import Data.Vect
9import qualified Data.Trie as T
10import qualified Data.Vector.Storable as SV
11import qualified Data.Vector as V
12import Text.Show.Pretty hiding (Float)
13
14import Backend.GL as GL
15import Backend.GL.Mesh
16import IR as IR
17import "lambdacube-ir" Linear as IR
18
19import System.Environment
20
21import Driver
22
23-- Our vertices. Tree consecutive floats give a 3D vertex; Three consecutive vertices give a triangle.
24-- A cube has 6 faces with 2 triangles each, so this makes 6*2=12 triangles, and 12*3 vertices
25g_vertex_buffer_data =
26 [ ( 1.0, 1.0,-1.0)
27 , ( 1.0,-1.0,-1.0)
28 , (-1.0,-1.0,-1.0)
29 , ( 1.0, 1.0,-1.0)
30 , (-1.0,-1.0,-1.0)
31 , (-1.0, 1.0,-1.0)
32 , ( 1.0, 1.0,-1.0)
33 , ( 1.0, 1.0, 1.0)
34 , ( 1.0,-1.0, 1.0)
35 , ( 1.0, 1.0,-1.0)
36 , ( 1.0,-1.0, 1.0)
37 , ( 1.0,-1.0,-1.0)
38 , ( 1.0, 1.0, 1.0)
39 , (-1.0,-1.0, 1.0)
40 , ( 1.0,-1.0, 1.0)
41 , ( 1.0, 1.0, 1.0)
42 , (-1.0, 1.0, 1.0)
43 , (-1.0,-1.0, 1.0)
44 , (-1.0, 1.0, 1.0)
45 , (-1.0,-1.0,-1.0)
46 , (-1.0,-1.0, 1.0)
47 , (-1.0, 1.0, 1.0)
48 , (-1.0, 1.0,-1.0)
49 , (-1.0,-1.0,-1.0)
50 , ( 1.0, 1.0,-1.0)
51 , (-1.0, 1.0,-1.0)
52 , (-1.0, 1.0, 1.0)
53 , ( 1.0, 1.0,-1.0)
54 , (-1.0, 1.0, 1.0)
55 , ( 1.0, 1.0, 1.0)
56 , ( 1.0, 1.0,-1.0)
57 , ( 1.0, 1.0, 1.0)
58 , (-1.0, 1.0, 1.0)
59 , ( 1.0, 1.0,-1.0)
60 , (-1.0, 1.0, 1.0)
61 , (-1.0, 1.0,-1.0)
62 ]
63
64-- Two UV coordinatesfor each vertex. They were created with Blender.
65g_uv_buffer_data =
66 [ (0.0, 0.0)
67 , (0.0, 1.0)
68 , (1.0, 1.0)
69 , (0.0, 0.0)
70 , (1.0, 1.0)
71 , (1.0, 0.0)
72 , (0.0, 0.0)
73 , (1.0, 0.0)
74 , (1.0, 1.0)
75 , (0.0, 0.0)
76 , (1.0, 1.0)
77 , (0.0, 1.0)
78 , (1.0, 0.0)
79 , (0.0, 1.0)
80 , (1.0, 1.0)
81 , (1.0, 0.0)
82 , (0.0, 0.0)
83 , (0.0, 1.0)
84 , (0.0, 0.0)
85 , (1.0, 1.0)
86 , (0.0, 1.0)
87 , (0.0, 0.0)
88 , (1.0, 0.0)
89 , (1.0, 1.0)
90 , (0.0, 0.0)
91 , (1.0, 0.0)
92 , (1.0, 1.0)
93 , (0.0, 0.0)
94 , (1.0, 1.0)
95 , (0.0, 1.0)
96 , (0.0, 0.0)
97 , (0.0, 1.0)
98 , (1.0, 1.0)
99 , (0.0, 0.0)
100 , (1.0, 1.0)
101 , (1.0, 0.0)
102 ]
103
104myCube :: Mesh
105myCube = Mesh
106 { mAttributes = T.fromList
107 [ ("position4", A_V4F $ SV.fromList [V4 x y z 1 | (x,y,z) <- g_vertex_buffer_data])
108 , ("vertexUV", A_V2F $ SV.fromList [V2 u v | (u,v) <- g_uv_buffer_data])
109 ]
110 , mPrimitive = P_Triangles
111 , mGPUData = Nothing
112 }
113
114main :: IO ()
115main = do
116 win <- initWindow "LambdaCube 3D DSL Sample" 1024 768
117 let keyIsPressed k = fmap (==KeyState'Pressed) $ getKey win k
118
119 n <- getArgs
120 let srcName = case n of
121 [fn] -> fn
122 _ -> "gfx03"
123
124 let inputSchema =
125 PipelineSchema
126 { GL.slots = T.fromList [("stream",SlotSchema Triangles $ T.fromList [("position",TV3F),("normal",TV3F),("UVTex",TV2F)])
127 ,("stream4",SlotSchema Triangles $ T.fromList [("position4",TV4F),("vertexUV",TV2F)])
128 ]
129 , uniforms = T.fromList [("MVP",M44F),("MVP2",M44F),("Time",Float)]
130 }
131 pplInput <- mkGLPipelineInput inputSchema
132
133 gpuCube <- compileMesh myCube
134 gpuMonkey <- loadMesh "Monkey.lcmesh"
135
136 addMesh pplInput "stream4" gpuCube []
137 addMesh pplInput "stream" gpuMonkey []
138
139 let setup = do
140 let sn = ExpN srcName
141 pplRes <- compileMain (ioFetch ["."]) OpenGL33 undefined sn
142 case pplRes of
143 (Left err,a) -> putStrLn ("error: " ++ show err) >> return Nothing
144 (Right (ppl,a),b) -> do
145 putStrLn $ ppShow ppl
146 --print [a,b]
147 renderer <- allocPipeline ppl
148 setPipelineInput renderer (Just pplInput)
149 sortSlotObjects pplInput
150 putStrLn "reloaded"
151 return $ Just renderer
152
153 let cm' = fromProjective (lookat (Vec3 4 0.5 (-0.6)) (Vec3 0 0 0) (Vec3 0 1 0))
154 cm = fromProjective (lookat (Vec3 3 1.3 0.3) (Vec3 0 0 0) (Vec3 0 1 0))
155 loop renderer = do
156 (w,h) <- getWindowSize win
157 let uniformMap = uniformSetter pplInput
158 texture = uniformFTexture2D "myTextureSampler" uniformMap
159 mvp = uniformM44F "MVP" uniformMap
160 mvp' = uniformM44F "MVP2" uniformMap
161 pm = perspective 0.1 100 (pi/4) (fromIntegral w / fromIntegral h)
162 time = uniformFloat "Time" uniformMap
163
164 setScreenSize pplInput (fromIntegral w) (fromIntegral h)
165 Just t <- getTime
166 let angle = pi / 24 * realToFrac t
167 mm = fromProjective $ rotationEuler $ Vec3 angle 0 0
168 mvp $! mat4ToM44F $! mm .*. cm .*. pm
169 mvp' $! mat4ToM44F $! mm .*. cm' .*. pm
170 time $ realToFrac t
171 renderPipeline renderer
172 swapBuffers win >> pollEvents
173
174 k <- keyIsPressed Key'Escape
175 reload <- keyIsPressed Key'R
176 rend' <- if not reload then return renderer else do
177 r <- setup
178 case r of
179 Nothing -> return renderer
180 Just a -> do
181 disposePipeline renderer
182 return a
183 when k $ disposePipeline rend'
184 unless k $ loop rend'
185
186 r <- setup
187 case r of
188 Just a -> loop a
189 Nothing -> return ()
190
191 destroyWindow win
192 terminate
193
194vec4ToV4F :: Vec4 -> V4F
195vec4ToV4F (Vec4 x y z w) = V4 x y z w
196
197mat4ToM44F :: Mat4 -> M44F
198mat4ToM44F (Mat4 a b c d) = V4 (vec4ToV4F a) (vec4ToV4F b) (vec4ToV4F c) (vec4ToV4F d)
199
200initWindow :: String -> Int -> Int -> IO Window
201initWindow title width height = do
202 GLFW.init
203 defaultWindowHints
204 mapM_ windowHint
205 [ WindowHint'ContextVersionMajor 3
206 , WindowHint'ContextVersionMinor 3
207 , WindowHint'OpenGLProfile OpenGLProfile'Core
208 , WindowHint'OpenGLForwardCompat True
209 ]
210 Just win <- createWindow width height title Nothing Nothing
211 makeContextCurrent $ Just win
212
213 return win
214
215-- | Perspective transformation matrix in row major order.
216perspective :: Float -- ^ Near plane clipping distance (always positive).
217 -> Float -- ^ Far plane clipping distance (always positive).
218 -> Float -- ^ Field of view of the y axis, in radians.
219 -> Float -- ^ Aspect ratio, i.e. screen's width\/height.
220 -> Mat4
221perspective n f fovy aspect = transpose $
222 Mat4 (Vec4 (2*n/(r-l)) 0 (-(r+l)/(r-l)) 0)
223 (Vec4 0 (2*n/(t-b)) ((t+b)/(t-b)) 0)
224 (Vec4 0 0 (-(f+n)/(f-n)) (-2*f*n/(f-n)))
225 (Vec4 0 0 (-1) 0)
226 where
227 t = n*tan(fovy/2)
228 b = -t
229 r = aspect*t
230 l = -r
231
232-- | Pure orientation matrix defined by Euler angles.
233rotationEuler :: Vec3 -> Proj4
234rotationEuler (Vec3 a b c) = orthogonal $ toOrthoUnsafe $ rotMatrixY a .*. rotMatrixX b .*. rotMatrixZ c
235
236-- | Camera transformation matrix.
237lookat :: Vec3 -- ^ Camera position.
238 -> Vec3 -- ^ Target position.
239 -> Vec3 -- ^ Upward direction.
240 -> Proj4
241lookat pos target up = translateBefore4 (neg pos) (orthogonal $ toOrthoUnsafe r)
242 where
243 w = normalize $ pos &- target
244 u = normalize $ up &^ w
245 v = w &^ u
246 r = transpose $ Mat3 u v w
diff --git a/examples/Hello.hs b/examples/Hello.hs
new file mode 100644
index 0000000..cfe1053
--- /dev/null
+++ b/examples/Hello.hs
@@ -0,0 +1,135 @@
1{-# LANGUAGE PackageImports, LambdaCase #-}
2{-# LANGUAGE FlexibleContexts #-}
3import "GLFW-b" Graphics.UI.GLFW as GLFW
4import qualified Data.Map as Map
5import qualified Data.Vector.Storable as SV
6
7import "lambdacube-gl-ir" LambdaCube.GL as LambdaCubeGL -- renderer
8import "lambdacube-gl-ir" LambdaCube.GL.Mesh as LambdaCubeGL
9
10import Codec.Picture as Juicy
11
12import LambdaCube.Compiler.Driver as LambdaCube -- compiler
13
14----
15import Control.Monad.Writer
16
17{-
18data ObjectArraySchema
19 = ObjectArraySchema
20 { primitive :: FetchPrimitive
21 , attributes :: Map String StreamType
22 }
23 deriving Show
24
25data PipelineSchema
26 = PipelineSchema
27 { objectArrays :: Map String ObjectArraySchema
28 , uniforms :: Map String InputType
29 }
30-}
31
32
33a @: b = tell [(a,b)]
34defObjectArray n p m = tell [PipelineSchema (Map.singleton n $ ObjectArraySchema p $ Map.fromList $ execWriter m) mempty]
35defUniforms m = tell [PipelineSchema mempty $ Map.fromList $ execWriter m]
36makeSchema a = head $ execWriter a :: PipelineSchema
37
38sch = makeSchema $ do
39 defObjectArray "objects" Triangles $ do
40 "position" @: Attribute_V4F
41 "uv" @: Attribute_V2F
42 defUniforms $ do
43 "time" @: Float
44 "diffuseTexture" @: FTexture2D
45
46-----
47main :: IO ()
48main = do
49 -- compile hello.lc to graphics pipeline description
50 pipelineDesc <- LambdaCube.compileMain ["."] OpenGL33 "hello" >>= \case
51 Left err -> fail $ "compile error:\n" ++ err
52 Right pd -> return pd
53
54 win <- initWindow "LambdaCube 3D DSL Hello World" 640 480
55
56 -- setup render data
57 let inputSchema = makeSchema $ do
58 defObjectArray "objects" Triangles $ do
59 "position" @: Attribute_V4F
60 "uv" @: Attribute_V2F
61 defUniforms $ do
62 "time" @: Float
63 "diffuseTexture" @: FTexture2D
64
65 storage <- LambdaCubeGL.allocStorage inputSchema
66
67 -- upload geometry to GPU and add to pipeline input
68 LambdaCubeGL.uploadMeshToGPU triangleA >>= LambdaCubeGL.addMeshToObjectArray storage "objects" []
69 LambdaCubeGL.uploadMeshToGPU triangleB >>= LambdaCubeGL.addMeshToObjectArray storage "objects" []
70
71 -- load image and upload texture
72 Right img <- Juicy.readImage "Panels_Diffuse.png"
73 textureData <- LambdaCubeGL.uploadTexture2DToGPU img
74
75 -- allocate GL pipeline
76 renderer <- LambdaCubeGL.allocRenderer pipelineDesc
77 LambdaCubeGL.setStorage renderer storage >>= \case -- check schema compatibility
78 Just err -> putStrLn err
79 Nothing -> loop
80 where loop = do
81 -- update graphics input
82 GLFW.getWindowSize win >>= \(w,h) -> LambdaCubeGL.setScreenSize storage (fromIntegral w) (fromIntegral h)
83 {-
84 LambdaCubeGL.updateUniforms storage $ do
85 "time" @= fromJust <$> GLFW.getTime
86 "diffuseTexture" @= return textureData
87 -}
88 -- render
89 LambdaCubeGL.renderFrame renderer
90 GLFW.swapBuffers win
91 GLFW.pollEvents
92
93 let keyIsPressed k = fmap (==KeyState'Pressed) $ GLFW.getKey win k
94 escape <- keyIsPressed Key'Escape
95 if escape then return () else loop
96
97 LambdaCubeGL.disposeRenderer renderer
98 LambdaCubeGL.disposeStorage storage
99 GLFW.destroyWindow win
100 GLFW.terminate
101
102-- geometry data: triangles
103triangleA :: LambdaCubeGL.Mesh
104triangleA = Mesh
105 { mAttributes = Map.fromList
106 [ ("position", A_V2F $ SV.fromList [V2 1 1, V2 1 (-1), V2 (-1) (-1)])
107 , ("uv", A_V2F $ SV.fromList [V2 0 0, V2 0 1, V2 1 1])
108 ]
109 , mPrimitive = P_Triangles
110 , mGPUData = Nothing
111 }
112
113triangleB :: LambdaCubeGL.Mesh
114triangleB = Mesh
115 { mAttributes = Map.fromList
116 [ ("position", A_V2F $ SV.fromList [V2 1 1, V2 (-1) (-1), V2 (-1) 1])
117 , ("uv", A_V2F $ SV.fromList [V2 0 0, V2 1 1, V2 1 0])
118 ]
119 , mPrimitive = P_Triangles
120 , mGPUData = Nothing
121 }
122
123initWindow :: String -> Int -> Int -> IO Window
124initWindow title width height = do
125 GLFW.init
126 GLFW.defaultWindowHints
127 mapM_ GLFW.windowHint
128 [ WindowHint'ContextVersionMajor 3
129 , WindowHint'ContextVersionMinor 3
130 , WindowHint'OpenGLProfile OpenGLProfile'Core
131 , WindowHint'OpenGLForwardCompat True
132 ]
133 Just win <- GLFW.createWindow width height title Nothing Nothing
134 GLFW.makeContextCurrent $ Just win
135 return win
diff --git a/tests/sampleIR.hs b/tests/sampleIR.hs
deleted file mode 100644
index a68d28a..0000000
--- a/tests/sampleIR.hs
+++ /dev/null
@@ -1,3 +0,0 @@
1import qualified SampleIR as S
2
3main = S.main
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-05 08:01:17 +0000