summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoe Crayne <joe@jerkface.net>2019-04-29 16:44:20 -0400
committerJoe Crayne <joe@jerkface.net>2019-04-29 16:44:20 -0400
commit2c277a7d3c25aa792c9d2d324b8e70296d4b453c (patch)
tree3f156ff2a984bfea7f14e0d80f54ec18a6ad0418
parentedbc09c280c1699933c443795686394c1e9e8de5 (diff)
WIP: Abandon GLWidget in favor of (non-working) MeshSketch design.
Diffstat
-rw-r--r--MeshSketch.hs349
-rw-r--r--mainObj.hs142
2 files changed, 143 insertions, 348 deletions
diff --git a/MeshSketch.hs b/MeshSketch.hs
index 9d49f93..9b75d9b 100644
--- a/MeshSketch.hs
+++ b/MeshSketch.hs
@@ -1,247 +1,140 @@
1{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE OverloadedLabels #-} 1{-# LANGUAGE OverloadedLabels #-}
3{-# LANGUAGE PatternSynonyms #-} 2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE RecordWildCards #-}
4module MeshSketch where 5module MeshSketch where
5 6
7import Codec.Picture as Juicy
8import Control.Concurrent
6import Control.Monad 9import Control.Monad
7import qualified Data.Aeson as JSON 10import Data.Word
8import qualified Data.ByteString as SB 11import Data.Function ((&))
9import Data.Coerce
10import Data.Functor
11import qualified Data.Map as Map
12import qualified Data.Vector as V
13import Data.IORef 12import Data.IORef
14import Foreign.C.Types 13import Data.Text (Text)
15import GI.Gdk 14import Data.Map.Strict (Map)
16import GI.GObject.Functions 15import qualified Data.Map.Strict as Map
17import GI.Gtk hiding (IsWindow,windowFullscreen,windowUnfullscreen) 16import qualified Data.Vector as V
17import GI.Gdk.Objects
18import GI.GLib.Constants
19import qualified GI.Gtk as Gtk (main)
20import GI.Gtk as Gtk hiding (main)
21import LambdaCube.GL as LC
22import LambdaCube.GL.Mesh as LC
18import Numeric.LinearAlgebra hiding ((<>)) 23import Numeric.LinearAlgebra hiding ((<>))
19import LambdaCube.GL as LC 24import System.Environment
20import LambdaCube.GL.Mesh as LC 25import System.IO
21import LambdaCube.GL.Data
22-- import LambdaCube.GL.Type as LC
23import LambdaCube.IR
24import System.IO.Error 26import System.IO.Error
25 27import Control.Exception
26import CubeMap 28
27import LambdaCube.GL.HMatrix () 29import GLWidget
28import LambdaCube.Gtk 30import LambdaCube.GL.HMatrix
31import LambdaCubeWidget
32import TimeKeeper
33import LoadMesh
34import InfinitePlane
35import MtlParser (ObjMaterial(..))
29import Matrix 36import Matrix
30 37
31data MeshMaker = MeshMaker 38-- State created by uploadState.
32 { mmWidget :: GLArea 39data State = State
33 , mmRealized :: IORef (Maybe State) 40 { stTimeKeeper :: TimeKeeper
41 , stTickCallback :: TickCallbackHandle
34 } 42 }
35 43
36data Camera = Camera 44addOBJToObjectArray :: GLStorage -> String -> [(GPUMesh, Maybe Text)] -> Map Text (ObjMaterial,TextureData) -> IO [LC.Object]
37 { camHeightAngle :: Float 45addOBJToObjectArray storage slotName objMesh mtlLib = forM objMesh $ \(mesh,mat) -> do
38 , camTarget :: Vector Float 46 obj <- LC.addMeshToObjectArray storage slotName ["diffuseTexture","diffuseColor"] mesh
39 , camDirection :: Vector Float 47 -- diffuseTexture and diffuseColor values can change on each model
40 , camDistance :: Float 48 case mat >>= flip Map.lookup mtlLib of
41 , camWidth :: Float 49 Nothing -> return ()
42 , camHeight :: Float 50 Just (ObjMaterial{..},t) -> LC.updateObjectUniforms obj $ do
43 , camUp :: Vector Float 51 "diffuseTexture" @= return t -- set model's diffuse texture
44 , camWorldToScreen :: Maybe (Matrix Float) 52 "diffuseColor" @= let (r,g,b) = mtl_Kd in return (V4 r g b mtl_Tr)
45 , camScreenToWorld :: Maybe (Matrix Float) 53 return obj
46 } 54
55
56uploadState :: IsWidget glarea => MeshData -> glarea -> GLStorage -> IO State
57uploadState obj glarea storage = do
58 -- load OBJ geometry and material descriptions
59 (objMesh,mtlLib) <- uploadOBJToGPU obj
60 -- load materials textures
61 gpuMtlLib <- uploadMtlLib mtlLib
62 -- add OBJ to pipeline input
63 addOBJToObjectArray storage "objects" objMesh gpuMtlLib
64 -- grid plane
65 uploadMeshToGPU xzplane >>= addMeshToObjectArray storage "plane" []
66
67 -- setup FrameClock
68 tm <- newTimeKeeper
69 tickcb <- widgetAddTickCallback glarea (tick tm)
70
71 return State
72 { stTimeKeeper = tm
73 , stTickCallback = tickcb
74 }
47 75
48data State = State 76destroyState :: GLArea -> State -> IO ()
49 { stCamera :: IORef Camera 77destroyState glarea st = do
50 , stSkyboxes :: Skyboxes 78 widgetRemoveTickCallback glarea (stTickCallback st)
51 , stSkybox :: IORef Int 79
52 , stFullscreen :: IO () 80deg30 :: Float
53 , stPipeline :: Pipeline 81deg30 = pi/6
54 , stSchema :: PipelineSchema 82
55 , stStorage :: GLStorage 83setUniforms :: glctx -> GLStorage -> State -> IO ()
56 , stRenderer :: GLRenderer 84setUniforms gl storage st = do
57 } 85 t <- (/ 10.0) <$> getSeconds (stTimeKeeper st)
86 let tf = realToFrac t :: Float
87 rot = rotMatrixZ (-tf) <> rotMatrixX (-tf)
88 pos = rot #> fromList [2,2,10]
89 up = rot #> fromList [0,1,0]
90 cam = lookat pos 0 up
91 aspect = 1
92 proj = perspective 0.1 100 deg30 aspect
93 mvp = proj <> cam
58 94
59initCamera :: Camera 95 LC.updateUniforms storage $ do
60initCamera = Camera 96 "CameraPosition" @= return (pos :: Vector Float)
61 { camHeightAngle = pi/6 97 "ViewProjection" @= return (mvp :: Matrix Float)
62 , camTarget = fromList [0,0,0]
63 , camDirection = fromList [0,0,-1]
64 , camDistance = 10
65 , camWidth = 0
66 , camHeight = 0
67 , camUp = fromList [0,1,0]
68 , camWorldToScreen = Nothing
69 , camScreenToWorld = Nothing
70 }
71 98
72viewProjection :: Camera -> (Camera,Matrix Float) 99data MeshSketch = MeshSketch
73viewProjection c 100 { mmWidget :: GLArea
74 | Just m <- camWorldToScreen c = (c,m) 101 , mmRealized :: IORef (Maybe Realized)
75 | otherwise = (c { camWorldToScreen = Just m' }, m') 102 }
76 where
77 m' = proj <> cam
78 cam = lookat pos (camTarget c) (camUp c)
79 pos = camTarget c - scale (camDistance c) (camDirection c)
80 proj = perspective 0.1 100 (camHeightAngle c) (camWidth c / camHeight c)
81 103
104data Realized = Realized
82 105
83new :: IO GLArea 106new :: IO MeshSketch
84new = do 107new = do
85 w <- gLAreaNew 108 m <- do
86 ref <- newIORef Nothing 109 objName <- head . (++ ["cube.obj"]) <$> getArgs
87 let mm = MeshMaker w ref 110 mobj <- loadOBJ objName
88 -- _ <- on w #createContext $ onCreateContext mm 111 mpipeline <- loadPipeline "hello_obj2.json" $ do
89 _ <- on w #realize $ onRealize mm 112 defObjectArray "objects" Triangles $ do
90 _ <- on w #unrealize $ onUnrealize mm 113 "position" @: Attribute_V4F
91 -- _ <- on w #destroy $ onDestroy mm 114 "normal" @: Attribute_V3F
92 return w 115 "uvw" @: Attribute_V3F
93 116 defObjectArray "plane" Triangles $ do
94loadPipeline :: IO (Either String (PipelineSchema,Pipeline)) 117 "position" @: Attribute_V4F
95loadPipeline = do
96 pipelineDesc <- do
97 maybe (Left "Unable to parse meshsketch.json") Right . JSON.decodeStrict <$> SB.readFile "meshsketch.json"
98 `catchIOError` \e -> return $ Left (show e)
99 -- setup render data
100 let inputSchema = makeSchema $ do
101 defObjectArray "skypoints" Points $ do
102 "position" @: Attribute_V3F
103 defUniforms $ do 118 defUniforms $ do
104 "Cam" @: M44F 119 "CameraPosition" @: V3F
105 "Skybox" @: FTextureCube 120 "ViewProjection" @: M44F
106 return $ (,) inputSchema <$> pipelineDesc 121 "diffuseTexture" @: FTexture2D
107 122 "diffuseColor" @: V4F
108 123 return $ (,) <$> mobj <*> mpipeline
109onRealize :: MeshMaker -> IO () 124 either (\e _ -> hPutStrLn stderr e >> throwIO (userError e)) (&) m $ \(obj,pipeline) -> do
110onRealize mm@(MeshMaker w ref) = do 125 app <- do
111 putStrLn "realize!" 126 mvar <- newEmptyMVar
112 readIORef ref >>= \case 127 return $ \glarea -> LCMethods
113 Just st -> onUnrealize mm -- Shouldn't happen. 128 { lcRealized = mvar
114 Nothing -> return () 129 , lcUploadState = uploadState obj glarea
115 set w [ #canFocus := True ] -- For keyboard events. 130 , lcDestroyState = destroyState glarea
116 widgetAddEvents w 131 , lcSetUniforms = setUniforms
117 [ EventMaskPointerMotionMask 132 , lcPipeline = pipeline
118 , EventMaskButtonPressMask 133 }
119 , EventMaskButtonReleaseMask 134
120 , EventMaskTouchMask 135 ref <- newIORef Nothing
121 , EventMaskScrollMask 136 glarea <- newGLWidget return (lambdaRender app glmethods)
122 , EventMaskKeyPressMask -- , EventMaskKeyReleaseMask 137 return MeshSketch
123 ] 138 { mmWidget = glarea
124 139 , mmRealized = ref
125 Right (schema,pipeline) <- loadPipeline
126
127 gLAreaMakeCurrent w
128
129 storage <- allocStorage schema
130 -- upload state
131 renderer <- allocRenderer pipeline
132 compat <- setStorage renderer storage -- check schema compatibility
133
134 cam <- newIORef initCamera
135 skyboxes <- loadSkyboxes
136 skybox <- newIORef 0
137 Right ts <- skyboxLoad skyboxes 0
138 skybox_id <- uploadCubeMapToGPU ts
139 mi <- LC.uploadMeshToGPU Mesh
140 { mAttributes = Map.singleton "position" $ A_V3F $ V.fromList
141 [ V3 0 0 (-1)
142 , V3 0 0 1
143 , V3 0 (-1) 0
144 , V3 0 1 0
145 , V3 (-1) 0 0
146 , V3 01 0 0
147 ]
148 , mPrimitive = P_Points
149 }
150 LC.addMeshToObjectArray storage "skypoints" [] mi
151 LC.updateUniforms storage $ do
152 "Skybox" @= return skybox_id
153 Just pwidget <- get w #parent
154 Just parent <- get pwidget #window
155 toggle <- mkFullscreenToggle parent
156 let st = State
157 { stCamera = cam
158 , stSkyboxes = skyboxes
159 , stSkybox = skybox
160 , stFullscreen = toggle
161 , stPipeline = pipeline
162 , stSchema = schema
163 , stStorage = storage
164 , stRenderer = renderer
165 } 140 }
166
167 _ <- on w #event $ onEvent w st
168 _ <- on w #render $ onRender w st
169 writeIORef ref $ Just st
170
171onUnrealize :: MeshMaker -> IO ()
172onUnrealize (MeshMaker w ref) = do
173 putStrLn "unrealize!"
174 readIORef ref >>= \case
175 Just st -> do
176 -- signalHandlerDisconnect w (sigRender st)
177 -- signalHandlerDisconnect w (sigEvent st)
178 return ()
179 Nothing -> return () -- Shouldn't happen.
180 writeIORef ref Nothing
181
182
183onRender :: w -> State -> GLContext -> IO Bool
184onRender w st gl = do
185 putStrLn "render"
186 mat_vp <- atomicModifyIORef' (stCamera st) viewProjection
187 r <- fixupRenderTarget (stRenderer st)
188 {-
189 let ks = Map.keys $ uniformSetup (stStorage st)
190 us = uniforms (stSchema st)
191 print (us,ks)
192 -}
193 LC.updateUniforms (stStorage st) $ do
194 "Cam" @= return mat_vp
195 -- todo Skybox texture
196 LC.renderFrame r
197 return True
198
199onEvent :: w -> State -> Event -> IO Bool
200onEvent w st ev = do
201 msrc <- eventGetSourceDevice ev
202 inputSource <- forM msrc $ \src -> do
203 src <- get src #inputSource
204 return src
205 etype <- get ev #type
206 -- putStrLn $ "onEvent! " ++ show (etype,inputSource)
207 let put x = putStrLn (show inputSource ++ " " ++ show x)
208 case etype of
209
210 EventTypeMotionNotify -> do
211 mev <- get ev #motion
212 x <- get mev #x
213 y <- get mev #y
214 put (x,y)
215 return ()
216
217 EventTypeScroll -> do
218 sev <- get ev #scroll
219 d <- get sev #direction
220 put d
221 return ()
222
223 EventTypeKeyPress -> do
224 kev <- get ev #key
225 val <- get kev #keyval <&> \k -> if k > 0x5A then k - 0x20 else k
226 case val of
227 KEY_N -> do
228 modifyIORef' (stSkybox st) $ \n -> (n + 1) `mod` (skyboxCount $ stSkyboxes st)
229 idx <- readIORef (stSkybox st)
230 put (skyboxNames (stSkyboxes st) !! idx)
231 return ()
232 KEY_F -> do
233 put 'F'
234 stFullscreen st
235 _ -> return ()
236
237 e -> return ()
238
239 return False
240
241mkFullscreenToggle :: IsWindow a => a -> IO (IO ())
242mkFullscreenToggle w = do
243 full <- newIORef False
244 return $ do
245 b <- atomicModifyIORef' full $ \b -> (not b, not b)
246 if b then windowFullscreen w
247 else windowUnfullscreen w
diff --git a/mainObj.hs b/mainObj.hs
index 970f94c..caf6501 100644
--- a/mainObj.hs
+++ b/mainObj.hs
@@ -1,127 +1,29 @@
1{-# LANGUAGE OverloadedLabels #-} 1{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE OverloadedLabels #-}
2{-# LANGUAGE OverloadedStrings #-} 3{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE LambdaCase #-} 4{-# LANGUAGE RecordWildCards #-}
4{-# LANGUAGE RecordWildCards #-}
5module Main where 5module Main where
6 6
7import Codec.Picture as Juicy 7import qualified GI.Gtk as Gtk (main)
8import Control.Concurrent 8 ;import GI.Gtk as Gtk hiding (main)
9import Control.Monad
10import Data.Word
11import Data.Function
12import Data.Text (Text)
13import Data.Map.Strict (Map)
14import qualified Data.Map.Strict as Map
15import qualified Data.Vector as V
16import GI.Gdk.Objects
17import GI.GLib.Constants
18import GI.Gtk as Gtk hiding (main)
19import LambdaCube.GL as LC
20import LambdaCube.GL.Mesh as LC
21import Numeric.LinearAlgebra hiding ((<>))
22import System.Environment
23import System.IO
24import System.IO.Error
25 9
26import GLWidget 10import qualified MeshSketch
27import LambdaCube.GL.HMatrix
28import LambdaCubeWidget
29import TimeKeeper
30import LoadMesh
31import InfinitePlane
32import MtlParser (ObjMaterial(..))
33import Matrix
34
35-- State created by uploadState.
36data State = State
37 { stTimeKeeper :: TimeKeeper
38 , stTickCallback :: TickCallbackHandle
39 }
40
41addOBJToObjectArray :: GLStorage -> String -> [(GPUMesh, Maybe Text)] -> Map Text (ObjMaterial,TextureData) -> IO [LC.Object]
42addOBJToObjectArray storage slotName objMesh mtlLib = forM objMesh $ \(mesh,mat) -> do
43 obj <- LC.addMeshToObjectArray storage slotName ["diffuseTexture","diffuseColor"] mesh
44 -- diffuseTexture and diffuseColor values can change on each model
45 case mat >>= flip Map.lookup mtlLib of
46 Nothing -> return ()
47 Just (ObjMaterial{..},t) -> LC.updateObjectUniforms obj $ do
48 "diffuseTexture" @= return t -- set model's diffuse texture
49 "diffuseColor" @= let (r,g,b) = mtl_Kd in return (V4 r g b mtl_Tr)
50 return obj
51
52
53uploadState :: IsWidget glarea => MeshData -> glarea -> GLStorage -> IO State
54uploadState obj glarea storage = do
55 -- load OBJ geometry and material descriptions
56 (objMesh,mtlLib) <- uploadOBJToGPU obj
57 -- load materials textures
58 gpuMtlLib <- uploadMtlLib mtlLib
59 -- add OBJ to pipeline input
60 addOBJToObjectArray storage "objects" objMesh gpuMtlLib
61 -- grid plane
62 uploadMeshToGPU xzplane >>= addMeshToObjectArray storage "plane" []
63
64 -- setup FrameClock
65 tm <- newTimeKeeper
66 tickcb <- widgetAddTickCallback glarea (tick tm)
67
68 return State
69 { stTimeKeeper = tm
70 , stTickCallback = tickcb
71 }
72
73destroyState :: GLArea -> State -> IO ()
74destroyState glarea st = do
75 widgetRemoveTickCallback glarea (stTickCallback st)
76
77deg30 :: Float
78deg30 = pi/6
79
80setUniforms :: glctx -> GLStorage -> State -> IO ()
81setUniforms gl storage st = do
82 t <- (/ 10.0) <$> getSeconds (stTimeKeeper st)
83 let tf = realToFrac t :: Float
84 rot = rotMatrixZ (-tf) <> rotMatrixX (-tf)
85 pos = rot #> fromList [2,2,10]
86 up = rot #> fromList [0,1,0]
87 cam = lookat pos 0 up
88 aspect = 1
89 proj = perspective 0.1 100 deg30 aspect
90 mvp = proj <> cam
91
92 LC.updateUniforms storage $ do
93 "CameraPosition" @= return (pos :: Vector Float)
94 "ViewProjection" @= return (mvp :: Matrix Float)
95 11
96main :: IO () 12main :: IO ()
97main = do 13main = do
98 m <- do 14 _ <- Gtk.init Nothing
99 objName <- head . (++ ["cube.obj"]) <$> getArgs 15
100 mobj <- loadOBJ objName 16 let mkChild = MeshSketch.mmWidget <$> MeshSketch.new
101 mpipeline <- loadPipeline "hello_obj2.json" $ do 17
102 defObjectArray "objects" Triangles $ do 18 window <- do
103 "position" @: Attribute_V4F 19 w <- Gtk.windowNew WindowTypeToplevel
104 "normal" @: Attribute_V3F 20 windowSetDefaultSize w 720 720
105 "uvw" @: Attribute_V3F 21 Gtk.windowSetTitle w "MeshSketch"
106 defObjectArray "plane" Triangles $ do 22 containerSetBorderWidth w 0
107 "position" @: Attribute_V4F 23 _ <- on w #deleteEvent $ \_ -> mainQuit >> return True
108 defUniforms $ do 24 child <- mkChild
109 "CameraPosition" @: V3F 25 containerAdd w child
110 "ViewProjection" @: M44F 26 return w
111 "diffuseTexture" @: FTexture2D 27
112 "diffuseColor" @: V4F 28 widgetShowAll window
113 return $ (,) <$> mobj <*> mpipeline 29 Gtk.main
114 either (\e _ -> hPutStrLn stderr e) (&) m $ \(obj,pipeline) -> do
115 app <- do
116 mvar <- newEmptyMVar
117 return $ \glarea -> LCMethods
118 { lcRealized = mvar
119 , lcUploadState = uploadState obj glarea
120 , lcDestroyState = destroyState glarea
121 , lcSetUniforms = setUniforms
122 , lcPipeline = pipeline
123 }
124
125 runGLApp return (lambdaRender app glmethods)
126 { glTitle = "LambdaCube 3D DSL OBJ viewer"
127 }
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-18 12:18:36 +0000