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

Simplify block drawing further, store shape of block

Browse Source
This commit is contained in:
justin
2025-10-24 19:39:44 +01:00
parent ffea3a1694
commit 95b4105f52
9 changed files with 143 additions and 163 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Block/Draw.hs
+12 -11
View File
@@ -1,12 +1,13 @@
module Dodge.Block.Draw (drawBlock) where
--{-# LANGUAGE LambdaCase #-}
module Dodge.Block.Draw () where
--
--import Dodge.Data.Block
--import Shape
--import ShapePicture
import Dodge.Data.Block
import Shape
import ShapePicture
drawBlock :: BlockDraw -> Block -> SPic
drawBlock bd = case bd of
BlockDrawMempty -> const mempty
BlockDraws bds -> \bl -> foldMap (`drawBlock` bl) bds
BlockDrawColHeightPoss col h ps -> const $ noPic $ colorSH col (upperBox Medium Typical h ps)
BlockDrawBlSh x -> const $ noPic x
--drawBlock :: BlockDraw -> SPic
--drawBlock = \case
-- BlockDrawMempty -> mempty
---- BlockDraws bds -> foldMap drawBlock bds
---- BlockDrawColHeightPoss col h ps -> noPic $ colorSH col (upperBox Medium Typical h ps)
-- BlockDrawBlSh x -> noPic x
src/Dodge/Data/Block.hs
+15 -14
View File
@@ -7,7 +7,7 @@ module Dodge.Data.Block (
module Dodge.Data.PathGraph,
) where
import Color
--import Color
import Control.Lens
import Data.Aeson
import Data.Aeson.TH
@@ -26,22 +26,23 @@ data Block = Block
, _blPos :: Point2
, _blDir :: Float
, _blHeight :: Float
, _blDraw :: BlockDraw
-- , _blDraw :: BlockDraw
, _blDraw :: Shape
}
deriving (Eq, Ord, Show, Read) --Generic, Flat)
data BlockDraw
= BlockDrawMempty
| BlockDrawBlSh Shape
| BlockDraws [BlockDraw]
| BlockDrawColHeightPoss Color Float [Point2]
deriving (Eq, Ord, Show, Read) --Generic, Flat)
data BlSh
= BlShConst Shape
deriving (Eq, Ord, Show, Read) --Generic, Flat)
--data BlockDraw
-- = BlockDrawMempty
-- | BlockDrawBlSh Shape
---- | BlockDraws [BlockDraw]
---- | BlockDrawColHeightPoss Color Float [Point2]
-- deriving (Eq, Ord, Show, Read) --Generic, Flat)
--
--data BlSh
-- = BlShConst Shape
-- deriving (Eq, Ord, Show, Read) --Generic, Flat)
makeLenses ''Block
deriveJSON defaultOptions ''BlSh
deriveJSON defaultOptions ''BlockDraw
--deriveJSON defaultOptions ''BlSh
--deriveJSON defaultOptions ''BlockDraw
deriveJSON defaultOptions ''Block
src/Dodge/Default/Block.hs
+1 -1
View File
@@ -11,7 +11,7 @@ defaultBlock = Block
, _blFootprint = []
, _blPos = 0
, _blDir = 0
, _blDraw = BlockDrawMempty
, _blDraw = mempty
, _blHeight = 100
}
defaultDirtBlock :: Block
src/Dodge/Draw.hs
+2 -2
View File
@@ -3,7 +3,7 @@ Rexports all Dodge.x.Draw files.
-}
module Dodge.Draw (
module Dodge.Beam.Draw,
module Dodge.Block.Draw,
-- module Dodge.Block.Draw,
module Dodge.Item.Draw,
module Dodge.Button.Draw,
module Dodge.EnergyBall.Draw,
@@ -23,7 +23,7 @@ module Dodge.Draw (
import Dodge.Beam.Draw
import Dodge.Item.Draw
import Dodge.Block.Draw
--import Dodge.Block.Draw
import Dodge.Button.Draw
import Dodge.EnergyBall.Draw
import Dodge.Flame.Draw
src/Dodge/Placement/Instance/Block.hs
+3 -4
View File
@@ -1,6 +1,6 @@
module Dodge.Placement.Instance.Block where
import Shape.Data
import Shape
import Color
import Dodge.Data.GenWorld
import Dodge.Default.Block
@@ -13,12 +13,11 @@ decoratedBlock decf mat col h ps = PutBlock bl wl $ reverse ps
where
bl =
defaultBlock
& blDraw .~ BlockDraws [BlockDrawColHeightPoss col h ps, BlockDrawBlSh decf]
& blDraw .~ (decf <> colorSH col (upperBox Medium Typical h ps))
-- BlockDraws [BlockDrawColHeightPoss col h ps, BlockDrawBlSh decf]
& blHeight .~ h
wl =
defaultWall
-- & wlPathFlag . at WallNotDestrucable .~ Nothing
-- & wlPathFlag . at WallBlockVisibility .~ Nothing
& wlRotateTo .~ False
& wlOpacity .~ SeeAbove
& wlMaterial .~ mat
src/Dodge/Placement/PlaceSpot/Block.hs
+1 -1
View File
@@ -79,7 +79,7 @@ plLineBlock basePane blwidth a b gw =
, _blFootprint = cornersAt p -- TODO check winding (clockwise, anticlockwise)
, _blHeight = 100
, _blPos = p
, _blDraw = BlockDrawMempty
, _blDraw = mempty
}
)
insertBlocks = flip (foldr insertBlock) $ zip is blockCenPs
src/Dodge/Render/ShapePicture.hs
+3 -1
View File
@@ -26,7 +26,9 @@ worldSPic cfig u =
<> foldMap' debrisSPic (filtOn' (xyV3 . _dbPos) _debris)
<> foldup drawProjectile (filtOn (^. pjPos . _xy) _projectiles)
<> foldup drawPulseBall (filtOn _pbPos _pulseBalls)
<> foldup (shiftDraw _blPos _blDir (drawBlock . _blDraw)) (filtOn _blPos _blocks)
-- <> foldup (shiftDraw _blPos _blDir (const $ drawBlock . _blDraw))
<> foldup (shiftDraw _blPos _blDir (const $ noPic . _blDraw))
(filtOn _blPos _blocks)
<> foldup (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _foreShapes)
<> foldup (drawCreature (lw ^. items)) (filtOn (^. crPos . _xy) _creatures)
<> foldup
src/Dodge/Room/Tanks.hs
+4 -25
View File
@@ -1,5 +1,7 @@
module Dodge.Room.Tanks where
import Color
import Control.Monad
import Dodge.Base.CardinalPoint
import Dodge.Data.GenWorld
import Dodge.LevelGen.PlacementHelper
@@ -14,7 +16,6 @@ import Geometry
import LensHelp
import RandomHelp
import Shape
import Control.Monad
randomTank :: RandomGen g => State g Placement
randomTank =
@@ -37,18 +38,7 @@ randEdgeTank = do
return $
basetank
& plType . putBlock . blDraw
%~ ( \bd ->
BlockDraws
[ bd
, BlockDrawBlSh
( colorSH
orange
( verticalPipe 80
<> horPipe 80 0 (70 *.* cardVec edge)
)
)
]
)
<>~ colorSH orange (verticalPipe 80 <> horPipe 80 0 (70 *.* cardVec edge))
-- %~ fmap (<> noPic ( colorSH orange (verticalPipe 80
-- <> horPipe 80 0 (70 *.* cardVec edge))))
-- 70 is a guess, the true value depends on the distance to the wall
@@ -67,18 +57,7 @@ randEdgeTanks i = do
replicate i $
basetank
& plType . putBlock . blDraw
%~ ( \bd ->
BlockDraws
[ bd
, BlockDrawBlSh
( colorSH
orange
( verticalPipe 80
<> horPipe 80 0 (70 *.* cardVec edge)
)
)
]
)
<>~ colorSH orange (verticalPipe 80 <> horPipe 80 0 (70 *.* cardVec edge))
-- 70 is a guess, the true value depends on the distance to the wall
& plSpot
.~ rprBool