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
|
{-# LANGUAGE OverloadedStrings #-}
module LambdaHello where
import GI.Gtk as Gtk
import GI.Gdk.Objects
import GI.GLib.Constants
import Data.Int
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 LambdaCube.Gtk
data State = State
{ stConfig :: Config
, stRealized :: MVar Realized
, stSeconds :: MVar Double
, stFirstFrame :: MVar Int64
}
initState :: IO State
initState = do
cfg <- either fail return =<< loadConfig
r <- newEmptyMVar
s <- newMVar 0.0
ff <- newMVar 0
return State
{ stConfig = cfg
, stRealized = r
, stSeconds = s
, stFirstFrame = ff
}
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
t <- withMVar (stSeconds st) return
LambdaCubeGL.updateUniforms (rStorage r) $ do
"diffuseTexture" @= return (rTexture r)
"time" @= 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
}
tick :: State -> Widget -> FrameClock -> IO Bool
tick st w clock = do
Just win <- widgetGetWindow w
windowInvalidateRect win Nothing False
micros <- frameClockGetFrameTime clock
ff <- modifyMVar (stFirstFrame st) $ \prev ->
if prev == 0 then return (micros, micros)
else return (prev, prev)
secs <- modifyMVar (stSeconds st) $ \_ -> do
let secs = fromIntegral (micros - ff) / 1000000.0
return (secs,secs)
-- putStrLn $ "tick! " ++ show (micros,secs)
return SOURCE_CONTINUE
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 $ do
tickcb <- widgetAddTickCallback w (tick st)
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
|
