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
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
|
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Lambda2 where
import qualified Graphics.Rendering.OpenGL as GL
import GI.Gtk.Objects (GLArea,gLAreaGetContext,widgetGetWindow)
import GI.Gdk.Objects.GLContext (GLContext, gLContextGetDebugEnabled,
gLContextGetForwardCompatible,
gLContextSetDebugEnabled,
gLContextSetForwardCompatible,
gLContextGetRequiredVersion,
gLContextSetRequiredVersion,
gLContextGetUseEs,
getGLContextWindow,
gLContextMakeCurrent)
import GI.Gdk.Objects.Window (windowCreateGlContext,windowGetWidth,windowGetHeight)
import qualified Data.Map as Map
import qualified Data.Vector as V
import LambdaCube.GL as LambdaCubeGL -- renderer
import LambdaCube.GL.Mesh as LambdaCubeGL
import Codec.Picture as Juicy
import Data.Aeson
import qualified Data.ByteString as SB
import Data.Char
import Text.Printf
import System.IO
-- import qualified Backend as RF
import LambdaCube.GL as RF
data State = State
initState :: IO State
initState = do
return State
render :: State -> GLArea -> GLContext -> IO Bool
render st glarea gl = do
cf <- GL.get GL.cullFace
oldvp <- GL.get GL.viewport
putStrLn $ "cullface = " ++ show cf
putStrLn $ "viewport = " ++ show oldvp
GL.cullFace GL.$= Nothing
Just pipelineDesc <- decodeStrict <$> SB.readFile "hello.json"
-- win <- initWindow "LambdaCube 3D DSL Hello World" 640 640
-- setup render data
let inputSchema = makeSchema $ do
defObjectArray "objects" Triangles $ do
"position" @: Attribute_V2F
"uv" @: Attribute_V2F
defUniforms $ do
"time" @: Float
"diffuseTexture" @: FTexture2D
storage <- LambdaCubeGL.allocStorage inputSchema
-- upload geometry to GPU and add to pipeline input
LambdaCubeGL.uploadMeshToGPU triangleA >>= LambdaCubeGL.addMeshToObjectArray storage "objects" []
LambdaCubeGL.uploadMeshToGPU triangleB >>= LambdaCubeGL.addMeshToObjectArray storage "objects" []
-- load image and upload texture
Right img <- Juicy.readImage "logo.png"
textureData <- LambdaCubeGL.uploadTexture2DToGPU img
-- allocate GL pipeline
renderer <- LambdaCubeGL.allocRenderer pipelineDesc
LambdaCubeGL.setStorage renderer storage >>= \case -- check schema compatibility
Just err -> putStrLn err
Nothing -> loop
where loop = do
-- update graphics input
-- GLFW.getWindowSize win >>= \(w,h) -> LambdaCubeGL.setScreenSize storage (fromIntegral w) (fromIntegral h)
(wd,ht) <- do
Just win <- getGLContextWindow gl
wd <- windowGetWidth win
ht <- windowGetHeight win
print (wd,ht)
return (wd,ht)
vp <- GL.get GL.viewport
dr <- GL.get GL.depthRange
mm <- GL.get GL.matrixMode
mat <- GL.get (GL.matrix $ Just mm)
cs <- GL.getMatrixComponents GL.RowMajor mat
dc <- GL.get GL.depthClamp
tms <- mapM (GL.get . GL.textureGenMode) [GL.S, GL.T, GL.R, GL.Q]
mx <- GL.get GL.maxViewportDims
print (vp,(wd,ht),dr,mm,dc)
print (mat :: GL.GLmatrix Double, cs)
print (tms,mx)
return (wd,ht) >>= \(w,h) -> LambdaCubeGL.setScreenSize storage (fromIntegral w) (fromIntegral h)
LambdaCubeGL.updateUniforms storage $ do
"diffuseTexture" @= return textureData
"time" @= do
Just t <- return $ Just (1.0::Double) -- GLFW.getTime
return (realToFrac t :: Float)
-- render
-- GL.clearColor GL.$= GL.Color4 0 0 0 0
-- GL.clear [GL.ColorBuffer,GL.DepthBuffer]
putStrLn "LambdaCubeGL.renderFrame enter.."
-- mapM_ print $ glCommands renderer
RF.renderFrame renderer
putStrLn "LambdaCubeGL.renderFrame ..exit"
-- GL.clear [GL.ColorBuffer,GL.DepthBuffer]
-- GLFW.swapBuffers win
-- GLFW.pollEvents
-- GL.flush
let keyIsPressed k = return True -- fmap (==KeyState'Pressed) $ GLFW.getKey win k
escape <- keyIsPressed () -- Key'Escape
if escape then return () else loop
LambdaCubeGL.disposeRenderer renderer
-- LambdaCubeGL.disposeStorage storage -- XXX: not implemented
-- GLFW.destroyWindow win
-- GLFW.terminate
return True
-- geometry data: triangles
triangleA :: LambdaCubeGL.Mesh
triangleA = Mesh
{ mAttributes = Map.fromList
[ ("position", A_V2F $ V.fromList [V2 1 1, V2 1 (-1), V2 (-1) (-1)])
, ("uv", A_V2F $ V.fromList [V2 1 1, V2 0 1, V2 0 0])
]
, mPrimitive = P_Triangles
}
triangleB :: LambdaCubeGL.Mesh
triangleB = Mesh
{ mAttributes = Map.fromList
[ ("position", A_V2F $ V.fromList [V2 1 1, V2 (-1) (-1), V2 (-1) 1])
, ("uv", A_V2F $ V.fromList [V2 1 1, V2 0 0, V2 1 0])
]
, mPrimitive = P_Triangles
}
realize :: State -> GLArea -> IO ()
realize st glarea = do
putStrLn "realize!"
{-
GL.debugMessageInsert (GL.DebugMessage GL.DebugSourceApplication
GL.DebugTypeOther
(GL.DebugMessageID 0)
GL.DebugSeverityHigh
"Hello2 world!")
-}
return ()
unrealize :: State -> GLArea -> IO ()
unrealize st glarea = do
return ()
prettyDebug :: GL.DebugMessage -> String
prettyDebug (GL.DebugMessage src typ (GL.DebugMessageID mid) severity msg) = unwords ws
where
ws = [wsrc,wtyp,wmid,wseverity,msg]
-- DebugSourceShaderCompiler DebugTypeOther 1 DebugSeverityNotification
wsrc = filter isUpper $ drop 11 $ show src
wtyp = take 2 $ drop 9 $ show typ
wmid = printf "%03i" mid
wseverity = drop 13 $ show severity
createContext :: State -> GLArea -> IO GLContext
createContext st glarea = do
putStrLn "createContext!"
-- gl <- gLAreaGetContext glarea -- Remember to bind signal with 'after' so that this is not nullPtr.
Just win <- widgetGetWindow glarea
gl <- windowCreateGlContext win
(maj,min) <- gLContextGetRequiredVersion gl
-- (vmaj,vmin) <- gLContextGetVersion gl -- must be realized
-- islegacy <- gLContextIsLegacy gl -- must be realized
-- v_es <-gLContextGetUseEs gl
v_db <- gLContextGetDebugEnabled gl
v_fw <- gLContextGetForwardCompatible gl
v_es <- gLContextGetUseEs gl
putStrLn $ unwords [ "debug:",show v_db
, "fw:",show v_fw
, "es:", show v_es
, "ver:", show (maj,min)
]
gLContextSetDebugEnabled gl True
gLContextSetForwardCompatible gl False -- True
gLContextSetRequiredVersion gl 3 3
v_db <- gLContextGetDebugEnabled gl
v_fw <- gLContextGetForwardCompatible gl
(maj,min) <- gLContextGetRequiredVersion gl
putStrLn $ unwords [ "debug:",show v_db
, "fw:",show v_fw
, "ver:", show (maj,min)
]
let pdebug m@(GL.DebugMessage src typ mid severity msg) = do
putStrLn (">> " ++ prettyDebug m)
gLContextMakeCurrent gl
GL.debugOutput GL.$= GL.Enabled
GL.debugOutputSynchronous GL.$= GL.Enabled
GL.debugMessageControl (GL.MessageGroup Nothing Nothing Nothing) GL.$= GL.Enabled
GL.debugMessageCallback GL.$= Just pdebug
{-
GL.debugMessageInsert (GL.DebugMessage GL.DebugSourceApplication
GL.DebugTypeOther
(GL.DebugMessageID 0)
GL.DebugSeverityHigh
"Hello world!")
-}
return gl
|
