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
|
{-# 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.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 GLWidget
import LambdaCube.GL.HMatrix
import LambdaCubeWidget
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
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
app <- do
mvar <- newEmptyMVar
return $ \glarea -> LCMethods
{ lcRealized = mvar
, lcUploadState = uploadState obj glarea
, lcDestroyState = destroyState glarea
, lcSetUniforms = setUniforms
, lcPipeline = pipeline
}
ref <- newIORef Nothing
glarea <- newGLWidget return (lambdaRender app glmethods)
return MeshSketch
{ mmWidget = glarea
, mmRealized = ref
}
|
