Put config/targeting pictures in sensible places, tweak main loop

appDodge/Main.hs

@@ -24,6 +24,8 @@ import Data.Preload.Render
 
 import Control.Lens
 import Control.Monad
+--import Control.Monad.Parallel
+import qualified Data.Text as T
 import qualified Data.IntMap               as IM
 import Graphics.Rendering.OpenGL hiding (color, rotate, scale, translate)
 import qualified SDL
@@ -41,13 +43,29 @@ main = do
         posy = _windowPosY con
     setupLoop
         20
-        (sizex,sizey)
+        (T.pack "Simple Game Loop")
-        (Just (posx,posy))
+        (winConfig sizex sizey (Just (posx,posy)))
         theCleanup
         (firstWorldLoad con)
         theUpdateStep
         (flip handleEvent)
 
+-- | Create an OpenGL SDL window configuration with a given x and y size.
+winConfig :: Int -> Int -> Maybe (Int, Int) -> SDL.WindowConfig
+winConfig x y winpos = SDL.defaultWindow 
+    { SDL.windowGraphicsContext = SDL.OpenGLContext $ SDL.defaultOpenGL 
+        { SDL.glProfile = SDL.Core SDL.Normal 4 3
+        , SDL.glColorPrecision = SDL.V4 8 8 8 8
+        } 
+    , SDL.windowPosition = theWinPos
+    , SDL.windowInitialSize = SDL.V2 (fromIntegral x) (fromIntegral y)
+    , SDL.windowResizable = True
+    }
+  where
+    theWinPos = case winpos of
+        Just (px,py) -> SDL.Absolute (SDL.P (SDL.V2 (fromIntegral px) (fromIntegral py)))
+        Nothing      -> SDL.Wherever
+
 theCleanup :: Universe -> IO ()
 theCleanup uv = SDL.cursorVisible $= True >> cleanUpPreload (_preloadData uv)
 
@@ -56,7 +74,6 @@ firstWorldLoad theConfig = do
     SDL.cursorVisible $= False
     theKeyConfig <- loadKeyConfig
     pdata <- doPreload >>= applyWorldConfig theConfig
---    w <- generateWorldFromSeed 0
     return $ startNewGame $ Universe 
         {_uvWorld = initialWorld
         ,_config    = theConfig
@@ -73,7 +90,7 @@ updateRenderSplit :: Universe -> IO Universe
 updateRenderSplit u = do
     let preData = _preloadData u
     updateUniverse u `par` void (doDrawing (_renderData preData) u)
-    return $ updateUniverse u
+    return (updateUniverse u)
 
 playSoundUnlessRewinding :: Universe -> IO (M.Map SoundOrigin Sound)
 playSoundUnlessRewinding u

package.yaml

@@ -29,13 +29,13 @@ dependencies:
 - OpenGL
 - OpenGLRaw
 - text
-- raw-strings-qq
+  #- raw-strings-qq
 - bytestring
 - lens
 - mtl
 - fgl
 - random
-- bmp
+  #- bmp
   #- monad-loops
 - JuicyPixels
 - vector
@@ -83,7 +83,7 @@ executables:
     - -fno-liberate-case 
     - -fno-state-hack
     - -funfolding-use-threshold1000 
-    - -funfolding-keeness-factor1000 
+      #- -funfolding-keeness-factor1000 
     - -fllvm 
     - -optlo-O3
     - -Wall

src/Dodge/Creature/Picture.hs

@@ -12,49 +12,25 @@ module Dodge.Creature.Picture
     , basicCrCorpse
     ) where
 import Dodge.Data
---import Dodge.Base
---import Dodge.Render.InfoBox
---import Dodge.Render.List
---import Dodge.Creature.AlertLevel.Data
---import Dodge.Picture.Layer
-import Dodge.Clock
 import Dodge.Creature.HandPos (translateToRightHand,translateToLeftHand)
 import Dodge.Creature.Test
 import Dodge.Damage
---import Dodge.Debug.Picture
 import Picture
 import Geometry
 import Shape
 import ShapePicture
 import qualified Quaternion as Q
---import Geometry.Vector3D
 
 import Control.Lens
