Load mesh in background.

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:
+--
+--    <src-tree>/<dist>/build/.../<executable>
+--
+-- 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