Commit before attempting to remove ptDraw field

src/Dodge/Data.hs

@@ -636,6 +636,15 @@ data Particle
         { _ptDraw   :: Particle -> Picture
         , _ptUpdate :: World -> Particle -> (World, Maybe Particle)
         }
+    | BlipParticle
+        { _ptDraw   :: Particle -> Picture
+        , _ptColor  :: Color
+        , _ptTimer  :: Int
+        , _ptMaxTime :: Int
+        , _ptUpdate :: World -> Particle -> (World, Maybe Particle)
+        , _ptRad    :: Float
+        , _ptPos    :: Point2
+        }
     | RadarCircleParticle
         { _ptDraw   :: Particle -> Picture
         , _ptUpdate :: World -> Particle -> (World, Maybe Particle)

src/Dodge/Item/Weapon/UseEffect.hs

@@ -52,10 +52,27 @@ drawPulse col pt = setLayer DebugLayer $ pictures sweepPics
     x = _ptTimer pt
 {- | Radar blip at a point.  -}
 blipAt :: Float -> Point2 -> Color -> Int -> Particle
-blipAt r p col i = Particle
+blipAt r p col i = BlipParticle
-    {_ptDraw = const blank
+    {_ptDraw = drawBlip
-    ,_ptUpdate = mvBlip r p col i i
+    ,_ptUpdate = \w pt -> if _ptTimer pt <= 0 then (w,Nothing) else (w,Just $ pt & ptTimer -~ 1)
+    ,_ptColor = col
+    ,_ptTimer = i
+    ,_ptMaxTime = i
+    ,_ptRad = r
+    ,_ptPos = p
     }
+drawBlip :: Particle -> Picture
+drawBlip pt = setDepth (-0.5)
+    . setLayer DebugLayer
+    . uncurryV translate p 
+    . color (withAlpha (fromIntegral t / fromIntegral maxt) col)
+    $ circleSolid r
+  where
+    p = _ptPos pt
+    t = _ptTimer pt
+    r = _ptRad pt
+    col = _ptColor pt
+    maxt = _ptMaxTime pt
 mvBlip :: Float
     -> Point2 -> Color 
     -> Int  -- ^ Max possible timer value

src/Dodge/Render.hs

@@ -27,7 +27,7 @@ import Graphics.Rendering.OpenGL hiding (color,scale,translate,rotate)
 import qualified SDL
 import qualified Data.Vector.Unboxed.Mutable as UMV
 import Graphics.GL.Core43
-import qualified Streaming.Prelude as S
+--import qualified Streaming.Prelude as S
 
 doDrawing :: RenderData -> Universe -> IO Word32
 doDrawing pdata u = do

src/Dodge/Render/ShapePicture.hs

@@ -39,24 +39,25 @@ import qualified Streaming.Prelude as S
 import qualified Data.Graph.Inductive as FGL
 import qualified Data.Set as Set
 import Padding
---import Data.Foldable
+import Data.Foldable
 
+singleSPic :: SPic -> SPic
 singleSPic = id
 
 worldSPic :: Configuration -> World -> SPic
 worldSPic cfig w 
     =  singleSPic (mempty, extraPics cfig w)
-    <> f (dbArg _prDraw) (filtOn' _prPos _props)                             
+    <> foldup (dbArg _prDraw) (filtOn' _prPos _props)                             
-    <> f (shiftDraw _blPos _blDir _blDraw) (filtOn' _blPos _blocks)           
+    <> foldup (shiftDraw _blPos _blDir _blDraw) (filtOn' _blPos _blocks)           
-    <> f (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn' _fsPos _shapes)   
+    <> foldup (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn' _fsPos _shapes)   
-    <> f (dbArg _cpPict) (filtOn' _cpPos _corpses)                            
+    <> foldup (dbArg _cpPict) (filtOn' _cpPos _corpses)                            
-    <> f (dbArg _crPict) (filtOn' _crPos _creatures)                          
+    <> foldup (dbArg _crPict) (filtOn' _crPos _creatures)                          
-    <> f floorItemSPic (filtOn' _flItPos _floorItems)                         
+    <> foldup floorItemSPic (filtOn' _flItPos _floorItems)                         
-    <> f btSPic (filtOn' _btPos _buttons)                                     
+    <> foldup btSPic (filtOn' _btPos _buttons)                                     
-    <> f mcSPic (filtOn' _mcPos _machines)                                    
+    <> foldup mcSPic (filtOn' _mcPos _machines)                                    
     <> singleSPic (anyTargeting cfig w)
   where
-    f = foldMap
+    foldup = foldMap'
     filtOn' f g = IM.filter (pointIsClose . f) (g w)
     --filtOn' f g = S.filter (pointIsClose . f) $ S.each (g w)
     pointIsClose = cullPoint cfig w

src/Geometry.hs

@@ -140,7 +140,8 @@ polyToTris'' _ = []
 polyToTris :: [s] -> [s]
 {-# INLINABLE polyToTris #-}
 --polyToTris (x:xs) = foldr (f x) [] $ foldPairs xs 
-polyToTris (x:xs) = foldr (f x) [] $ zip xs $ tail xs
+polyToTris (x:xs) = foldl' (flip $ f x) [] $ zip xs $ tail xs
+--polyToTris (x:xs) = foldr (f x) [] $ zip xs $ tail xs
   where
     f a (b,c) ls = a:b:c:ls
 polyToTris _ = []

src/Shader/Poke.hs

@@ -1,6 +1,6 @@
 module Shader.Poke
     ( pokeVerxs
-    , pokeSPics
+--    , pokeSPics
     , pokeLayVerxs
     , pokeArrayOff
 --    , pokePoint33s
@@ -13,7 +13,7 @@ import Shader.Parameters
 import Picture.Data
 import Shape.Data
 import Geometry.Data
-import ShapePicture
+--import ShapePicture
 
 import Graphics.Rendering.OpenGL hiding (color,scale,translate,rotate)
 import Foreign
@@ -83,15 +83,15 @@ pokeW ptr i' ((V2 a b,V2 c d),V4 e f g h) = do
     pokeElemOff ptr (i + 7) h
     return $ i' + 1
 
-pokeSPics
+--pokeSPics
-    :: MV.MVector (PrimState IO) FullShader 
+--    :: MV.MVector (PrimState IO) FullShader 
-    -> UMV.MVector (PrimState IO) Int
+--    -> UMV.MVector (PrimState IO) Int
-    -> Ptr Float -> Ptr GLushort -> Ptr GLushort 
+--    -> Ptr Float -> Ptr GLushort -> Ptr GLushort 
-    -> Stream (Of SPic) IO ()
+--    -> Stream (Of SPic) IO ()
-    -> IO (Int,Int,Int)
+--    -> IO (Int,Int,Int)
-pokeSPics vbos counts ptr iptr ieptr = 
+--pokeSPics vbos counts ptr iptr ieptr = 
-    S.foldM_ (\is (sh,pic) -> pokeLayVerxs vbos counts pic >> pokeShape' ptr iptr ieptr is sh)
+--    S.foldM_ (\is (sh,pic) -> pokeLayVerxs vbos counts pic >> pokeShape' ptr iptr ieptr is sh)
-    (return (0,0,0)) return
+--    (return (0,0,0)) return
     
 
 pokeShape :: Ptr Float -> Ptr GLushort -> Ptr GLushort 

src/Shape.hs

@@ -21,12 +21,14 @@ module Shape
 import Geometry
 import Shape.Data
 import Color
-import qualified Streaming.Prelude as S
+--import qualified Streaming.Prelude as S
 
 singleShape :: ShapeObj -> Shape
 {-# INLINE singleShape #-}
 singleShape = (:[])
 
+shMap :: (ShapeObj -> ShapeObj) -> Shape -> Shape
+{-# INLINE shMap #-}
 shMap = map
 
 emptySH :: Shape

src/ShapePicture.hs

@@ -19,10 +19,11 @@ import Geometry
 
 import Data.Bifunctor
 import Control.Lens
-import qualified Streaming.Prelude as S
+--import qualified Streaming.Prelude as S
 
 type SPic =  (Shape, Picture)
 
+shMap :: (ShapeObj -> ShapeObj) -> Shape -> Shape
 shMap = map
 
 -- should all this be inlined/inlinable?