diff options
author | Joe Crayne <joe@jerkface.net> | 2019-04-29 17:33:10 -0400 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2019-04-29 17:33:10 -0400 |
commit | d04c6fb9334493b9afa23bc7df2cddbae7fd4903 (patch) | |
tree | ec4bd2007d4e666691430a80a3e877e0396bf054 | |
parent | 2c277a7d3c25aa792c9d2d324b8e70296d4b453c (diff) |
Continued rework toward MeshSketch design.
-rw-r--r-- | MeshSketch.hs | 80 |
1 files changed, 65 insertions, 15 deletions
diff --git a/MeshSketch.hs b/MeshSketch.hs index 9b75d9b..c56d34f 100644 --- a/MeshSketch.hs +++ b/MeshSketch.hs | |||
@@ -9,6 +9,7 @@ import Control.Concurrent | |||
9 | import Control.Monad | 9 | import Control.Monad |
10 | import Data.Word | 10 | import Data.Word |
11 | import Data.Function ((&)) | 11 | import Data.Function ((&)) |
12 | import Data.Int | ||
12 | import Data.IORef | 13 | import Data.IORef |
13 | import Data.Text (Text) | 14 | import Data.Text (Text) |
14 | import Data.Map.Strict (Map) | 15 | import Data.Map.Strict (Map) |
@@ -25,10 +26,13 @@ import System.Environment | |||
25 | import System.IO | 26 | import System.IO |
26 | import System.IO.Error | 27 | import System.IO.Error |
27 | import Control.Exception | 28 | import Control.Exception |
29 | import LambdaCube.GL as LC | ||
30 | import LambdaCube.IR as LC | ||
31 | import LambdaCube.Gtk | ||
28 | 32 | ||
29 | import GLWidget | 33 | import GLWidget (nullableContext, withCurrentGL) |
30 | import LambdaCube.GL.HMatrix | 34 | import LambdaCube.GL.HMatrix |
31 | import LambdaCubeWidget | 35 | import LambdaCubeWidget (loadPipeline,DynamicPipeline(..)) |
32 | import TimeKeeper | 36 | import TimeKeeper |
33 | import LoadMesh | 37 | import LoadMesh |
34 | import InfinitePlane | 38 | import InfinitePlane |
@@ -102,6 +106,10 @@ data MeshSketch = MeshSketch | |||
102 | } | 106 | } |
103 | 107 | ||
104 | data Realized = Realized | 108 | data Realized = Realized |
109 | { stStorage :: GLStorage | ||
110 | , stRenderer :: GLRenderer | ||
111 | , stState :: State | ||
112 | } | ||
105 | 113 | ||
106 | new :: IO MeshSketch | 114 | new :: IO MeshSketch |
107 | new = do | 115 | new = do |
@@ -122,19 +130,61 @@ new = do | |||
122 | "diffuseColor" @: V4F | 130 | "diffuseColor" @: V4F |
123 | return $ (,) <$> mobj <*> mpipeline | 131 | return $ (,) <$> mobj <*> mpipeline |
124 | either (\e _ -> hPutStrLn stderr e >> throwIO (userError e)) (&) m $ \(obj,pipeline) -> do | 132 | either (\e _ -> hPutStrLn stderr e >> throwIO (userError e)) (&) m $ \(obj,pipeline) -> do |
125 | app <- do | ||
126 | mvar <- newEmptyMVar | ||
127 | return $ \glarea -> LCMethods | ||
128 | { lcRealized = mvar | ||
129 | , lcUploadState = uploadState obj glarea | ||
130 | , lcDestroyState = destroyState glarea | ||
131 | , lcSetUniforms = setUniforms | ||
132 | , lcPipeline = pipeline | ||
133 | } | ||
134 | 133 | ||
135 | ref <- newIORef Nothing | 134 | ref <- newIORef Nothing |
136 | glarea <- newGLWidget return (lambdaRender app glmethods) | 135 | -- glarea <- newGLWidget return (lambdaRender app glmethods) |
137 | return MeshSketch | 136 | do |
138 | { mmWidget = glarea | 137 | g <- gLAreaNew |
139 | , mmRealized = ref | 138 | let mm = MeshSketch g ref |
139 | gLAreaSetHasDepthBuffer g True | ||
140 | st <- return g | ||
141 | -- _ <- on g #render $ glRender w st | ||
142 | -- _ <- on g #resize $ glResize w st | ||
143 | _ <- on g #realize $ withCurrentGL g (onRealize obj (dynamicPipeline pipeline) (dynamicSchema pipeline) mm) | ||
144 | _ <- on g #unrealize $ onUnrealize mm | ||
145 | -- _ <- on g #createContext $ nullableContext (glCreateContext w st) | ||
146 | return mm | ||
147 | |||
148 | onUnrealize :: MeshSketch -> IO () | ||
149 | onUnrealize mm = do | ||
150 | m <- readIORef (mmRealized mm) | ||
151 | forM_ m $ \st -> do | ||
152 | LC.disposeStorage (stStorage st) | ||
153 | LC.disposeRenderer (stRenderer st) | ||
154 | -- lcDestroyState lc x | ||
155 | |||
156 | onRealize :: MeshData -> Pipeline -> PipelineSchema -> MeshSketch -> IO () | ||
157 | onRealize mesh pipeline schema mm = do | ||
158 | onUnrealize mm | ||
159 | storage <- LC.allocStorage schema | ||
160 | renderer <- LC.allocRenderer pipeline | ||
161 | compat <- LC.setStorage renderer storage -- check schema compatibility | ||
162 | x <- uploadState mesh (mmWidget mm) storage | ||
163 | let r = Realized | ||
164 | { stStorage = storage | ||
165 | , stRenderer = renderer | ||
166 | , stState = x | ||
140 | } | 167 | } |
168 | _ <- on (mmWidget mm) #render $ onRender (mmWidget mm) r | ||
169 | _ <- on (mmWidget mm) #resize $ onResize (mmWidget mm) r | ||
170 | writeIORef (mmRealized mm) $ Just r | ||
171 | |||
172 | onRender :: w -> Realized -> GLContext -> IO Bool | ||
173 | onRender w realized gl = do | ||
174 | r <- fixupRenderTarget (stRenderer realized) | ||
175 | setUniforms gl (stStorage realized) (stState realized) | ||
176 | LC.renderFrame r | ||
177 | return True | ||
178 | |||
179 | onResize :: GLArea -> Realized -> Int32 -> Int32 -> IO () | ||
180 | onResize glarea realized w h = do | ||
181 | let storage = stStorage realized | ||
182 | -- Plenty of options here. I went with the last one. | ||
183 | -- 1. gLContextGetWindow :: HasCallStack => GLContext -> IO (Maybe Window) | ||
184 | -- 2. getGLContextWindow :: GLContext -> IO (Maybe Window) | ||
185 | -- 3. widgetGetWindow :: HasCallStack => GLArea -> IO (Maybe Window) | ||
186 | widgetGetWindow glarea >>= mapM_ (\win -> do | ||
187 | (wd,ht) <- do wd <- windowGetWidth win | ||
188 | ht <- windowGetHeight win | ||
189 | return (fromIntegral wd,fromIntegral ht) | ||
190 | LC.setScreenSize (stStorage realized) wd ht) | ||