-import qualified Data.IntMap.Strict as IM
+
-import qualified Data.Vector as V
+basicCrPict :: Creature -> SPic
-basicCrPict :: Creature 
+basicCrPict cr = drawCrEquipment cr <> (basicCrShape cr , mempty)
-    -> Configuration
-    -> World
-    -> SPic
-basicCrPict cr cfig w = 
-    drawCrEquipment cr
-    <>
-    (basicCrShape cr
-    , pictures $
-        targetingPic ++
-        [ creatureDisplayText cfig w cr
-        --, tr . rotdir $ _spPicture $ drawEquipment cr
-        ]
-    )
-  where 
-    targetingPic = IM.elems $ IM.mapMaybe f $ _crInv cr
-    f it = fmap (\g -> g it cr cfig w) (it ^? itTargeting . tgDraw)
 
 drawCrEquipment :: Creature -> SPic
 drawCrEquipment cr = uncurryV translateSPf (_crPos cr) (rotateSP (_crDir cr) $ drawEquipment cr)
 
-shapeAtCrPos :: Shape -> Creature -> Configuration -> World -> SPic
+shapeAtCrPos :: Shape -> Creature -> SPic
-shapeAtCrPos sh cr _ _ = 
+shapeAtCrPos sh cr = 
     ( uncurryV translateSHf (_crPos cr) $ rotateSH (_crDir cr) sh
     , mempty
     )
@@ -77,47 +53,6 @@ basicCrShape cr
     rotdir = rotateSH (_crDir cr)
     rotmdir = rotateSH (_crMvDir cr)
 
-creatureDisplayText :: Configuration -> World -> Creature -> Picture
-creatureDisplayText cfig w cr 
-  | not (debugOn Cr_awareness cfig) = []
-  | otherwise
-    = setLayer DebugLayer 
-    . setDepth 20 
-    . translate x y 
-    . color white 
-    . rotate (0.5 * pi)
---    . rotate (argV v - 0.5 * pi)
-    . scale theScale theScale 
-    . stackText 
-    $ clockCycle 25 (V.fromList 
-        [ \cr' -> [crDisplayVigilance cr']
-        , \cr' -> [crDisplayAwareness cr']
-        ]
-        ) w cr
-  where
-    campos = _cameraViewFrom w
-    theScale = 0.15 / _cameraZoom w
-    cpos = _crPos cr
-    v = cpos -.- campos
-    (V2 x y) = campos +.+ v +.+ _crRad cr *.* normalizeV v
-
-crDisplayAwareness :: Creature -> String
-crDisplayAwareness cr
-    | isSuspicious = "?"
-    | isCognizant  = "!"
-    | otherwise    = "."
-  where
-    imAwarenesses = _cpAwareness (_crPerception cr)
-    isSuspicious = any f imAwarenesses && not (null imAwarenesses)
-    isCognizant  = any g imAwarenesses && not (null imAwarenesses)
-    f (Suspicious _) = True
-    f _ = False
-    g (Cognizant _) = True
-    g _ = False
-
-crDisplayVigilance :: Creature -> String
-crDisplayVigilance = show . _cpVigilance . _crPerception
-
 --damageMod :: Creature -> Picture -> Picture
 --damageMod cr pic = piercingMod $ bluntScale pic
 --  where
@@ -285,13 +220,13 @@ drawEquipment cr = foldMap f (_crInv cr)
 circLine :: Float -> Picture
 circLine x = line [V2 0 0,V2 x 0]
 
