Engage multiple threads

src/Dodge/Event.hs

@@ -35,11 +35,8 @@ import Control.Lens
 import qualified Data.Set as S
 import SDL
 
-handleEvent :: World -> Event -> Maybe World
-handleEvent = flip handleEvent'
-
-handleEvent' :: Event -> World -> Maybe World
-handleEvent' e = case eventPayload e of
+handleEvent :: Event -> World -> Maybe World
+handleEvent e = case eventPayload e of
     KeyboardEvent kev           -> handleKeyboardEvent kev
     MouseMotionEvent mmev       -> handleMouseMotionEvent mmev
     MouseButtonEvent mbev       -> handleMouseButtonEvent mbev

src/Dodge/Render.hs

@@ -23,6 +23,7 @@ import Shader.Parameters
 import Foreign
 import Control.Lens
 import Control.Monad
+import qualified Control.Monad.Parallel as MP
 import Graphics.Rendering.OpenGL hiding (color,scale,translate,rotate)
 import qualified SDL
 import qualified Data.Vector.Unboxed.Mutable as UMV
@@ -42,16 +43,20 @@ doDrawing pdata w = do
         viewFrom3d = Vector3 vfx vfy 20
         shadV = _pictureShaders pdata
     -- bind as much data into vbos as feasible at this point
-    -- pictures
+    -- pictures setup
     layerCounts <- UMV.replicate (6*6) 0
