justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Commit before attempting to remove ptDraw field

Browse Source
This commit is contained in:
justin
2022-07-10 10:49:49 +01:00
parent 2a70dcc9a6
commit 8202d12b6a
8 changed files with 59 additions and 28 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data.hs
+9
View File
@@ -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
+20 -3
View File
@@ -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
src/Dodge/Render.hs
+1 -1
View File
@@ -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
+11 -10
View File
@@ -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
src/Geometry.hs
+2 -1
View File
@@ -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
+11 -11
View File
@@ -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
src/Shape.hs
+3 -1
View File
@@ -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
+2 -1
View File
@@ -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?