diff options
Diffstat (limited to 'MeshSketch.hs')
-rw-r--r-- | MeshSketch.hs | 47 |
1 files changed, 45 insertions, 2 deletions
diff --git a/MeshSketch.hs b/MeshSketch.hs index 331d435..30d14b7 100644 --- a/MeshSketch.hs +++ b/MeshSketch.hs | |||
@@ -4,6 +4,8 @@ | |||
4 | module MeshSketch where | 4 | module MeshSketch where |
5 | 5 | ||
6 | import Control.Monad | 6 | import Control.Monad |
7 | import qualified Data.Aeson as JSON | ||
8 | import qualified Data.ByteString as SB | ||
7 | import Data.Coerce | 9 | import Data.Coerce |
8 | import Data.Functor | 10 | import Data.Functor |
9 | import Data.IORef | 11 | import Data.IORef |
@@ -12,7 +14,11 @@ import GI.Gdk | |||
12 | import GI.GObject.Functions | 14 | import GI.GObject.Functions |
13 | import GI.Gtk hiding (IsWindow,windowFullscreen,windowUnfullscreen) | 15 | import GI.Gtk hiding (IsWindow,windowFullscreen,windowUnfullscreen) |
14 | import Numeric.LinearAlgebra | 16 | import Numeric.LinearAlgebra |
17 | import LambdaCube.GL as LC | ||
18 | import LambdaCube.IR | ||
19 | import System.IO.Error | ||
15 | 20 | ||
21 | import LambdaCube.Gtk | ||
16 | import CubeMap | 22 | import CubeMap |
17 | 23 | ||
18 | data MeshMaker = MeshMaker | 24 | data MeshMaker = MeshMaker |
@@ -36,6 +42,10 @@ data State = State | |||
36 | , stSkyboxes :: Skyboxes | 42 | , stSkyboxes :: Skyboxes |
37 | , stSkybox :: IORef Int | 43 | , stSkybox :: IORef Int |
38 | , stFullscreen :: IO () | 44 | , stFullscreen :: IO () |
45 | , stPipeline :: Pipeline | ||
46 | , stSchema :: PipelineSchema | ||
47 | , stStorage :: GLStorage | ||
48 | , stRenderer :: GLRenderer | ||
39 | } | 49 | } |
40 | 50 | ||
41 | initCamera :: Camera | 51 | initCamera :: Camera |
@@ -61,6 +71,18 @@ new = do | |||
61 | -- _ <- on w #destroy $ onDestroy mm | 71 | -- _ <- on w #destroy $ onDestroy mm |
62 | return w | 72 | return w |
63 | 73 | ||
74 | loadPipeline :: IO (Either String (PipelineSchema,Pipeline)) | ||
75 | loadPipeline = do | ||
76 | pipelineDesc <- do | ||
77 | maybe (Left "Unable to parse meshsketch.json") Right . JSON.decodeStrict <$> SB.readFile "meshsketch.json" | ||
78 | `catchIOError` \e -> return $ Left (show e) | ||
79 | -- setup render data | ||
80 | let inputSchema = makeSchema $ do | ||
81 | defObjectArray "skypoints" Points $ do | ||
82 | "position" @: Attribute_V3F | ||
83 | return $ (,) inputSchema <$> pipelineDesc | ||
84 | |||
85 | |||
64 | onRealize :: MeshMaker -> IO () | 86 | onRealize :: MeshMaker -> IO () |
65 | onRealize mm@(MeshMaker w ref) = do | 87 | onRealize mm@(MeshMaker w ref) = do |
66 | putStrLn "realize!" | 88 | putStrLn "realize!" |
@@ -76,6 +98,16 @@ onRealize mm@(MeshMaker w ref) = do | |||
76 | , EventMaskScrollMask | 98 | , EventMaskScrollMask |
77 | , EventMaskKeyPressMask -- , EventMaskKeyReleaseMask | 99 | , EventMaskKeyPressMask -- , EventMaskKeyReleaseMask |
78 | ] | 100 | ] |
101 | |||
102 | Right (schema,pipeline) <- loadPipeline | ||
103 | |||
104 | gLAreaMakeCurrent w | ||
105 | |||
106 | storage <- allocStorage schema | ||
107 | -- upload state | ||
108 | renderer <- allocRenderer pipeline | ||
109 | compat <- setStorage renderer storage -- check schema compatibility | ||
110 | |||
79 | cam <- newIORef initCamera | 111 | cam <- newIORef initCamera |
80 | skyboxes <- loadSkyboxes | 112 | skyboxes <- loadSkyboxes |
81 | skybox <- newIORef 0 | 113 | skybox <- newIORef 0 |
@@ -87,9 +119,14 @@ onRealize mm@(MeshMaker w ref) = do | |||
87 | , stSkyboxes = skyboxes | 119 | , stSkyboxes = skyboxes |
88 | , stSkybox = skybox | 120 | , stSkybox = skybox |
89 | , stFullscreen = toggle | 121 | , stFullscreen = toggle |
122 | , stPipeline = pipeline | ||
123 | , stSchema = schema | ||
124 | , stStorage = storage | ||
125 | , stRenderer = renderer | ||
90 | } | 126 | } |
91 | 127 | ||
92 | _ <- on w #event $ onEvent w st | 128 | _ <- on w #event $ onEvent w st |
129 | _ <- on w #render $ onRender w st | ||
93 | writeIORef ref $ Just st | 130 | writeIORef ref $ Just st |
94 | 131 | ||
95 | onUnrealize :: MeshMaker -> IO () | 132 | onUnrealize :: MeshMaker -> IO () |
@@ -97,13 +134,19 @@ onUnrealize (MeshMaker w ref) = do | |||
97 | putStrLn "unrealize!" | 134 | putStrLn "unrealize!" |
98 | readIORef ref >>= \case | 135 | readIORef ref >>= \case |
99 | Just st -> do | 136 | Just st -> do |
137 | -- signalHandlerDisconnect w (sigRender st) | ||
138 | -- signalHandlerDisconnect w (sigEvent st) | ||
100 | return () | 139 | return () |
101 | Nothing -> return () -- Shouldn't happen. | 140 | Nothing -> return () -- Shouldn't happen. |
102 | writeIORef ref Nothing | 141 | writeIORef ref Nothing |
103 | 142 | ||
104 | 143 | ||
105 | onRender :: MeshMaker -> GLContext -> IO Bool | 144 | onRender :: w -> State -> GLContext -> IO Bool |
106 | onRender (MeshMaker w ref) gl = do | 145 | onRender w st gl = do |
146 | putStrLn "render" | ||
147 | r <- fixupRenderTarget (stRenderer st) | ||
148 | -- lcSetUniforms lc gl s x | ||
149 | LC.renderFrame r | ||
107 | return True | 150 | return True |
108 | 151 | ||
109 | onEvent :: w -> State -> Event -> IO Bool | 152 | onEvent :: w -> State -> Event -> IO Bool |