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

Cleanup

Browse Source
This commit is contained in:
justin
2025-10-08 09:20:19 +01:00
parent 77fcf8353a
commit 4e651fcded
9 changed files with 57 additions and 75 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Render/ShapePicture.hs
+36 -23
View File
@@ -1,8 +1,5 @@
module Dodge.Render.ShapePicture (
worldSPic,
) where
module Dodge.Render.ShapePicture (worldSPic) where
import Dodge.Item.Draw.SPic
import Control.Lens
import Data.Foldable
import Data.Strict.Tuple
@@ -10,14 +7,15 @@ import Dodge.Creature.Picture
import Dodge.Data.Universe
import Dodge.Debug.Picture
import Dodge.Draw
import Dodge.Item.Draw.SPic
import Dodge.RadarBlip
import Dodge.Render.Picture
import Geometry
import qualified IntMapHelp as IM
import Linear.V3
import Picture
import Shape
import ShapePicture
import Linear.V3
worldSPic :: Config -> Universe -> SPic
worldSPic cfig u =
@@ -27,36 +25,44 @@ worldSPic cfig u =
<> foldup drawProjectile (filtOn (^. pjPos . _xy) _projectiles)
<> foldup drawPulseBall (filtOn _pbPos _pulseBalls)
<> foldup (shiftDraw _blPos _blDir (drawBlock . _blDraw)) (filtOn _blPos _blocks)
<> foldup (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _foregroundShapes)
<> foldup (drawCreature (u ^. uvWorld . cWorld . lWorld . items))
(filtOn _crPos _creatures)
<> foldup (Prelude.uncurry floorItemSPic) (IM.intersectionWith (,) (u^.uvWorld.cWorld.lWorld.items) (filtOn _flItPos _floorItems))
<> foldup (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _foreShapes)
<> foldup (drawCreature (lw ^. items)) (filtOn _crPos _creatures)
<> foldup
(Prelude.uncurry floorItemSPic)
( IM.intersectionWith
(,)
(lw ^. items)
(filtOn _flItPos _floorItems)
)
<> foldup btSPic (filtOn _btPos _buttons)
<> foldup (mcSPic (u ^. uvWorld . cWorld)) (filtOn _mcPos _machines)
<> foldMap' drawChasm (u ^. uvWorld . cWorld . chasms)
<> foldup (mcSPic (w ^. cWorld)) (filtOn _mcPos _machines)
<> foldMap' drawChasm (w ^. cWorld . chasms)
where
w = _uvWorld u
w = u ^. uvWorld
lw = w ^. cWorld . lWorld
foldup = foldMap'
filtOn f g = IM.filter (pointIsClose . f) (g (_lWorld (_cWorld w)))
filtOn' f g = filter (pointIsClose . f) (g (_lWorld (_cWorld w)))
filtOn f g = IM.filter (pointIsClose . f) (g lw)
filtOn' f g = filter (pointIsClose . f) (g lw)
pointIsClose = cullPoint cfig w
drawChasm :: [Point2] -> SPic
drawChasm = foldMap (Prelude.uncurry drawCliff) . loopPairs
drawCliff :: Point2 -> Point2 -> SPic
drawCliff x y = noPic
. translateSHz (-500.01)
. colorSH (dark orange)
$ upperPrismPoly Large Important 500 [x,0.5 *(x+y) + normalizeV (vNormal (y - x)),y]
drawCliff x y =
noPic
. translateSHz (-500.01)
. colorSH (dark orange)
$ upperPrismPoly Large Important 500
[x, 0.5 * (x + y) + normalizeV (vNormal (y - x)), y]
drawPulseBall :: PulseBall -> SPic
drawPulseBall pb =
translateSPz 20
. uncurryV translateSPxy (pb ^. pbPos)
. noShape
. setLayer BloomLayer
$ circleSolidCol green white 10
translateSPz 20
. uncurryV translateSPxy (pb ^. pbPos)
. noShape
. setLayer BloomLayer
$ circleSolidCol green white 10
drawCreature :: IM.IntMap Item -> Creature -> SPic
drawCreature m cr = translateSPz (_crZ cr) . uncurryV translateSPxy (_crPos cr) . rotateSP (_crDir cr) $
@@ -130,3 +136,10 @@ mcSPic :: CWorld -> Machine -> SPic
mcSPic cw mc =
uncurryV translateSPxy (_mcPos mc) $
rotateSP (_mcDir mc) (drawMachine cw mc)
drawBullet :: Bullet -> Picture
drawBullet pt =
setLayer BloomLayer
. setDepth 20
. color (V4 200 200 200 2)
$ thickLine 2 [_buOldPos pt, _buPos pt]