diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 6c37f23ac..02642d44c 100644 --- a/src/Dodge/Data.hs +++ b/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) diff --git a/src/Dodge/Item/Weapon/UseEffect.hs b/src/Dodge/Item/Weapon/UseEffect.hs index 49878e7ee..ca93814ff 100644 --- a/src/Dodge/Item/Weapon/UseEffect.hs +++ b/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 - {_ptDraw = const blank - ,_ptUpdate = mvBlip r p col i i +blipAt r p col i = BlipParticle + {_ptDraw = drawBlip + ,_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 diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index 2a054d999..234f16c69 100644 --- a/src/Dodge/Render.hs +++ b/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 diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index d9f14fedf..982b1d35a 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/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) - <> f (shiftDraw _blPos _blDir _blDraw) (filtOn' _blPos _blocks) - <> f (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn' _fsPos _shapes) - <> f (dbArg _cpPict) (filtOn' _cpPos _corpses) - <> f (dbArg _crPict) (filtOn' _crPos _creatures) - <> f floorItemSPic (filtOn' _flItPos _floorItems) - <> f btSPic (filtOn' _btPos _buttons) - <> f mcSPic (filtOn' _mcPos _machines) + <> foldup (dbArg _prDraw) (filtOn' _prPos _props) + <> foldup (shiftDraw _blPos _blDir _blDraw) (filtOn' _blPos _blocks) + <> foldup (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn' _fsPos _shapes) + <> foldup (dbArg _cpPict) (filtOn' _cpPos _corpses) + <> foldup (dbArg _crPict) (filtOn' _crPos _creatures) + <> foldup floorItemSPic (filtOn' _flItPos _floorItems) + <> foldup btSPic (filtOn' _btPos _buttons) + <> 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 diff --git a/src/Geometry.hs b/src/Geometry.hs index f84a44088..ea8eb21ee 100644 --- a/src/Geometry.hs +++ b/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 _ = [] diff --git a/src/Shader/Poke.hs b/src/Shader/Poke.hs index 534a2aaf3..b95899a5b 100644 --- a/src/Shader/Poke.hs +++ b/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 - :: MV.MVector (PrimState IO) FullShader - -> UMV.MVector (PrimState IO) Int - -> Ptr Float -> Ptr GLushort -> Ptr GLushort - -> Stream (Of SPic) IO () - -> IO (Int,Int,Int) -pokeSPics vbos counts ptr iptr ieptr = - S.foldM_ (\is (sh,pic) -> pokeLayVerxs vbos counts pic >> pokeShape' ptr iptr ieptr is sh) - (return (0,0,0)) return +--pokeSPics +-- :: MV.MVector (PrimState IO) FullShader +-- -> UMV.MVector (PrimState IO) Int +-- -> Ptr Float -> Ptr GLushort -> Ptr GLushort +-- -> Stream (Of SPic) IO () +-- -> IO (Int,Int,Int) +--pokeSPics vbos counts ptr iptr ieptr = +-- S.foldM_ (\is (sh,pic) -> pokeLayVerxs vbos counts pic >> pokeShape' ptr iptr ieptr is sh) +-- (return (0,0,0)) return pokeShape :: Ptr Float -> Ptr GLushort -> Ptr GLushort diff --git a/src/Shape.hs b/src/Shape.hs index 74dd24fba..1bc0619cb 100644 --- a/src/Shape.hs +++ b/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 diff --git a/src/ShapePicture.hs b/src/ShapePicture.hs index 30b04b176..418b8517a 100644 --- a/src/ShapePicture.hs +++ b/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?