From 781e337cad9414075b3476841ccd41456d8ea410 Mon Sep 17 00:00:00 2001 From: justin Date: Sat, 18 Jun 2022 11:07:17 +0100 Subject: [PATCH] Commit mid block refactor --- src/Dodge/Base/Collide.hs | 6 ++-- src/Dodge/Block.hs | 23 +++++++++------ src/Dodge/Block/Debris.hs | 40 +++++++++++++++----------- src/Dodge/Data.hs | 13 ++++----- src/Dodge/Default/Wall.hs | 10 +++---- src/Dodge/Placement/Instance/Wall.hs | 14 +++++---- src/Dodge/Placement/PlaceSpot.hs | 6 ++-- src/Dodge/Placement/PlaceSpot/Block.hs | 22 +++++++------- src/Dodge/Room/Pillar.hs | 5 ++-- src/Dodge/Room/RoadBlock.hs | 3 +- 10 files changed, 78 insertions(+), 64 deletions(-) diff --git a/src/Dodge/Base/Collide.hs b/src/Dodge/Base/Collide.hs index a5390103d..90af10fcf 100644 --- a/src/Dodge/Base/Collide.hs +++ b/src/Dodge/Base/Collide.hs @@ -260,8 +260,10 @@ canSee i j w = hasLOS p1 p2 w -- jpos = _crPos (_creatures w IM.! j) canSeeIndirect :: Int -> Int -> World -> Bool -canSeeIndirect i j w = not $ any (isJust . uncurry (intersectSegSeg ipos jpos) . _wlLine) - $ IM.filter wlIsOpaque $ wallsAlongLine ipos jpos w +canSeeIndirect i j w = not + $ any (isJust . uncurry (intersectSegSeg ipos jpos) . _wlLine) + $ IM.filter wlIsOpaque + $ wallsAlongLine ipos jpos w where ipos = _crPos (_creatures w IM.! i) jpos = _crPos (_creatures w IM.! j) diff --git a/src/Dodge/Block.hs b/src/Dodge/Block.hs index f14257121..eb465443e 100644 --- a/src/Dodge/Block.hs +++ b/src/Dodge/Block.hs @@ -11,14 +11,19 @@ import Geometry --import Geometry.ConvexPoly import Data.Function +import Data.Maybe import qualified Data.IntSet as IS import qualified Data.IntMap.Strict as IM import Control.Lens splinterBlock :: Block -> World -> World splinterBlock bl w = foldr unshadowBlock w (_blShadows bl) -- foldr shiftTowardCen w (_blWallIDs bl) - & matSplintSound (_blMaterial bl) cen + & matSplintSound bm cen where + bm = fromMaybe Stone $ do + wlids <- w ^? blocks . ix (_blID bl) . blWallIDs + (wlid,_) <- IS.minView wlids + w ^? walls . ix wlid . wlMaterial cen = centroid $ fst . _wlLine <$> IM.restrictKeys (_walls w) (_blWallIDs bl) unshadowBlock :: Int -> World -> World @@ -30,21 +35,21 @@ unshadowBlock wlid w = case w ^? walls . ix wlid of (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl) Nothing -> w -matSplintSound :: BlockMaterial -> Point2 -> World -> World +matSplintSound :: Material -> Point2 -> World -> World matSplintSound mat = case mat of - GlassBlock -> mkSoundSplinterGlass - StoneBlock -> mkSoundSplinterBlock - CrystalBlock -> mkSoundSplinterBlock - DirtBlock -> originIDsAt (BlockDegradeSound 1) [impact1S,impact3S] - WoodBlock -> originIDsAt (BlockDegradeSound 1) [impact1S,impact2S,impact3S] - MetalBlock -> originIDsAt (BlockDegradeSound 1) [impact2S,impact3S] + Glass -> mkSoundSplinterGlass + Stone -> mkSoundSplinterBlock + Crystal -> mkSoundSplinterBlock + Dirt -> originIDsAt (BlockDegradeSound 1) [impact1S,impact3S] + Wood -> originIDsAt (BlockDegradeSound 1) [impact1S,impact2S,impact3S] + Metal -> originIDsAt (BlockDegradeSound 1) [impact2S,impact3S] destroyBlock :: Block -> World -> World destroyBlock bl w = w & flip (foldr unshadowBlock) (_blShadows bl) & deleteWallIDs wlids & blocks %~ IM.delete (_blID bl) - & matDesSound (_blMaterial bl) pos +-- & matDesSound (_blMaterial bl) pos & _blDeath bl bl & flip (foldr (wlDustAt awl)) (map (pos +.+) ps) where diff --git a/src/Dodge/Block/Debris.hs b/src/Dodge/Block/Debris.hs index 7e6de894e..5665025ee 100644 --- a/src/Dodge/Block/Debris.hs +++ b/src/Dodge/Block/Debris.hs @@ -13,27 +13,33 @@ import Color import LensHelp import RandomHelp import qualified Quaternion as Q ---import Data.List (zip4) +import qualified Data.IntSet as IS +import Data.Maybe makeBlockDebris :: Block -> World -> World -makeBlockDebris bl = makeDebris (_blMaterial bl) (_blPos bl) +makeBlockDebris bl w = w & makeDebris mt (_blPos bl) + where + mt = fromMaybe Stone $ do + wlids <- w ^? blocks . ix (_blID bl) . blWallIDs + (wlid,_) <- IS.minView wlids + w ^? walls . ix wlid . wlMaterial -makeDebris :: BlockMaterial -> Point2 -> World -> World +makeDebris :: Material -> Point2 -> World -> World makeDebris = makeDebrisDirected 1 2 (2*pi) 0 makeDebrisDirected :: Float -> Float - -> Float -> Float -> BlockMaterial -> Point2 -> World -> World + -> Float -> Float -> Material -> Point2 -> World -> World makeDebrisDirected mindist maxdist arcrad dir bm p w = w & flip (foldr (plNew props pjID)) thedebris & randGen .~ newg & matDesSound bm p where someDebris = case bm of - StoneBlock -> stoneDebris - GlassBlock -> glassDebris - CrystalBlock -> crystalDebris - DirtBlock -> dirtDebris - WoodBlock -> stoneDebris - MetalBlock -> stoneDebris + Stone -> stoneDebris + Glass -> glassDebris + Crystal -> crystalDebris + Dirt -> dirtDebris + Wood -> stoneDebris + Metal -> stoneDebris (thedebris,newg) = runState (mapM f [35,55..95]) $ _randGen w f h = do v <- rotateV (dir - arcrad/2) <$> randInArcStrip mindist maxdist arcrad @@ -89,11 +95,11 @@ crystalDebris = glassDebris debrisShape :: Float -> Prop -> Shape debrisShape size pr = colorSH (_pjColor pr) . translateSHz (-size) $ upperPrismPoly 8 $ square size -matDesSound :: BlockMaterial -> Point2 -> World -> World +matDesSound :: Material -> Point2 -> World -> World matDesSound mat = case mat of - GlassBlock -> mkSoundBreakGlass - CrystalBlock -> mkSoundBreakGlass -- this should be more crunchy - StoneBlock -> mkSoundSplinterBlock - DirtBlock -> originIDsAt (BlockDegradeSound 1) [impact1S,impact3S] - WoodBlock -> originIDsAt (BlockDegradeSound 1) [impact1S,impact2S,impact3S] - MetalBlock -> originIDsAt (BlockDegradeSound 1) [impact2S,impact3S] + Glass -> mkSoundBreakGlass + Crystal -> mkSoundBreakGlass -- this should be more crunchy + Stone -> mkSoundSplinterBlock + Dirt -> originIDsAt (BlockDegradeSound 1) [impact1S,impact3S] + Wood -> originIDsAt (BlockDegradeSound 1) [impact1S,impact2S,impact3S] + Metal -> originIDsAt (BlockDegradeSound 1) [impact2S,impact3S] diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 9d57f48a5..c863e0f9b 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -922,14 +922,13 @@ data Block = Block , _blWallIDs :: IS.IntSet , _blHP :: Int , _blShadows :: [Int] -- a list of blocks/walls? that are not shown when this block exists - , _blMaterial :: BlockMaterial , _blFootprint :: [Point2] , _blPos :: Point2 , _blDraw :: Block -> SPic , _blDeath :: Block -> World -> World } -data BlockMaterial = WoodBlock | DirtBlock | StoneBlock | GlassBlock | MetalBlock - | CrystalBlock +data Material = Wood | Dirt | Stone | Glass | Metal | Crystal + deriving (Eq,Ord,Show,Bounded,Enum) data TerminalStatus = TerminalOff | TerminalBusy | TerminalReady deriving (Eq,Ord,Show) data TerminalInput = TerminalInput @@ -1032,7 +1031,7 @@ data Wall = Wall , _wlStructure :: WallStructure , _wlHeight :: Float , _wlDamageEff :: Damage -> Wall -> World -> World - , _wlMaterial :: BlockMaterial + , _wlMaterial :: Material } data Opacity = SeeThrough @@ -1402,12 +1401,12 @@ data PSType = PutCrit {_unPutCrit :: Creature} | PutTerminal {_unputTerminal :: Terminal} | PutFlIt Item | PutPPlate PressPlate - | PutBlock BlockMaterial Int Wall [Point2] + | PutBlock Block Wall [Point2] | PutCoord Point2 | PutMod Modification | PutTrigger (World -> Bool) - | PutLineBlock {_putWall :: Wall, _putBlockMaterial :: BlockMaterial - , _putWidth :: Float, _putDepth :: Float, _putStartPoint :: Point2, _putEndPoint :: Point2} + | PutLineBlock {_putWall :: Wall , _putWidth :: Float + , _putDepth :: Float, _putStartPoint :: Point2, _putEndPoint :: Point2} | PutWall { _pwPoly :: [Point2] , _pwWall :: Wall } | PutSlideDr Bool Color (World -> Bool) Float Point2 Point2 Float | PutDoor Color (World -> Bool) [(Point2,Point2)] diff --git a/src/Dodge/Default/Wall.hs b/src/Dodge/Default/Wall.hs index 877f7efc9..9f833ccf3 100644 --- a/src/Dodge/Default/Wall.hs +++ b/src/Dodge/Default/Wall.hs @@ -23,14 +23,14 @@ defaultWall = Wall , _wlWalkable = False , _wlHeight = 100 , _wlDamageEff = defaultWallDamage - , _wlMaterial = StoneBlock + , _wlMaterial = Stone } {- Indestructible see-through wall. -} defaultCrystalWall :: Wall defaultCrystalWall = defaultWall { _wlColor = withAlpha 0.5 aquamarine , _wlOpacity = SeeThrough - , _wlMaterial = CrystalBlock + , _wlMaterial = Crystal } defaultMachineWall :: Wall defaultMachineWall = defaultWall @@ -38,7 +38,7 @@ defaultMachineWall = defaultWall , _wlDraw = False , _wlRotateTo = False , _wlStructure = MachinePart 0 - , _wlMaterial = MetalBlock + , _wlMaterial = Metal } defaultDirtWall :: Wall defaultDirtWall = defaultWall @@ -50,7 +50,7 @@ defaultDirtWall = defaultWall , _wlRotateTo = False , _wlDraw = True , _wlFireThrough = True - , _wlMaterial = DirtBlock + , _wlMaterial = Dirt } defaultWindow :: Wall defaultWindow = defaultWall @@ -62,5 +62,5 @@ defaultWindow = defaultWall , _wlOpacity = SeeThrough , _wlDraw = True , _wlFireThrough = True - , _wlMaterial = GlassBlock + , _wlMaterial = Glass } diff --git a/src/Dodge/Placement/Instance/Wall.hs b/src/Dodge/Placement/Instance/Wall.hs index 85c92dd48..45ce2d3d2 100644 --- a/src/Dodge/Placement/Instance/Wall.hs +++ b/src/Dodge/Placement/Instance/Wall.hs @@ -1,6 +1,8 @@ module Dodge.Placement.Instance.Wall where import Dodge.Data +import Dodge.Default.Block +import Dodge.Block.Debris import Dodge.LevelGen.Data import Dodge.Default.Wall --import Dodge.Wall.DamageEffect @@ -56,7 +58,7 @@ midWall ps = ps0j (PutShape . colorSH col $ upperPrismPoly 50 ps) singleBlock :: Point2 -> [Placement] singleBlock a = [sPS a 0 - $ PutBlock StoneBlock 100 baseBlockPane + $ PutBlock defaultBlock baseBlockPane $ reverse $ square 10 ] @@ -65,20 +67,20 @@ Places a line of blocks between two points. Width 9, also extends out from each point by 9. -} blockLine :: Point2 -> Point2 -> Placement -blockLine a b = sps0 $ PutLineBlock baseBlockPane StoneBlock 9 9 a b +blockLine a b = sps0 $ PutLineBlock baseBlockPane 9 9 a b {- Places an breakable window between two points. Width 8, also extends out from each point by 8. -} windowLine :: Point2 -> Point2 -> Placement -windowLine a b = sps0 $ PutLineBlock defaultWindow GlassBlock 8 8 a b +windowLine a b = sps0 $ PutLineBlock defaultWindow 8 8 a b {- Places an unbreakable window between two points. Width 7, also extends out from each point by 7. -} crystalLine :: Point2 -> Point2 -> Placement -crystalLine a b = sps0 $ PutLineBlock defaultCrystalWall CrystalBlock 7 7 a b +crystalLine a b = sps0 $ PutLineBlock defaultCrystalWall 7 7 a b --crystalLine a b = sps0 $ PutWall ps defaultCrystalWall -- where -- ps = @@ -104,7 +106,7 @@ wallLine a b = sps0 $ PutWall ps defaultWall up = vNormal left windowLineType :: Point2 -> Point2 -> PSType -windowLineType = PutLineBlock defaultWindow GlassBlock 8 8 +windowLineType = PutLineBlock defaultWindow 8 8 baseBlockPane :: Wall baseBlockPane = defaultWall @@ -151,7 +153,7 @@ putBlockRect' w h = ps0jPushPS (aline tl tr) tr = V2 w h br = V2 w (-h) bl = V2 (-w) (-h) - aline = PutLineBlock baseBlockPane StoneBlock 9 9 + aline = PutLineBlock baseBlockPane 9 9 putBlockRect :: Float -> Float -> Float -> Float -> [Placement] putBlockRect a x b y = diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs index b221425f2..f723b7cbb 100644 --- a/src/Dodge/Placement/PlaceSpot.hs +++ b/src/Dodge/Placement/PlaceSpot.hs @@ -103,9 +103,9 @@ placeSpotID ps pt w = case pt of PutCoord cp -> plNewID coordinates (doShift cp) w PutSlideDr pth col f off a b spd -> plSlideDoor pth col f off (doShift a) (doShift b) spd w - PutBlock bm hp wl ps' - -> placeBlock (map doShift ps') hp wl bm w - PutLineBlock wl bm wdth dpth a b -> placeLineBlock wl bm wdth dpth (doShift a) (doShift b) w + PutBlock bl wl ps' + -> placeBlock (map doShift ps') bl wl w + PutLineBlock wl wdth dpth a b -> placeLineBlock wl wdth dpth (doShift a) (doShift b) w PutWall qs wl -> (0,placeWallPoly (map doShift qs) wl w) PutShape sh -> placeShape sh p rot w PutNothing -> (0,w) diff --git a/src/Dodge/Placement/PlaceSpot/Block.hs b/src/Dodge/Placement/PlaceSpot/Block.hs index d7b0fa42b..fe8b105c4 100644 --- a/src/Dodge/Placement/PlaceSpot/Block.hs +++ b/src/Dodge/Placement/PlaceSpot/Block.hs @@ -20,15 +20,14 @@ import qualified Data.IntSet as IS addBlock :: [Point2] -- ^ Block polygon -> Wall -- ^ Base Pane - -> Int -- ^ First layer of health - -> BlockMaterial + -> Block -> World -> World -addBlock (p:ps) wl hp bm w = w +addBlock (p:ps) wl bl w = w & wallsZone . znObjects %~ flip (IM.foldl' $ flip wallInZone) panes & walls %~ IM.union panes - & blocks %~ IM.insert blid Block - {_blID = blid,_blWallIDs = IS.fromList is, _blHP = hp, _blShadows=[], _blMaterial = bm + & blocks %~ IM.insert blid bl + {_blID = blid,_blWallIDs = IS.fromList is, _blShadows=[] , _blFootprint = p:ps, _blPos = centroid (p:ps), _blDraw = const mempty , _blDeath = makeBlockDebris} where @@ -51,26 +50,25 @@ addBlock (p:ps) wl hp bm w = w (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl) wlid = _wlID wl ips = map zoneOfPoint $ uncurry (divideLine (2*zoneSize)) (_wlLine wl) -addBlock _ _ _ _ _ = error "Trying to add a block with incomplete polygon" +addBlock _ _ _ _ = error "Trying to add a block with incomplete polygon" -placeBlock :: [Point2] -> Int -> Wall -> BlockMaterial -> World -> (Int,World) -placeBlock poly hp wl bm w +placeBlock :: [Point2] -> Block -> Wall -> World -> (Int,World) +placeBlock poly bl wl w = (0, foldr (uncurry removePathsCrossing) wWithBlock pairs) where pairs = loopPairs poly - wWithBlock = addBlock poly wl hp bm w + wWithBlock = addBlock poly wl bl w {- | Splits a line into many four cornered blocks. -} placeLineBlock :: Wall -- ^ Base pane - -> BlockMaterial -> Float -- ^ Block width -> Float -- ^ Block depth -> Point2 -- ^ Start point (symmetric) -> Point2 -- ^ End point (symmetric) -> World -> (Int, World) -placeLineBlock basePane bm blockWidth depth a b gw = ( 0 +placeLineBlock basePane blockWidth depth a b gw = ( 0 , removePathsCrossing a b (foldr insertWall (insertBlocks gw) listWalls) ) where @@ -86,7 +84,7 @@ placeLineBlock basePane bm blockWidth depth a b gw = ( 0 blid = IM.newKey $ _blocks gw insertBlock (i,p) = over blocks $ IM.insert (i+blid) Block { _blID = i + blid, _blWallIDs = IS.fromList $ ksAtI i - , _blHP = 1000, _blShadows = shadowsAt i, _blMaterial = bm + , _blHP = 1000, _blShadows = shadowsAt i , _blFootprint = cornersAt p -- TODO check winding (clockwise, anticlockwise) , _blPos = p, _blDraw = const mempty , _blDeath = makeBlockDebris} insertBlocks = flip (foldr insertBlock) $ zip is blockCenPs diff --git a/src/Dodge/Room/Pillar.hs b/src/Dodge/Room/Pillar.hs index d7f8c38e9..492403a4e 100644 --- a/src/Dodge/Room/Pillar.hs +++ b/src/Dodge/Room/Pillar.hs @@ -1,4 +1,5 @@ module Dodge.Room.Pillar where +import Dodge.Default.Block import Dodge.Placement.Instance.LightSource import Dodge.Data import Dodge.Cleat @@ -29,10 +30,10 @@ blockPillar w' h' = ps0jPushPS (aline tl tr) tr = V2 w h br = V2 w (-h) bl = V2 (-w) (-h) - aline = PutLineBlock baseBlockPane StoneBlock 9 9 + aline = PutLineBlock baseBlockPane 9 9 smallPillar :: PSType -smallPillar = PutBlock StoneBlock 500 baseBlockPane $ reverse $ square 5 +smallPillar = PutBlock defaultBlock 500 baseBlockPane $ reverse $ square 5 crossPillar :: Float -> Float -> Placement crossPillar w' h' = ps0jPushPS (aline (V2 (-w) 0) (V2 w 0)) diff --git a/src/Dodge/Room/RoadBlock.hs b/src/Dodge/Room/RoadBlock.hs index 1c70cb4f4..7a9061c5b 100644 --- a/src/Dodge/Room/RoadBlock.hs +++ b/src/Dodge/Room/RoadBlock.hs @@ -1,6 +1,7 @@ {- Connecting rooms designed with a pass-through technique in mind. -} module Dodge.Room.RoadBlock where import Dodge.Default.Wall +import Dodge.Default.Block import Dodge.Cleat import Dodge.Data import Dodge.RoomLink @@ -67,7 +68,7 @@ blockedCorridor :: RandomGen g => State g (Tree Room) blockedCorridor = longBlockedCorridor 0 dirtPoly :: [Point2] -> PSType -dirtPoly = PutBlock DirtBlock 1 defaultDirtWall . reverse +dirtPoly = PutBlock defaultDirtBlock defaultDirtWall . reverse -- | A single corridor with a destructible block blocking it. blockedCorridorCloseBlocks :: RandomGen g => State g Room