-    pokeBindFoldableLayer shadV layerCounts $ worldPictures w
-    -- poke wall points and colors
-    nWalls <- poke224s (shadVBOptr $ _wallTextureShader pdata) wallPointsCol
-    (nShapeVs,nIndices,nSilIndices) <- pokeShape
-        (_vboPtr $ _vaoVBO $ _shadVAO $ _shapeShader pdata)
-        (_eboPtr $ _shapeEBO pdata)
-        (_eboPtr $ _silhouetteEBO pdata)
-        $ worldShape w
+    -- attempt to do this poking in parallel
+    (nWalls,(nShapeVs,nIndices,nSilIndices)) <- MP.bindM3 (\ _ a b -> return (a,b))
+        -- pictures poking
+        ( pokeBindFoldableLayer shadV layerCounts $ worldPictures w )
+        -- poke wall points and colors
+        ( poke224s (shadVBOptr $ _wallTextureShader pdata) wallPointsCol )
+        ( pokeShape 
+            (_vboPtr $ _vaoVBO $ _shadVAO $ _shapeShader pdata)
+            (_eboPtr $ _shapeEBO pdata)
+            (_eboPtr $ _silhouetteEBO pdata)
+            $ worldShape w
+        )
     -- bind wall points, silhouette data, surface geometry
     uncurry bindShaderBuffers $ unzip
         [ ( _wallTextureShader pdata, nWalls)

src/Shader/Poke.hs

@@ -17,11 +17,16 @@ import Geometry.Data
 
 import Graphics.Rendering.OpenGL hiding (color,scale,translate,rotate)
 import Foreign
+import qualified Data.Vector as V
+import qualified Data.Vector.Unboxed as UV
 import qualified Data.Vector.Unboxed.Mutable as UMV
 import qualified Data.Vector.Mutable as MV
 import qualified Data.Vector.Fusion.Stream.Monadic as VS
 import Control.Monad.Primitive
-import Control.Monad
+--import Control.Parallel.Strategies
+--import System.Environment
+import Control.Monad.Parallel as MP
+--import Control.Monad
 --import qualified Data.DList as DL
 
 pokeVerxs 
@@ -63,30 +68,38 @@ pokeShapeObj ptr iptr ieptr counts (ShapeObj shType shVerts) = case shType of
 
 pokeTopPrism :: Int -> Ptr Float -> Ptr GLushort 
     -> Ptr GLushort -> (Int,Int,Int) -> [ShapeV] -> IO (Int,Int,Int)
-pokeTopPrism size ptr iptr ieptr count svs = do
-    count' <- pokeTopPrismIndices size iptr count >>= pokeTopPrismEdgeIndices size ieptr
-    VS.foldlM' (pokeJustV ptr) count' (VS.fromList svs)
-
-pokeTopPrismIndices :: Int -> Ptr GLushort -> (Int,Int,Int) -> IO (Int,Int,Int)
-pokeTopPrismIndices size iptr (nv,ni,nei) = do
-    ni' <- foldM (pokeTopPrismIndex nv iptr) ni (topPrismIndices size)
-    return (nv,ni',nei)
-
-pokeTopPrismEdgeIndices :: Int -> Ptr GLushort -> (Int,Int,Int) -> IO (Int,Int,Int)
-pokeTopPrismEdgeIndices size ieptr (nv,ni,nei) = do
-    nei' <- foldM (pokeTopPrismEdgeIndex nv ieptr) nei (topPrismEdgeIndices size)
-    return (nv,ni,nei')
+pokeTopPrism size ptr iptr ieptr (nv,ni,nei) svs = do
+    MP.bindM3 (\a b c -> return (a,b,c))
+        (VS.foldlM' (pokeJustV ptr) nv (VS.fromList svs) )
+        (UV.foldM (pokeTopPrismIndex nv iptr)      ni  (memoTopPrismIndices     V.! (size - 2)) )
+        (UV.foldM (pokeTopPrismEdgeIndex nv ieptr) nei (memoTopPrismEdgeIndices V.! (size - 2)) )
+--    ni'  <- UV.foldM (pokeTopPrismIndex nv iptr)      ni  (memoTopPrismIndices     V.! (size - 2))
+--    nei' <- UV.foldM (pokeTopPrismEdgeIndex nv ieptr) nei (memoTopPrismEdgeIndices V.! (size - 2))
+--    nv'  <- VS.foldlM' (pokeJustV ptr) nv (VS.fromList svs)
+--    return (nv',ni',nei')
 
 pokeTopPrismEdgeIndex :: Int -> Ptr GLushort -> Int -> Int -> IO Int
+{-# INLINE pokeTopPrismEdgeIndex #-}
 pokeTopPrismEdgeIndex nv iptr ni ioff = do
     pokeElemOff iptr ni (fromIntegral $ nv + ioff)
     return (ni + 1)
 
 pokeTopPrismIndex :: Int -> Ptr GLushort -> Int -> Int -> IO Int
+{-# INLINE pokeTopPrismIndex #-}
 pokeTopPrismIndex nv iptr ni ioff = do
     pokeElemOff iptr ni (fromIntegral $ nv + ioff)
     return (ni + 1)
 
+memoTopPrismEdgeIndices :: V.Vector (UV.Vector Int)
+memoTopPrismEdgeIndices = V.generate 6 f
+  where
+    f n = UV.fromList $ topPrismEdgeIndices (n + 2)
+
+memoTopPrismIndices :: V.Vector (UV.Vector Int)
+memoTopPrismIndices = V.generate 6 f
+  where
+    f n = UV.fromList $ topPrismIndices (n + 2)
+
 topPrismEdgeIndices :: Int -> [Int]
 topPrismEdgeIndices n = concatMap f [0..n-1]
   where
@@ -108,8 +121,8 @@ topPrismIndices n = concatMap f [1..n-2]    -- triangles on top face
     g x = [2*x,2*x+1,2*x+3
             ,2*x,2*x+3,2*x+2]
 
-pokeJustV :: Ptr Float -> (Int,Int,Int) -> ShapeV -> IO (Int,Int,Int)
-pokeJustV ptr (nv,ni,nei) sh = do
+pokeJustV :: Ptr Float -> Int -> ShapeV -> IO Int
+pokeJustV ptr nv sh = do
     pokeElemOff ptr (off 0) a
     pokeElemOff ptr (off 1) b
     pokeElemOff ptr (off 2) c
@@ -117,7 +130,7 @@ pokeJustV ptr (nv,ni,nei) sh = do
     pokeElemOff ptr (off 4) e
     pokeElemOff ptr (off 5) f
     pokeElemOff ptr (off 6) g
-    return (nv+1,ni,nei)
+    return (nv+1)
   where
     off i = nv*7 + i
     V3 a b c    = _svPos sh