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

Commit mid block refactor

Browse Source
This commit is contained in:
justin
2022-06-18 11:07:17 +01:00
parent a1c7abedaf
commit 781e337cad
10 changed files with 78 additions and 64 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Base/Collide.hs
+4 -2
View File
@@ -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)
src/Dodge/Block.hs
+14 -9
View File
@@ -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
src/Dodge/Block/Debris.hs
+23 -17
View File
@@ -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]
src/Dodge/Data.hs
+6 -7
View File
@@ -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)]
src/Dodge/Default/Wall.hs
+5 -5
View File
@@ -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
}
src/Dodge/Placement/Instance/Wall.hs
+8 -6
View File
@@ -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 =
src/Dodge/Placement/PlaceSpot.hs
+3 -3
View File
@@ -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)
src/Dodge/Placement/PlaceSpot/Block.hs
+10 -12
View File
@@ -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
src/Dodge/Room/Pillar.hs
+3 -2
View File
@@ -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))
src/Dodge/Room/RoadBlock.hs
+2 -1
View File
@@ -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