From 5024860293943ad598d4d89331bdc1615a862d25 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Wed, 19 Jun 2019 02:28:58 -0400 Subject: Load mesh in background. --- GPURing.hs | 3 --- MeshSketch.hs | 79 ++++++++++++++++++++++++++++++++++++++++---------------- lambda-gtk.cabal | 1 + 3 files changed, 58 insertions(+), 25 deletions(-) diff --git a/GPURing.hs b/GPURing.hs index 904c551..a315349 100644 --- a/GPURing.hs +++ b/GPURing.hs @@ -20,9 +20,6 @@ import LambdaCube.GL.Input.Type import LambdaCube.GL.Input hiding (createObjectCommands) --- | Typical usage: --- --- > ringBuffer <- newRing capacity (VectorRing.new capacity) type Update keys = (keys -> Writer [DSum AttributeKey GLUniformValue] ()) new :: Data keys => Primitive -> String -> GLStorage -> (String -> String) -> Int -> IO (TargetBuffer (Update keys)) diff --git a/MeshSketch.hs b/MeshSketch.hs index 8c18b67..87d9763 100644 --- a/MeshSketch.hs +++ b/MeshSketch.hs @@ -176,8 +176,8 @@ xzPlaneVector :: Vector Float xzPlaneVector = fromList [ 0,1,0 -- unit normal , 0 ] -- distance from origin -uploadState :: MeshData -> MeshSketch -> GLStorage -> IO State -uploadState obj mm storage = do +stateChangeMesh :: MeshData -> MeshSketch -> GLStorage -> State -> IO State +stateChangeMesh obj mm storage st = do let glarea = mmWidget mm -- load OBJ geometry and material descriptions let workarea = BoundingBox (-2.5) (2.5) (-2.5) 2.5 (-2.5) (2.5) @@ -191,23 +191,26 @@ uploadState obj mm storage = do let gs = Map.keys $ foldr (\a ms -> Map.union (groupMasks a) ms) Map.empty bufs forM_ gs $ \groupname -> do addToGroupsPane (mmListStore mm) True groupname - objsRef <- newIORef bufs - masksRef <- newIORef $ map (objSpan . maskableObject) bufs + writeIORef (stObjects st) bufs + writeIORef (stMasks st) $ map (objSpan . maskableObject) bufs + return st +initializeState :: MeshSketch -> GLStorage -> IO State +initializeState mm storage = do + let glarea = mmWidget mm + objsRef <- newIORef [] + masksRef <- newIORef [] -- grid plane uploadMeshToGPU xzplane >>= addMeshToObjectArray storage "plane" [] - let bufsize = 1000 v <- MV.unsafeNew bufsize pts <- newRing bufsize (Vector.new v) ring <- newRing bufsize (GPU.new LineStrip "Curve" storage ringPointAttr bufsize) cpts <- newRing 100 (GPU.new PointList "Points" storage ringPointAttr 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 @@ -225,14 +228,12 @@ uploadState obj mm storage = do skytex <- newIORef skybox_id mi <- LC.uploadMeshToGPU cubeMesh LC.addMeshToObjectArray storage "SkyCube" [] mi - drag <- newIORef Nothing dragPlane <- newIORef Nothing pendown <- newIORef False plane <- newIORef $ Just (xzPlaneVector G.// [(3,-1)]) recentPts <- newIORef Give0 angle <- newIORef 0 - let st = State { stAnimator = tm , stCamera = cam @@ -254,10 +255,8 @@ uploadState obj mm storage = do , stMasks = masksRef } -- _ <- addAnimation tm (whirlingCamera st) - return st - destroyState :: GLArea -> State -> IO () destroyState glarea st = do -- widgetRemoveTickCallback glarea (stTickCallback st) @@ -313,6 +312,21 @@ data Realized = Realized , stSigs :: [SignalHandlerId] -- Signals attached by onRealize. } +-- | Assumes the executable is nested somewhere in the source tree like so: +-- +-- //build/.../ +-- +-- If a "build" directory was not found, an empty string is returned. +findSrcTree :: IO FilePath +findSrcTree = do + exe <- getExecutablePath + let ps = reverse . drop 2 + . dropWhile (/="build") + . reverse + . splitDirectories + . takeDirectory $ exe + return $ foldr () "" ps + findModule :: FilePath -> IO FilePath findModule fn = do let checkPath action next = do @@ -321,16 +335,19 @@ findModule fn = do found <- doesFileExist f if found then return f else next - foldr checkPath (return fn) [getExecutablePath,getCurrentDirectory] + foldr checkPath (return fn) [getExecutablePath,findSrcTree,getCurrentDirectory] + +loadInitialMesh kont = do + objName <- head . (++ ["cube.obj"]) <$> getArgs + putStrLn $ "Loading object "++objName++"..." + mobj <- loadOBJ objName + putStrLn $ "Finisehd loading object "++objName++"." + kont mobj new :: IO Gtk.Paned new = do putStrLn "new!" m <- do - objName <- head . (++ ["cube.obj"]) <$> getArgs - putStrLn $ "Loading object "++objName++"..." - mobj <- loadOBJ objName - putStrLn $ "Finisehd loading object "++objName++"." -- mpipeline <- (\s -> return (Right (DynamicPipeline savedPipeline (makeSchema s)))) $ do ppath <- findModule "hello_obj2.json" mpipeline <- loadPipeline ppath $ do @@ -358,8 +375,8 @@ new = do "PointsStart" @: Int "diffuseTexture" @: FTexture2D "diffuseColor" @: V4F - return $ (,) <$> mobj <*> mpipeline - either (\e _ -> hPutStrLn stderr e >> throwIO (userError e)) (&) m $ \(obj,pipeline) -> do + return mpipeline + either (\e _ -> hPutStrLn stderr e >> throwIO (userError e)) (&) m $ \pipeline -> do mapM_ (putStrLn . ppShow) (targets $ dynamicPipeline pipeline) ref <- newIORef Nothing g <- gLAreaNew @@ -368,7 +385,7 @@ new = do let mm = MeshSketch g panes groups liststore ref gLAreaSetHasDepthBuffer g True st <- return g - _ <- on g #realize $ withCurrentGL g (onRealize obj (dynamicPipeline pipeline) (dynamicSchema pipeline) mm) + _ <- on g #realize $ withCurrentGL g (onRealize (dynamicPipeline pipeline) (dynamicSchema pipeline) mm) _ <- on g #unrealize $ onUnrealize mm _ <- on g #createContext $ nullableContext (onCreateContext g) panedPack1 panes g True True @@ -441,8 +458,22 @@ onUnrealize mm = do -- lcDestroyState lc x writeIORef (mmRealized mm) Nothing -onRealize :: MeshData -> Pipeline -> PipelineSchema -> MeshSketch -> IO () -onRealize mesh pipeline schema mm = do +onLoadedMesh :: MeshSketch -> Either String MeshData -> IO Bool +onLoadedMesh mm mmesh = do + case mmesh of + Left e -> putStrLn e + Right mesh -> do + mr <- readIORef (mmRealized mm) + forM_ mr $ \r -> do + x <- stateChangeMesh mesh mm (stStorage r) (stState r) + writeIORef (mmRealized mm) $ Just r { stState = x } + mwin <- widgetGetWindow (mmWidget mm) + forM_ mwin $ \win -> + windowInvalidateRect win Nothing False + return False + +onRealize :: Pipeline -> PipelineSchema -> MeshSketch -> IO () +onRealize pipeline schema mm = do putStrLn "onRealize!" onUnrealize mm setupGLDebugging @@ -452,7 +483,7 @@ onRealize mesh pipeline schema mm = do renderer <- LC.allocRenderer pipeline compat <- LC.setStorage renderer storage -- check schema compatibility -- putStrLn $ "setStorage compat = " ++ show compat - x <- uploadState mesh mm storage + x <- initializeState mm storage let r = Realized { stStorage = storage , stRenderer = renderer @@ -484,6 +515,10 @@ onRealize mesh pipeline schema mm = do panedSetPosition (mmPaned mm) (panedW * 8 `div` 10) -- widgetQueueAllocate (mmPaned mm) writeIORef (mmRealized mm) $ Just r { stSigs = [sige,sigr,sigs] } + forkOS $ loadInitialMesh $ \mmesh -> do + sid <- threadsAddIdle PRIORITY_DEFAULT_IDLE $ onLoadedMesh mm mmesh + return () + return () onRender :: w -> Realized -> GLContext -> IO Bool onRender w realized gl = do diff --git a/lambda-gtk.cabal b/lambda-gtk.cabal index 24340d8..02dbc85 100644 --- a/lambda-gtk.cabal +++ b/lambda-gtk.cabal @@ -66,3 +66,4 @@ executable meshsketch gi-gdk , gi-glib , gi-gobject , gi-gtk , haskell-gi-base default-language: Haskell2010 + ghc-options: -threaded -- cgit v1.2.3