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
|
{-# LANGUAGE OverloadedStrings #-}
module LambdaHello where
import GI.Gtk as Gtk
import GI.Gdk.Objects
import qualified Graphics.Rendering.OpenGL as GL
import Data.Function
import Control.Concurrent
import LambdaCube.GL as LambdaCubeGL
import LambdaCube.GL.Mesh as LambdaCubeGL
import LambdaCube.IR
import Codec.Picture as Juicy
import Data.Aeson as JSON
import qualified Data.ByteString as SB
import System.IO.Error
import qualified Data.Map as Map
import qualified Data.Vector as V
-- import qualified Backend as RF
import LambdaCube.GL as RF
import LambdaCube.GL.Type
import Control.Monad.IO.Class
import qualified Unsafe.Coerce
data State = State
{ stConfig :: Config
, stRealized :: MVar Realized
}
initState :: IO State
initState = do
cfg <- either fail return =<< loadConfig
r <- newEmptyMVar
return State
{ stConfig = cfg
, stRealized = r
}
-- | LambdaCube.GL assumes we are rendering to the default framebuffer #0 but
-- Gtk.GLArea actually uses an unpredictable framebuffer object target. As a
-- workaround, we read the current framebuffer target and patch up the render
-- commands to use it instead of 0.
fixupRenderTarget :: MonadIO m => GLRenderer -> m GLRenderer
fixupRenderTarget r = do
fbo0 <- GL.get $ GL.bindFramebuffer GL.DrawFramebuffer
let fbo = Unsafe.Coerce.unsafeCoerce fbo0 :: GL.GLuint -- XXX: Is there a better way to get this?
setFBO rt | framebufferObject rt == 0 = rt { framebufferObject = fbo }
| otherwise = rt
updateDC dc = dc { glRenderTarget = rt' } where rt' = setFBO (glRenderTarget dc)
update (GLClearRenderTarget rt imgs) = GLClearRenderTarget (setFBO rt) imgs
update (GLRenderSlot dc s p) = GLRenderSlot (updateDC dc) s p
update (GLRenderStream dc s p) = GLRenderStream (updateDC dc) s p
return r { glCommands = map update (glCommands r) }
render :: State -> GLArea -> GLContext -> IO Bool
render st w gl = do
mr <- tryTakeMVar (stRealized st)
maybe (\_ -> putStrLn "Not realized!") (&) mr $ \r -> do
renderer <- fixupRenderTarget (rRenderer r)
-- Load input to pipeline.
-- 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 (fromIntegral wd,fromIntegral ht)
LambdaCubeGL.setScreenSize (rStorage r) wd ht
LambdaCubeGL.updateUniforms (rStorage r) $ do
"diffuseTexture" @= return (rTexture r)
"time" @= do
-- Just t <- GLFW.getTime
let t = 1.0 :: Double
return (realToFrac t :: Float)
-- putStrLn "render!"
-- GL.clearColor GL.$= GL.Color4 0 255 0 1
-- GL.clear [GL.ColorBuffer]
RF.renderFrame renderer
-- GL.flush
putMVar (stRealized st) r
return True
data Realized = Realized
{ rStorage :: GLStorage
, rTexture :: TextureData
, rRenderer :: GLRenderer
}
realize :: State -> GLArea -> IO ()
realize st w = gLAreaMakeCurrent w >> gLAreaGetError w >>= \me -> maybe id (\e _ -> print e) me $ do
let cfg = stConfig st
_ <- tryTakeMVar (stRealized st)
storage <- LambdaCubeGL.allocStorage (cfgSchema cfg)
-- 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
texture <- LambdaCubeGL.uploadTexture2DToGPU (cfgLogo cfg)
renderer <- LambdaCubeGL.allocRenderer (cfgPipeline cfg)
compat <- LambdaCubeGL.setStorage renderer storage -- check schema compatibility
putMVar (stRealized st) $ Realized storage texture renderer
-- GL.flush
putStrLn "realize!"
maybe id (\e _ -> putStrLn e) compat $ return ()
unrealize :: State -> GLArea -> IO ()
unrealize _ _ = return ()
data Config = Config
{ cfgSchema :: PipelineSchema
, cfgPipeline :: Pipeline
, cfgLogo :: DynamicImage
}
loadConfig :: IO (Either String Config)
loadConfig = do
pipelineDesc <- do
maybe (Left "Unable to parse hello.json") Right . JSON.decodeStrict <$> SB.readFile "hello.json"
`catchIOError` \e -> return $ Left (show e)
-- setup render data
let inputSchema = makeSchema $ do
defObjectArray "objects" Triangles $ do
"position" @: Attribute_V2F
"uv" @: Attribute_V2F
defUniforms $ do
"time" @: Float
"diffuseTexture" @: FTexture2D
-- load image and upload texture
img <- Juicy.readImage "logo.png"
`catchIOError` \e -> return $ Left (show e)
return $ Config inputSchema <$> pipelineDesc <*> img
-- 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
}
createContext :: State -> GLArea -> IO GLContext
createContext st glarea = do
Just win <- widgetGetWindow glarea
gl <- windowCreateGlContext win
return gl
|