-picAtCrPos :: Picture -> Creature -> Configuration -> World -> SPic
+picAtCrPos :: Picture -> Creature -> SPic
 --{-# INLINE picAtCrPos #-}
-picAtCrPos thePic cr _ _ = (,) emptySH $ tranRot (_crPos cr) (_crDir cr) thePic
+picAtCrPos thePic cr = (,) emptySH $ tranRot (_crPos cr) (_crDir cr) thePic
 
-picAtCrPosNoRot :: Picture -> Creature -> Configuration -> World -> SPic
+picAtCrPosNoRot :: Picture -> Creature -> SPic
 --{-# INLINE picAtCrPos #-}
-picAtCrPosNoRot thePic cr _ _ = (,) emptySH $ uncurryV translate (_crPos cr) thePic
+picAtCrPosNoRot thePic cr = (,) emptySH $ uncurryV translate (_crPos cr) thePic
 
 basicCrCorpse :: Creature -> Corpse -> SPic
 basicCrCorpse cr cp = noPic . tr . scaleSH (V3 crsize crsize crsize) $ mconcat

src/Dodge/Creature/Picture/Awareness.hs

@@ -0,0 +1,45 @@
+module Dodge.Creature.Picture.Awareness where
+import Dodge.Data
+import Dodge.Clock
+import Picture
+import Geometry
+
+import qualified Data.Vector as V
+
+creatureDisplayText :: World -> Creature -> Picture
+creatureDisplayText w cr = setLayer DebugLayer 
+    . setDepth 20 
+    . translate x y 
+    . color white 
+    . rotate (0.5 * pi)
+--    . rotate (argV v - 0.5 * pi)
+    . scale theScale theScale 
+    . stackText 
+    $ clockCycle 25 (V.fromList 
+        [ \cr' -> [crDisplayVigilance cr']
+        , \cr' -> [crDisplayAwareness cr']
+        ]
+        ) w cr
+  where
+    campos = _cameraViewFrom w
+    theScale = 0.15 / _cameraZoom w
+    cpos = _crPos cr
+    v = cpos -.- campos
+    (V2 x y) = campos +.+ v +.+ _crRad cr *.* normalizeV v
+
+crDisplayAwareness :: Creature -> String
+crDisplayAwareness cr
+    | isSuspicious = "?"
+    | isCognizant  = "!"
+    | otherwise    = "."
+  where
+    imAwarenesses = _cpAwareness (_crPerception cr)
+    isSuspicious = any f imAwarenesses && not (null imAwarenesses)
+    isCognizant  = any g imAwarenesses && not (null imAwarenesses)
+    f (Suspicious _) = True
+    f _ = False
+    g (Cognizant _) = True
+    g _ = False
+
+crDisplayVigilance :: Creature -> String
+crDisplayVigilance = show . _cpVigilance . _crPerception

src/Dodge/Data.hs

@@ -346,7 +346,8 @@ data Creature = Creature
     , _crMvDir          :: Float
     , _crTwist          :: Float
     , _crID             :: Int
-    , _crPict           :: Creature -> Configuration -> World -> SPic
+    --, _crPict           :: Creature -> Configuration -> World -> SPic
+    , _crPict           :: Creature -> SPic
     , _crSkin           :: CreatureSkin
     , _crUpdate         :: Creature -> World -> World
     , _crRad            :: Float

src/Dodge/Placement/Instance/Turret.hs

@@ -75,7 +75,7 @@ updateTurret rotSpeed mc w
                 & crOldPos .~ mcpos
                 & crRad    .~ 1
                 & crDir .~ mcdir
-                & crPict .~ (\cr _ _ -> drawCrEquipment cr)
+                & crPict .~ drawCrEquipment
                 & crUpdate .~ stateUpdate followThenClearImpulses
                 & crStance . posture .~ Aiming
                 & crApplyDamage .~ applyNoDamage

src/Dodge/Render.hs

@@ -47,17 +47,15 @@ doDrawing pdata u = do
     -- bind as much data into vbos as feasible at this point
     -- count mutable vectors setup
     layerCounts  <- UMV.replicate (numLayers*6) 0
---    shapeCounts  <- UMV.replicate 3 0
-    wlwiflCounts <- UMV.replicate 3 0
     -- attempt to poke in parallel
     let (ws,wp) = wallSPics <> worldSPic cfig w
-    (nShapeVs, nIndices, nSilIndices) <- MP.bindM3 (\ _ _ counts -> return counts)
+    ( (nWalls, nWins , nFls),(nShapeVs, nIndices, nSilIndices) )
+        <- MP.bindM3 (\ _ wlwifl counts -> return (wlwifl,counts))
         ( pokeBindFoldableLayer shadV layerCounts wp)
         ( pokeWallsWindowsFloor
             (shadVBOptr $ _wallTextureShader pdata) 
             (shadVBOptr $ _windowShader pdata) 
             (shadVBOptr $ _textureArrayShader pdata)
-            wlwiflCounts
             wallPointsCol
             windowPoints
             (_floorTiles w)
@@ -68,9 +66,6 @@ doDrawing pdata u = do
             (_eboPtr $ _silhouetteEBO pdata)
             ws
         )
