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
|
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
module MeshSketch where
import Codec.Picture as Juicy
import Control.Concurrent
import Control.Monad
import Data.Word
import Data.Function ((&))
import Data.Int
import Data.IORef
import Data.Text (Text)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import qualified Data.Vector as V
import GI.Gdk.Objects
import GI.GLib.Constants
import qualified GI.Gtk as Gtk (main)
import GI.Gtk as Gtk hiding (main)
import LambdaCube.GL as LC
import LambdaCube.GL.Mesh as LC
import Numeric.LinearAlgebra hiding ((<>))
import System.Environment
import System.IO
import System.IO.Error
import Control.Exception
import LambdaCube.GL as LC
import LambdaCube.IR as LC
import LambdaCube.Gtk
import GLWidget (nullableContext, withCurrentGL)
import LambdaCube.GL.HMatrix
import LambdaCubeWidget (loadPipeline,DynamicPipeline(..))
import TimeKeeper
import LoadMesh
import InfinitePlane
import MtlParser (ObjMaterial(..))
import Matrix
-- State created by uploadState.
data State = State
{ stTimeKeeper :: TimeKeeper
, stTickCallback :: TickCallbackHandle
}
addOBJToObjectArray :: GLStorage -> String -> [(GPUMesh, Maybe Text)] -> Map Text (ObjMaterial,TextureData) -> IO [LC.Object]
addOBJToObjectArray storage slotName objMesh mtlLib = forM objMesh $ \(mesh,mat) -> do
obj <- LC.addMeshToObjectArray storage slotName ["diffuseTexture","diffuseColor"] mesh
-- diffuseTexture and diffuseColor values can change on each model
case mat >>= flip Map.lookup mtlLib of
Nothing -> return ()
Just (ObjMaterial{..},t) -> LC.updateObjectUniforms obj $ do
"diffuseTexture" @= return t -- set model's diffuse texture
"diffuseColor" @= let (r,g,b) = mtl_Kd in return (V4 r g b mtl_Tr)
return obj
uploadState :: IsWidget glarea => MeshData -> glarea -> GLStorage -> IO State
uploadState obj glarea storage = do
-- load OBJ geometry and material descriptions
(objMesh,mtlLib) <- uploadOBJToGPU obj
-- load materials textures
gpuMtlLib <- uploadMtlLib mtlLib
-- add OBJ to pipeline input
addOBJToObjectArray storage "objects" objMesh gpuMtlLib
-- grid plane
uploadMeshToGPU xzplane >>= addMeshToObjectArray storage "plane" []
-- setup FrameClock
tm <- newTimeKeeper
tickcb <- widgetAddTickCallback glarea (tick tm)
return State
{ stTimeKeeper = tm
, stTickCallback = tickcb
}
destroyState :: GLArea -> State -> IO ()
destroyState glarea st = do
widgetRemoveTickCallback glarea (stTickCallback st)
deg30 :: Float
deg30 = pi/6
setUniforms :: glctx -> GLStorage -> State -> IO ()
setUniforms gl storage st = do
t <- (/ 10.0) <$> getSeconds (stTimeKeeper st)
let tf = realToFrac t :: Float
rot = rotMatrixZ (-tf) <> rotMatrixX (-tf)
pos = rot #> fromList [2,2,10]
up = rot #> fromList [0,1,0]
cam = lookat pos 0 up
aspect = 1
proj = perspective 0.1 100 deg30 aspect
mvp = proj <> cam
LC.updateUniforms storage $ do
"CameraPosition" @= return (pos :: Vector Float)
"ViewProjection" @= return (mvp :: Matrix Float)
data MeshSketch = MeshSketch
{ mmWidget :: GLArea
, mmRealized :: IORef (Maybe Realized)
}
data Realized = Realized
{ stStorage :: GLStorage
, stRenderer :: GLRenderer
, stState :: State
}
new :: IO MeshSketch
new = do
m <- do
objName <- head . (++ ["cube.obj"]) <$> getArgs
mobj <- loadOBJ objName
mpipeline <- loadPipeline "hello_obj2.json" $ do
defObjectArray "objects" Triangles $ do
"position" @: Attribute_V4F
"normal" @: Attribute_V3F
"uvw" @: Attribute_V3F
defObjectArray "plane" Triangles $ do
"position" @: Attribute_V4F
defUniforms $ do
"CameraPosition" @: V3F
"ViewProjection" @: M44F
"diffuseTexture" @: FTexture2D
"diffuseColor" @: V4F
return $ (,) <$> mobj <*> mpipeline
either (\e _ -> hPutStrLn stderr e >> throwIO (userError e)) (&) m $ \(obj,pipeline) -> do
ref <- newIORef Nothing
-- glarea <- newGLWidget return (lambdaRender app glmethods)
do
g <- gLAreaNew
let mm = MeshSketch g ref
gLAreaSetHasDepthBuffer g True
st <- return g
-- _ <- on g #render $ glRender w st
-- _ <- on g #resize $ glResize w st
_ <- on g #realize $ withCurrentGL g (onRealize obj (dynamicPipeline pipeline) (dynamicSchema pipeline) mm)
_ <- on g #unrealize $ onUnrealize mm
-- _ <- on g #createContext $ nullableContext (glCreateContext w st)
return mm
onUnrealize :: MeshSketch -> IO ()
onUnrealize mm = do
m <- readIORef (mmRealized mm)
forM_ m $ \st -> do
LC.disposeStorage (stStorage st)
LC.disposeRenderer (stRenderer st)
-- lcDestroyState lc x
onRealize :: MeshData -> Pipeline -> PipelineSchema -> MeshSketch -> IO ()
onRealize mesh pipeline schema mm = do
onUnrealize mm
storage <- LC.allocStorage schema
renderer <- LC.allocRenderer pipeline
compat <- LC.setStorage renderer storage -- check schema compatibility
x <- uploadState mesh (mmWidget mm) storage
let r = Realized
{ stStorage = storage
, stRenderer = renderer
, stState = x
}
_ <- on (mmWidget mm) #render $ onRender (mmWidget mm) r
_ <- on (mmWidget mm) #resize $ onResize (mmWidget mm) r
writeIORef (mmRealized mm) $ Just r
onRender :: w -> Realized -> GLContext -> IO Bool
onRender w realized gl = do
r <- fixupRenderTarget (stRenderer realized)
setUniforms gl (stStorage realized) (stState realized)
LC.renderFrame r
return True
onResize :: GLArea -> Realized -> Int32 -> Int32 -> IO ()
onResize glarea realized w h = do
let storage = stStorage realized
-- Plenty of options here. I went with the last one.
-- 1. gLContextGetWindow :: HasCallStack => GLContext -> IO (Maybe Window)
-- 2. getGLContextWindow :: GLContext -> IO (Maybe Window)
-- 3. widgetGetWindow :: HasCallStack => GLArea -> IO (Maybe Window)
widgetGetWindow glarea >>= mapM_ (\win -> do
(wd,ht) <- do wd <- windowGetWidth win
ht <- windowGetHeight win
return (fromIntegral wd,fromIntegral ht)
LC.setScreenSize (stStorage realized) wd ht)
|