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
|
{-# 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
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
}
render :: State -> GLArea -> GLContext -> IO Bool
render st w _ = do -- gLAreaMakeCurrent w >> gLAreaGetError w >>= \me -> maybe id (\e _ -> print e >> return False) me $ do
mr <- tryTakeMVar (stRealized st)
maybe (\_ -> putStrLn "Not realized!") (&) mr $ \r -> do
-- Load input to pipeline.
-- GLFW.getWindowSize win >>= \(w,h) -> LambdaCubeGL.setScreenSize storage (fromIntegral w) (fromIntegral h)
return (500,500) >>= \(w,h) -> LambdaCubeGL.setScreenSize (rStorage r) (fromIntegral w) (fromIntegral h)
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 (rRenderer r)
-- 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
|
