From ffea3a16948d9d5e9d7179b16d0157f6dbcbff6d Mon Sep 17 00:00:00 2001 From: justin Date: Fri, 24 Oct 2025 19:09:23 +0100 Subject: [PATCH] Simplify block drawing --- src/Dodge/Block/Draw.hs | 7 +------ src/Dodge/Data/Block.hs | 5 ++--- src/Dodge/Placement/Instance/Block.hs | 5 +++-- src/Dodge/Placement/Instance/Tank.hs | 2 +- src/Dodge/Placement/PlaceSpot/Block.hs | 19 +++++-------------- src/Dodge/Room/Tanks.hs | 6 ++---- src/Dodge/Room/Tutorial.hs | 2 ++ 7 files changed, 16 insertions(+), 30 deletions(-) diff --git a/src/Dodge/Block/Draw.hs b/src/Dodge/Block/Draw.hs index 55d488e71..39fd4e7e3 100644 --- a/src/Dodge/Block/Draw.hs +++ b/src/Dodge/Block/Draw.hs @@ -9,9 +9,4 @@ 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 -> noPic . doBlSh x - -doBlSh :: BlSh -> Block -> Shape -doBlSh bs = case bs of - BlShMempty -> const mempty - BlShConst sh -> const sh + BlockDrawBlSh x -> const $ noPic x diff --git a/src/Dodge/Data/Block.hs b/src/Dodge/Data/Block.hs index 202e09f8e..dab8894ba 100644 --- a/src/Dodge/Data/Block.hs +++ b/src/Dodge/Data/Block.hs @@ -32,14 +32,13 @@ data Block = Block data BlockDraw = BlockDrawMempty - | BlockDrawBlSh BlSh + | BlockDrawBlSh Shape | BlockDraws [BlockDraw] | BlockDrawColHeightPoss Color Float [Point2] deriving (Eq, Ord, Show, Read) --Generic, Flat) data BlSh - = BlShMempty - | BlShConst Shape + = BlShConst Shape deriving (Eq, Ord, Show, Read) --Generic, Flat) makeLenses ''Block diff --git a/src/Dodge/Placement/Instance/Block.hs b/src/Dodge/Placement/Instance/Block.hs index d0447513e..3b72964b9 100644 --- a/src/Dodge/Placement/Instance/Block.hs +++ b/src/Dodge/Placement/Instance/Block.hs @@ -1,5 +1,6 @@ module Dodge.Placement.Instance.Block where +import Shape.Data import Color import Dodge.Data.GenWorld import Dodge.Default.Block @@ -7,7 +8,7 @@ import Dodge.Default.Wall import Geometry import LensHelp -decoratedBlock :: BlSh -> Material -> Color -> Float -> [Point2] -> PSType +decoratedBlock :: Shape -> Material -> Color -> Float -> [Point2] -> PSType decoratedBlock decf mat col h ps = PutBlock bl wl $ reverse ps where bl = @@ -24,4 +25,4 @@ decoratedBlock decf mat col h ps = PutBlock bl wl $ reverse ps & wlHeight .~ h lowBlock :: Material -> Color -> Float -> [Point2] -> PSType -lowBlock = decoratedBlock BlShMempty +lowBlock = decoratedBlock mempty diff --git a/src/Dodge/Placement/Instance/Tank.hs b/src/Dodge/Placement/Instance/Tank.hs index 13f128207..830276da4 100644 --- a/src/Dodge/Placement/Instance/Tank.hs +++ b/src/Dodge/Placement/Instance/Tank.hs @@ -20,7 +20,7 @@ tankSquareDec :: tankSquareDec dec = tankShape (reverse . orderPolygon $ square 20) (dec 20 20 31) tankShape :: [Point2] -> (Color -> Color -> Shape) -> Color -> Color -> Placement -tankShape baseshape facade col col' = sps0 $ decoratedBlock (BlShConst $ facade col col') Metal col 31 baseshape +tankShape baseshape facade col col' = sps0 $ decoratedBlock (facade col col') Metal col 31 baseshape roundTank :: Color -> Color -> Placement roundTank = tankShape (polyCirc 4 20) $ diff --git a/src/Dodge/Placement/PlaceSpot/Block.hs b/src/Dodge/Placement/PlaceSpot/Block.hs index 5f80bfe8e..5c44848da 100644 --- a/src/Dodge/Placement/PlaceSpot/Block.hs +++ b/src/Dodge/Placement/PlaceSpot/Block.hs @@ -15,16 +15,8 @@ import Dodge.Path import Geometry import qualified IntMapHelp as IM -plBlock :: - -- | Block polygon - [Point2] -> - Block -> - -- | Base Pane - Wall -> - GenWorld -> - (Int, GenWorld) -plBlock [] _ _ _ = error "Trying to add a block with incomplete polygon" -plBlock (p : ps) bl wl w = +plBlock :: [Point2] -> Block -> Wall -> GenWorld -> (Int, GenWorld) +plBlock ps bl wl w = (,) blid $ w & gwWorld . cWorld . lWorld . blocks . at blid @@ -32,19 +24,18 @@ plBlock (p : ps) bl wl w = { _blID = blid , _blWallIDs = IS.fromList is , _blShadows = [] - , _blFootprint = p : ps + , _blFootprint = ps } & gwWorld %~ insertWalls wls where blid = IM.newKey $ w ^. gwWorld . cWorld . lWorld . blocks - lns = zip (p : ps) (ps ++ [p]) i = IM.newKey $ w ^. gwWorld . cWorld . lWorld . walls - is = [i .. i + length lns -1] + is = take (length ps) [i .. ] wls = zipWith (\j ln -> wl & wlLine .~ ln & wlID .~ j & wlStructure .~ BlockPart blid) is - lns + (loopPairs ps) -- | Splits a line into many four cornered blocks. plLineBlock :: diff --git a/src/Dodge/Room/Tanks.hs b/src/Dodge/Room/Tanks.hs index 3412e4de8..84af0a9fa 100644 --- a/src/Dodge/Room/Tanks.hs +++ b/src/Dodge/Room/Tanks.hs @@ -41,8 +41,7 @@ randEdgeTank = do BlockDraws [ bd , BlockDrawBlSh - ( BlShConst $ - colorSH + ( colorSH orange ( verticalPipe 80 <> horPipe 80 0 (70 *.* cardVec edge) @@ -72,8 +71,7 @@ randEdgeTanks i = do BlockDraws [ bd , BlockDrawBlSh - ( BlShConst $ - colorSH + ( colorSH orange ( verticalPipe 80 <> horPipe 80 0 (70 *.* cardVec edge) diff --git a/src/Dodge/Room/Tutorial.hs b/src/Dodge/Room/Tutorial.hs index 575f88240..87f720f71 100644 --- a/src/Dodge/Room/Tutorial.hs +++ b/src/Dodge/Room/Tutorial.hs @@ -1,5 +1,6 @@ module Dodge.Room.Tutorial where +import Dodge.Room.Tanks import Dodge.Room.LongDoor import Dodge.Layout import Dodge.Item.Held.Utility @@ -43,6 +44,7 @@ tutAnoTree = do foldMTRS [ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox , corDoor + , tToBTree "lastun" . return . cleatOnward <$> tanksRoom [] [] -- , return $ tToBTree "cor" $ return $ cleatOnward corridor -- , return $ tToBTree "cor" $ return $ cleatOnward corridor -- , tToBTree "lastun" . return . cleatOnward <$> cenLasTur