-    nWalls <- UMV.read wlwiflCounts 0
-    nWins  <- UMV.read wlwiflCounts 1
-    nFls   <- UMV.read wlwiflCounts 2
     -- bind wall points, silhouette data, surface geometry
     uncurry bindShaderBuffers $ unzip
         [ ( _wallTextureShader pdata, nWalls)

src/Dodge/Render/ShapePicture.hs

@@ -1,6 +1,7 @@
 module Dodge.Render.ShapePicture
     ( worldSPic
     ) where
+import Dodge.Creature.Picture.Awareness
 import Dodge.ShortShow
 import Dodge.Config.Data
 import Dodge.Render.InfoBox
@@ -25,6 +26,7 @@ import Sound.Data
 import Geometry.ConvexPoly
 --import Dodge.Base.Collide
 
+--import Data.Foldable
 import qualified Data.IntMap.Strict as IM -- Lazy?
 import qualified Data.Map.Strict as M
 import Control.Lens
@@ -33,22 +35,26 @@ import qualified Streaming.Prelude as S
 
 -- TODO only filter out shapes outside the range of the furthest shown light source
 worldSPic :: Configuration -> World -> SPic
-worldSPic cfig w = 
+worldSPic cfig w = (mempty, extraPics cfig w)
-    (mempty, extraPics cfig w)
-    --(mempty, extraPics cfig w)
     <> foldMap (dbArg _prDraw) (filtOn _prPos _props)
     <> foldMap (shiftDraw _blPos _blDir _blDraw) (filtOn _blPos _blocks)
     <> foldMap (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _shapes)
---    <> foldMap (\fs -> uncurryV translateSPf (_fsPos fs) . rotateSP (_fsDir fs) $ _fsSPic fs) (_shapes w)
     <> foldMap (dbArg _cpPict) (filtOn _cpPos _corpses)
-    <> foldMap ((($ w) . ($ cfig)) . dbArg _crPict) (filtOn _crPos _creatures)
+    <> foldMap (dbArg _crPict) (filtOn _crPos _creatures)
     <> foldMap floorItemSPic (filtOn _flItPos _floorItems)
     <> foldMap btSPic (filtOn _btPos _buttons)
     <> foldMap mcSPic (filtOn _mcPos _machines)
+    <> anyTargeting cfig w
   where
     filtOn f g = IM.filter (pointIsClose . f) (g w)
     pointIsClose = cullPoint cfig w
 
+anyTargeting :: Configuration -> World -> SPic
+anyTargeting cfig w = (mempty,pictures $ IM.elems $ IM.mapMaybe f $ _crInv cr)
+  where
+    cr = you w
+    f it = fmap (\g -> g it cr cfig w) (it ^? itTargeting . tgDraw)
+
 shiftDraw :: (a -> Point2) -> (a -> Float) -> (a -> a -> SPic) -> a -> SPic
 shiftDraw fpos fdir fdraw x = uncurryV translateSPf (fpos x)
     . rotateSP (fdir x)
@@ -83,11 +89,15 @@ extraPics cfig w = pictures (_decorations w)
     <> cfigdraw Show_far_wall_detect    (const drawFarWallDetect)
     <> cfigdraw Show_select             (const drawWorldSelect)
     <> cfigdraw Inspect_wall            (const drawInspectWalls)
+    <> cfigdraw Cr_awareness            (const drawCreatureDisplayTexts)
   where
     cfigdraw boption draw
         | debugOn boption cfig = draw cfig w
         | otherwise = mempty
 
+drawCreatureDisplayTexts :: World -> Picture
+drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (_creatures w)
+
 drawInspectWalls :: World -> Picture
 drawInspectWalls w = foldMap (drawInspectWall w) 
     $ filter (isJust . uncurry (intersectSegSeg a b) . _wlLine)
@@ -113,9 +123,12 @@ drawWorldSelect w = setLayer DebugLayer . color cyan
     (a,b) = _wSelect w
 
 drawFarWallDetect :: World -> Picture
-drawFarWallDetect w = setLayer DebugLayer . color yellow 
+drawFarWallDetect w = setLayer DebugLayer 
-    . concatMap (\q -> line [p,q]) 
+    . color yellow 
-    . map (\q -> fst $ collidePoint p q $ S.filter wlIsOpaque $ wallsAlongLine p q w)
+    . concatMap (\q -> line 
+        [ p
+        , fst $ collidePoint p q $ S.filter wlIsOpaque $ wallsAlongLine p q w
+        ]   )
     $ runIdentity $ S.toList_ $ streamViewpoints p w
   where
     p = _cameraViewFrom w

src/Dodge/Room/Foreground.hs

@@ -5,7 +5,7 @@ import Picture
 import Geometry
 import Shape
 import Quaternion
-import Bound
+--import Bound
 
 --import Dodge.Data.ForegroundShape
 import Dodge.Default.Foreground
@@ -13,8 +13,8 @@ import Data.List
 import Data.Maybe
 import Control.Lens
 import ShapePicture
-import Streaming
+--import Streaming
-import qualified Streaming.Prelude as S
+--import qualified Streaming.Prelude as S
 
 highDiagonalMesh
     :: Point2 
@@ -123,7 +123,7 @@ putShape :: Shape -> PSType
 putShape sh = PutForeground $ defaultForeground
     & fsPos .~ m
     & fsRad .~ radBounds bnds
-    & fsSPic .~ noPic (uncurryV translateSHf (-m) $ sh)
+    & fsSPic .~ noPic (uncurryV translateSHf (-m) sh)
   where
     bnds = (0,0,0,0) -- shapeBounds sh
     m = midBounds bnds

src/Loop.hs

@@ -18,18 +18,20 @@ import qualified Graphics.Rendering.OpenGL as GL
 -- | Create a game loop with an SDL window.
 setupLoop
     :: Int                  -- ^ Target seconds per frame
-    -> (Int,Int)            -- ^ The window size.
+    -> T.Text               -- ^ Window title
-    -> Maybe (Int,Int)            -- ^ The window position.
+    -> WindowConfig
+--    -> (Int,Int)            -- ^ The window size.
+--    -> Maybe (Int,Int)            -- ^ The window position.
     -> (world -> IO ())    -- ^ Function for cleaning up parameters, applied when exiting loop.
     -> IO world             -- ^ Initial simulation state.
     -> (world -> IO world)   -- ^ update, called once per frame. Allows for side effects such as rendering.
     -> (world -> Event -> IO (Maybe world))
                             -- ^ SDL Event handling, once per frame. Evaluating 'Nothing' exits the loop.
     -> IO ()
-setupLoop spf (xSize,ySize) winpos paramCleanup ioStartWorld sideEffects eventFn = do 
+setupLoop spf title winconfig paramCleanup ioStartWorld sideEffects eventFn = do 
     initializeAll
     bracket 
-        (createWindow (T.pack "Simple Game Loop") (winConfig xSize ySize winpos)) 
+        (createWindow title winconfig) 
         destroyWindow 
         $ \window -> bracket 
             (glCreateContext window) 
@@ -68,6 +70,7 @@ doLoop
 
             doLoop spf window worldSideEffects eventFn updatedWorld
         Nothing -> return ()
+
 -- | Handle quit events in a manner to exit the loop. Other events handled as
 -- determined by the custom function, although resize events also change the viewport.
 applyEventIO :: (world -> Event -> IO (Maybe world)) -> Maybe world -> Event -> IO (Maybe world)
@@ -81,18 +84,3 @@ applyEventIO fn mw e = case eventPayload e of
     mupdate = case mw of
         Nothing -> return Nothing
         Just w  -> fn w e
--- | Create an OpenGL SDL window configuration with a given x and y size.
-winConfig :: Int -> Int -> Maybe (Int, Int) -> WindowConfig
-winConfig x y winpos = defaultWindow 
-    { windowGraphicsContext = OpenGLContext $ defaultOpenGL 
-        { glProfile = Core Normal 4 3
-        , glColorPrecision = V4 8 8 8 8
-        } 
-    , windowPosition = theWinPos
-    , windowInitialSize = V2 (fromIntegral x) (fromIntegral y)
-    , windowResizable =True
-    }
-  where
-    theWinPos = case winpos of
-        Just (px,py) -> Absolute (P (V2 (fromIntegral px) (fromIntegral py)))
-        Nothing      -> Wherever

src/Shader/Poke.hs

@@ -19,7 +19,7 @@ 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 Data.Vector.Fusion.Util
+--import Data.Vector.Fusion.Util
 import Control.Monad.Primitive
 --import qualified Control.Monad.Parallel as MP
 
@@ -45,19 +45,18 @@ pokeWallsWindowsFloor
     :: Ptr Float
     -> Ptr Float
     -> Ptr Float
-    -> UMV.MVector (PrimState IO) Int
     -> [ ( (Point2,Point2) , Point4 ) ]
     -> [ ( (Point2,Point2) , Point4 ) ]
     -> [ ( Point3          , Point3 ) ]
-    -> IO ()
+    -> IO (Int,Int,Int)
-pokeWallsWindowsFloor wlptr wiptr flptr counts wls wis fls = do
+pokeWallsWindowsFloor wlptr wiptr flptr wls wis fls = do
-    VS.mapM_ (pokeW wlptr counts 0) (VS.fromList wls)
+    wlcounts1 <- VS.foldM (pokeW wlptr) 0 (VS.fromList wls)
-    VS.mapM_ (pokeW wiptr counts 1) (VS.fromList wis)
+    wlcounts2 <- VS.foldM (pokeW wiptr) 0 (VS.fromList wis)
-    VS.mapM_ (pokeF flptr counts)   (VS.fromList fls)
+    flcounts  <- VS.foldM (pokeF flptr) 0 (VS.fromList fls)
+    return (wlcounts1,wlcounts2,flcounts)
 
-pokeF :: Ptr Float -> UMV.MVector (PrimState IO) Int -> (Point3,Point3) -> IO ()
+pokeF :: Ptr Float -> Int -> (Point3,Point3) -> IO Int
-pokeF ptr counts (V3 a b c,V3 d e f) = do
+pokeF ptr i' (V3 a b c,V3 d e f) = do
-    i' <- UMV.unsafeRead counts 2
     let i = i' * 6
     pokeElemOff ptr (i + 0) a
     pokeElemOff ptr (i + 1) b
@@ -65,11 +64,10 @@ pokeF ptr counts (V3 a b c,V3 d e f) = do
     pokeElemOff ptr (i + 3) d
     pokeElemOff ptr (i + 4) e
     pokeElemOff ptr (i + 5) f
-    UMV.unsafeModify counts (+1) 2
+    return $ i' + 1
 
-pokeW :: Ptr Float -> UMV.MVector (PrimState IO) Int -> Int -> ((Point2,Point2),Point4) -> IO ()
+pokeW :: Ptr Float -> Int -> ((Point2,Point2),Point4) -> IO Int
-pokeW ptr counts iv ((V2 a b,V2 c d),V4 e f g h) = do
+pokeW ptr i' ((V2 a b,V2 c d),V4 e f g h) = do
-    i' <- UMV.unsafeRead counts iv
     let i = i' * 8
     pokeElemOff ptr (i + 0) a
     pokeElemOff ptr (i + 1) b
@@ -79,12 +77,9 @@ pokeW ptr counts iv ((V2 a b,V2 c d),V4 e f g h) = do
     pokeElemOff ptr (i + 5) f
     pokeElemOff ptr (i + 6) g
     pokeElemOff ptr (i + 7) h
-    UMV.unsafeModify counts (+1) iv
+    return $ i' + 1
 
-pokeShape
+pokeShape :: Ptr Float -> Ptr GLushort -> Ptr GLushort 
-    :: Ptr Float 
-    -> Ptr GLushort 
-    -> Ptr GLushort 
     -> [ShapeObj] 
     -> IO (Int,Int,Int)
 pokeShape ptr iptr ieptr = VS.foldM (pokeShapeObj ptr iptr ieptr) (0,0,0) . VS.fromList
@@ -96,7 +91,7 @@ pokeShapeObj
     -> (Int,Int,Int)
     -> ShapeObj
     -> IO (Int,Int,Int)
-{-# INLINE pokeShapeObj #-}
+--{-# INLINE pokeShapeObj #-}
 pokeShapeObj ptr iptr ieptr counts (ShapeObj shType shVerts) = case shType of
     TopPrism size -> pokeTopPrism (size - 2) ptr iptr ieptr counts shVerts
 
@@ -105,7 +100,7 @@ pokeTopPrism :: Int -> Ptr Float -> Ptr GLushort
     -> (Int,Int,Int)
     -> VS.Stream IO ShapeV
     -> IO (Int,Int,Int)
-{-# INLINE pokeTopPrism #-}
+--{-# INLINE pokeTopPrism #-}
 pokeTopPrism size ptr iptr ieptr (nv,nshapeindices,nedgeindices) svs = do
     nv' <- VS.foldM (pokeJustV ptr) nv svs
     nshapeindices' <- UV.foldM (pokeTopPrismIndex nv iptr) nshapeindices 
@@ -118,7 +113,7 @@ pokeTopPrismEdgeIndex :: Int -> Ptr GLushort
     -> Int
     -> Int 
     -> IO Int
-{-# INLINE pokeTopPrismEdgeIndex #-}
+--{-# INLINE pokeTopPrismEdgeIndex #-}
 pokeTopPrismEdgeIndex nv eiptr nedgeindices ioff = do
     pokeElemOff eiptr nedgeindices (fromIntegral $ nv + ioff)
     return $ nedgeindices + 1
@@ -127,7 +122,7 @@ pokeTopPrismIndex :: Int -> Ptr GLushort
     -> Int
     -> Int 
     -> IO Int
-{-# INLINE pokeTopPrismIndex #-}
+--{-# INLINE pokeTopPrismIndex #-}
 pokeTopPrismIndex nv iptr nshapeindices ioff = do
     pokeElemOff iptr nshapeindices (fromIntegral $ nv + ioff)
     return $ nshapeindices + 1
@@ -168,9 +163,9 @@ pokeJustV :: Ptr Float
     -> Int
     -> ShapeV 
     -> IO Int
-{-# INLINE pokeJustV #-}
+--{-# INLINE pokeJustV #-}
 pokeJustV ptr nv sh = do
-    let off i = nv*7 + i
+--    pokeArray (advancePtr ptr (off 0)) [a,b,c,d,e,f,g]
     pokeElemOff ptr (off 0) a
     pokeElemOff ptr (off 1) b
     pokeElemOff ptr (off 2) c
@@ -180,6 +175,7 @@ pokeJustV ptr nv sh = do
     pokeElemOff ptr (off 6) g
     return (nv + 1)
   where
+    off i = nv*7 + i
     V3 a b c    = _svPos sh
     V4 d e f g  = _svCol sh
 

src/Shape/Data.hs

@@ -8,7 +8,7 @@ module Shape.Data
 import Geometry.Data
 
 import qualified Data.Vector.Fusion.Stream.Monadic as VS
-import Data.Vector.Fusion.Util
+--import Data.Vector.Fusion.Util
 import Control.Lens
 type Shape = [ShapeObj]
 

stack.yaml

@@ -18,7 +18,8 @@
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
 #resolver: lts-17.1
-resolver: lts-18.5
+resolver: lts-18.28
+#resolver: lts-19.3
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.
@@ -36,8 +37,11 @@ packages:
 # forks / in-progress versions pinned to a git hash. For example:
 #
 extra-deps:
-- SDL-0.6.7.0@sha256:9d6ba75c0cab575ec38468c8277803983e985f9622437aeca6a53e6a7337a7d5,2045
+    #- SDL-0.6.7.0@sha256:9d6ba75c0cab575ec38468c8277803983e985f9622437aeca6a53e6a7337a7d5,2045
-- repa-3.4.1.4@sha256:5a99bde69fe96a18d70aae23f47c8f719b1134558dca3ee5a7c15423b68a132e,3323
+- sdl2-mixer-1.2.0.0@sha256:6a6b5a46c035c9e77eaf9c244e45de9e4a9b9a110890cfeeb9fa72faa2419cef,4497   
+- repa-3.4.1.5@sha256:4d94845e66d668345130f75f5de8f7c69139b91495c8c4b5a825014e8985e2fd,3562
+   #- repa-3.4.1.4@sha256:5a99bde69fe96a18d70aae23f47c8f719b1134558dca3ee5a7c15423b68a132e,3323
+   #- sdl2-mixer-1.1.0@sha256:c809aecd91ebf9c759af66eebaa4f45f766f2603c13a73412abfd0bd1e02071a,3067
   #  # for threadscope
   #- cairo-0.13.8.1@sha256:1938aaeb5d3504678d995774dfe870f6b66cbd43d336b692fa8779b23b2b67a9,4075
   #- ghc-events-0.15.1@sha256:b4052e98694a6426f46fb6ebb250b06d6f68a14fa0b7ceb7c01282c6bb5fe47e,3757