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
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
|
{-# 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.Functor ((<&>))
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 Foreign.Marshal.Array
import Foreign.Storable
import GI.Gdk
import GI.Gdk.Objects
import GI.GLib.Constants
import GI.Gtk hiding (IsWindow,windowFullscreen,windowUnfullscreen)
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 LambdaCube.GL.Data (uploadCubeMapToGPU,uploadTextureBufferToGPU,updateTextureBuffer)
import LambdaCube.GL.Type (TextureCubeData(..),Object(..))
-- import Text.Show.Pretty (ppShow)
import qualified Graphics.Rendering.OpenGL as GL
import Data.Char
import Text.Printf
import CubeMap
import GLWidget (nullableContext, withCurrentGL)
import LambdaCube.GL.HMatrix
import LambdaCubeWidget (loadPipeline,DynamicPipeline(..))
import Animator
import LoadMesh
import InfinitePlane
import MtlParser (ObjMaterial(..))
import Matrix
import PointPrimitiveRing
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
setupGLDebugging :: IO ()
setupGLDebugging = do
let pdebug m@(GL.DebugMessage src typ mid severity msg) = do
putStrLn (">> " ++ prettyDebug m)
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
-- State created by uploadState.
data State = State
{ stAnimator :: Animator
, stCamera :: IORef Camera
, stFullscreen :: IO ()
, stSkyboxes :: Skyboxes
, stSkybox :: IORef Int
, stSkyTexture :: IORef TextureCubeData
, stDragFrom :: IORef (Maybe (Vector Float,Camera))
, stRingBuffer :: Ring
, stPenDown :: IORef Bool
}
data Camera = Camera
{ camHeightAngle :: Float
, camTarget :: Vector Float
, camDirection :: Vector Float
, camDistance :: Float
, camWidth :: Float
, camHeight :: Float
, camUp :: Vector Float
, camWorldToScreen :: Maybe (Matrix Float)
, camScreenToWorld :: Maybe (Matrix Float)
}
camPos c = camTarget c - scale (camDistance c) (camDirection c)
initCamera :: Camera
initCamera = Camera
{ camHeightAngle = pi/6
, camTarget = fromList [0,0,0]
, camDirection = scale (1/d) $ fromList [-2,-2,-10]
, camDistance = d
, camWidth = 700
, camHeight = 700
, camUp = fromList [0,1,0]
, camWorldToScreen = Nothing
, camScreenToWorld = Nothing
}
where d = realToFrac $ norm_2 $ fromList [2::Float,2,10]
viewProjection :: Camera -> (Camera,(Matrix Float,Vector Float))
viewProjection c
| Just m <- camWorldToScreen c = (c,(m,pos))
| otherwise = (c { camWorldToScreen = Just m' }, (m',pos))
where
m' = proj <> cam
cam = lookat pos (camTarget c) (camUp c)
pos = camTarget c - scale (camDistance c) (camDirection c)
proj = perspective 0.1 100 (camHeightAngle c) (camWidth c / camHeight c)
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
mkFullscreenToggle :: IsWindow a => a -> IO (IO ())
mkFullscreenToggle w = do
full <- newIORef False
return $ do
b <- atomicModifyIORef' full $ \b -> (not b, not b)
if b then windowFullscreen w
else windowUnfullscreen w
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" []
ring <- newRing storage 100
-- setup FrameClock
w <- toWidget glarea
tm <- newAnimator w
cam <- newIORef initCamera
Just pwidget <- get w #parent
Just parent <- get pwidget #window
toggle <- mkFullscreenToggle parent
skyboxes <- loadSkyboxes
skybox <- newIORef 0
skybox_id <- skyboxLoad skyboxes 0 >>= \case
Right ts -> do
skybox_id <- uploadCubeMapToGPU ts
LC.updateUniforms storage $ do
"CubeMap" @= return skybox_id
return skybox_id
Left msg -> do
putStrLn msg
return (TextureCubeName 0)
skytex <- newIORef skybox_id
mi <- LC.uploadMeshToGPU cubeMesh
LC.addMeshToObjectArray storage "SkyCube" [] mi
drag <- newIORef Nothing
pendown <- newIORef False
let st = State
{ stAnimator = tm
, stCamera = cam
, stFullscreen = toggle
, stSkyboxes = skyboxes
, stSkybox = skybox
, stSkyTexture = skytex
, stDragFrom = drag
, stRingBuffer = ring
, stPenDown = pendown
}
-- _ <- addAnimation tm (whirlingCamera st)
return st
destroyState :: GLArea -> State -> IO ()
destroyState glarea st = do
-- widgetRemoveTickCallback glarea (stTickCallback st)
return ()
deg30 :: Float
deg30 = pi/6
whirlingCamera :: State -> Animation
whirlingCamera st = Animation $ \_ t -> do
let tf = realToFrac t :: Float
rot = rotMatrixZ (-tf/2) <> rotMatrixX (-tf/pi)
modifyIORef (stCamera st) $ \cam -> cam
{ camUp = fromList [0,1,0] <# rot
, camDirection = (scale (1/camDistance cam) $ fromList [-2,-2,-10]) <# rot
, camWorldToScreen = Nothing
, camScreenToWorld = Nothing
}
return $ Just (whirlingCamera st)
setUniforms :: glctx -> GLStorage -> State -> IO ()
setUniforms gl storage st = do
(mvp,pos) <- atomicModifyIORef' (stCamera st) viewProjection
LC.updateUniforms storage $ do
"CameraPosition" @= return (pos :: Vector Float)
"ViewProjection" @= return (mvp :: Matrix Float)
updateRingUniforms storage (stRingBuffer st)
data MeshSketch = MeshSketch
{ mmWidget :: GLArea
, mmRealized :: IORef (Maybe Realized)
}
data Realized = Realized
{ stStorage :: GLStorage
, stRenderer :: GLRenderer
, stState :: State
}
new :: IO GLArea
new = do
m <- do
objName <- head . (++ ["cube.obj"]) <$> getArgs
mobj <- loadOBJ objName
-- mpipeline <- (\s -> return (Right (DynamicPipeline savedPipeline (makeSchema s)))) $ do
mpipeline <- loadPipeline "hello_obj2.json" $ do
defObjectArray "SkyCube" Triangles $ do
"position" @: Attribute_V3F
defObjectArray "objects" Triangles $ do
"position" @: Attribute_V4F
"normal" @: Attribute_V3F
"uvw" @: Attribute_V3F
defObjectArray "plane" Triangles $ do
"position" @: Attribute_V4F
defObjectArray "Points" Points $ do
"position" @: Attribute_V3F
defUniforms $ do
"PointBuffer" @: FTextureBuffer
"CubeMap" @: FTextureCube
"CameraPosition" @: V3F
"ViewProjection" @: M44F
"PointsMax" @: Int
"PointsStart" @: Int
"diffuseTexture" @: FTexture2D
"diffuseColor" @: V4F
return $ (,) <$> mobj <*> mpipeline
either (\e _ -> hPutStrLn stderr e >> throwIO (userError e)) (&) m $ \(obj,pipeline) -> do
-- putStrLn $ ppShow (dynamicPipeline pipeline)
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 #realize $ withCurrentGL g (onRealize obj (dynamicPipeline pipeline) (dynamicSchema pipeline) mm)
_ <- on g #unrealize $ onUnrealize mm
-- _ <- on g #createContext $ nullableContext (glCreateContext w st)
return g
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
setupGLDebugging
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
}
w = mmWidget mm
set w [ #canFocus := True ] -- For keyboard events.
widgetAddEvents w
[ EventMaskPointerMotionMask
, EventMaskButtonPressMask
, EventMaskButtonReleaseMask
, EventMaskTouchMask
, EventMaskScrollMask
, EventMaskKeyPressMask -- , EventMaskKeyReleaseMask
]
_ <- on w #event $ \ev -> do gLAreaMakeCurrent w
onEvent w r ev
_ <- on w #render $ onRender w r
_ <- on w #resize $ onResize w 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)
modifyIORef' (stCamera $ stState realized)
$ \c -> c { camWidth = fromIntegral wd
, camHeight = fromIntegral ht
, camWorldToScreen = Nothing
, camScreenToWorld = Nothing
}
LC.setScreenSize (stStorage realized) wd ht)
-- This computes a point in world coordinates on the view screen if
-- we assume the camera is located at the origin.
computeDirection :: Camera -> Double -> Double -> Vector Float
computeDirection cam h k =
let d̂ = camDirection cam -- forward
û = camUp cam -- upward
r̂ = d̂ `cross` û -- rightward
xr = realToFrac h - (camWidth cam / 2)
xu = (camHeight cam / 2) - realToFrac k
xd = (camHeight cam / 2) / tan (camHeightAngle cam / 2)
in scale xr r̂ + scale xu û + scale xd d̂
rotate :: Float -> Vector Float -> Matrix Float
rotate cosθ u = (3><3)
[ cosθ + ux² mcosθ , (uy.uy)mcosθ - uz sinθ , (ux.uz)mcosθ + uy sinθ
, (uy.ux)mcosθ + uz sinθ , cosθ + uy² mcosθ , (uy.uz)mcosθ - ux sinθ
, (uz.ux)mcosθ - uy sinθ , (uz.uy)mcosθ + ux sinθ , cosθ + uz² mcosθ
]
where
sinθ = sqrt (1 - cosθ * cosθ)
mcosθ = 1 - cosθ
û = scale (1/realToFrac (norm_2 u)) u
ux a = (û!0) * a
uy a = (û!1) * a
uz a = (û!2) * a
ux² = ux . ux
uy² = uy . uy
uz² = uz . uz
updateCameraRotation w st h k = do
m <- readIORef (stDragFrom st)
forM_ m $ \(df,cam) -> do
let d̂ = camDirection cam -- forward
û = camUp cam -- upward
r̂ = d̂ `cross` û -- rightward
-- fr = df `dot` r̂
-- fu = df `dot` û
-- fd = df `dot` d̂
dt = computeDirection cam h k
-- tr = dt `dot` r̂
-- tu = dt `dot` û
-- td = dt `dot` d̂
cosθ = dot df dt / realToFrac (norm_2 df) / realToFrac (norm_2 dt)
axis0 = df `cross` dt
small x = abs x < 0.00001
axis = let xs = toList axis0
in if any isNaN xs || all small xs
then fromList [0,1,0]
else axis0
cam' = cam
{ camDirection = d̂ <# rotate cosθ axis
, camUp = û <# rotate cosθ axis
, camWorldToScreen = Nothing
, camScreenToWorld = Nothing
}
writeIORef (stCamera st) cam'
mwin <- widgetGetWindow w
forM_ mwin $ \win ->
windowInvalidateRect win Nothing False
sanitizeCamera st = do
modifyIORef (stCamera st) $ \cam ->
let d = camDirection cam
u = camUp cam
dd = norm_2 d
uu = norm_2 u
e = scale (realToFrac $ 1/dd) d
d̂ = if any isNaN (toList e)
then fromList [0,0,-1]
else e
f = scale (realToFrac $ 1/uu) u
û = if any isNaN (toList f)
then fromList [0,1,0]
else f
in cam
{ camDirection = d̂
, camUp = û
, camWorldToScreen = Nothing
, camScreenToWorld = Nothing
}
onEvent :: IsWidget w => w -> Realized -> Event -> IO Bool
onEvent w realized ev = do
let st = stState realized
msrc <- eventGetSourceDevice ev
inputSource <- forM msrc $ \src -> do
src <- get src #inputSource
return src
etype <- get ev #type
-- putStrLn $ "onEvent! " ++ show (etype,inputSource)
let put x = putStrLn (show inputSource ++ " " ++ show x)
let st = stState realized
case etype of
EventTypeMotionNotify -> do
case inputSource of
Just InputSourcePen -> do
isDown <- readIORef (stPenDown st)
when isDown $ do
mev <- get ev #motion
h <- get mev #x
k <- get mev #y
cam <- readIORef (stCamera st)
let d = camPos cam + computeDirection cam h k
-- pushBack (stRingBuffer st) (d!0) (d!1) (d!2)
pushBack (stRingBuffer st) (2 * realToFrac h/camWidth cam - 1) (1 - 2 * realToFrac k/camHeight cam) 1 -- (d!0) (d!1) (d!2)
Just win <- getWidgetWindow w
windowInvalidateRect win Nothing False
put (etype,(h,k),d)
_ -> do
mev <- get ev #motion
h <- get mev #x
k <- get mev #y
put (h,k)
updateCameraRotation w st h k
return ()
EventTypeButtonPress -> do
case inputSource of
Just InputSourcePen -> do
writeIORef (stPenDown st) True
bev <- get ev #button
h <- get bev #x
k <- get bev #y
cam <- readIORef (stCamera st)
let d = camPos cam + computeDirection cam h k
-- pushBack (stRingBuffer st) (d!0) (d!1) (d!2)
pushBack (stRingBuffer st) (2 * realToFrac h/camWidth cam - 1) (1 - 2 * realToFrac k/camHeight cam) 1 -- (d!0) (d!1) (d!2)
Just win <- getWidgetWindow w
windowInvalidateRect win Nothing False
put (etype,(h,k),d)
_ -> do
bev <- get ev #button
h <- get bev #x
k <- get bev #y
cam <- readIORef (stCamera st)
let d = computeDirection cam h k
writeIORef (stDragFrom st) $ Just (d,cam)
put (etype,(h,k),d)
return ()
EventTypeButtonRelease -> do
case inputSource of
Just InputSourcePen -> do
writeIORef (stPenDown st) False
bev <- get ev #button
h <- get bev #x
k <- get bev #y
cam <- readIORef (stCamera st)
let d = camPos cam + computeDirection cam h k
pushBack (stRingBuffer st) (2 * realToFrac h/camWidth cam - 1) (1 - 2 * realToFrac k/camHeight cam) 1 -- (d!0) (d!1) (d!2)
Just win <- getWidgetWindow w
windowInvalidateRect win Nothing False
_ -> do
bev <- get ev #button
h <- get bev #x
k <- get bev #y
updateCameraRotation w st h k
sanitizeCamera st
writeIORef (stDragFrom st) Nothing
EventTypeScroll -> do
sev <- get ev #scroll
d <- get sev #direction
let δ = case d of
ScrollDirectionDown -> - pi/180
ScrollDirectionUp -> pi/180
_ -> 0
when (δ /= 0) $ do
modifyIORef (stCamera st) $ \cam -> cam
{ camHeightAngle = δ + camHeightAngle cam
, camWorldToScreen = Nothing
, camScreenToWorld = Nothing
}
mwin <- widgetGetWindow w
forM_ mwin $ \win ->
windowInvalidateRect win Nothing False
put d
return ()
EventTypeKeyPress -> do
kev <- get ev #key
val <- get kev #keyval <&> \k -> if k > 0x5A then k - 0x20 else k
case val of
KEY_N -> do
modifyIORef' (stSkybox st) $ \n -> (n + 1) `mod` (skyboxCount $ stSkyboxes st)
idx <- readIORef (stSkybox st)
when (skyboxCount (stSkyboxes st) > 1) $ do
Right ts <- skyboxLoad (stSkyboxes st) idx
disposeTextureCube =<< readIORef (stSkyTexture st)
skybox_id <- uploadCubeMapToGPU ts
LC.updateUniforms (stStorage realized) $ do
"CubeMap" @= return skybox_id
writeIORef (stSkyTexture st) skybox_id
put (skyboxNames (stSkyboxes st) !! idx)
return ()
KEY_F -> do
put 'F'
stFullscreen st
_ -> return ()
e -> return ()
return False
|