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

Unify block wall types

Browse Source
This commit is contained in:
justin
2021-10-28 00:05:57 +01:00
parent 74e19008b4
commit 686a9fc3ee
9 changed files with 38 additions and 187 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data.hs
+15 -30
View File
@@ -57,7 +57,7 @@ data World = World
, _particles :: ![Particle]
, _walls :: !(IM.IntMap Wall)
, _doors :: IM.IntMap Door
, _blocks :: IM.IntMap Block'
, _blocks :: IM.IntMap Block
, _wallsZone :: Zone (IM.IntMap Wall)
, _forceFields :: IM.IntMap ForceField
, _floorItems :: IM.IntMap FloorItem
@@ -536,11 +536,11 @@ data Prop
, _pjTimer :: Int
}
data Either3 a b c = E3x1 a | E3x2 b | E3x3 c
data Block' = Block'
data Block = Block
{ _blID :: Int
, _blWallIDs :: [Int]
, _blHPs :: [Int]
, _blShadows' :: [Int]
, _blShadows :: [Int]
}
data Door = Door
{ _drID :: Int
@@ -551,32 +551,17 @@ data Door = Door
}
data DoorStatus = DoorOpen | DoorClosed | DoorHalfway | DoorInt Int
deriving (Eq, Ord, Show)
data Wall
= Wall
{ _wlLine :: (Point2,Point2)
, _wlID :: Int
, _wlColor :: Color
, _wlSeen :: Bool
, _wlIsSeeThrough :: Bool
, _wlPathable :: Bool
, _wlDraw :: Bool
, _wlRotateTo :: Bool
}
| Block
{ _wlLine :: (Point2,Point2)
, _wlID :: Int
, _wlColor :: Color
, _wlSeen :: Bool
, _blIDs :: [Int]
--, _blHP :: Int
, _wlIsSeeThrough :: Bool
, _blVisible :: Bool
--, _blDegrades :: [Int]
, _blShadows :: [Int]
, _wlDraw :: Bool
, _wlRotateTo :: Bool
, _wlBlockID :: Int
}
data Wall = Wall
{ _wlLine :: (Point2,Point2)
, _wlID :: Int
, _wlColor :: Color
, _wlSeen :: Bool
, _wlIsSeeThrough :: Bool
, _wlPathable :: Bool
, _wlDraw :: Bool
, _wlRotateTo :: Bool
, _wlBlockID :: Maybe Int
}
data ForceField = FF
{ _ffLine :: [Point2] , _ffID :: Int
, _ffColor :: Color
@@ -773,7 +758,7 @@ makeLenses ''CrGroupParams
makeLenses ''CrMvType
makeLenses ''Intention
makeLenses ''Door
makeLenses ''Block'
makeLenses ''Block
makeLenses ''Zone
numColor :: Int -> Color
numColor 0 = toV4 (1,0,0,1)
src/Dodge/Default/Wall.hs
+1 -15
View File
@@ -14,22 +14,8 @@ defaultWall = Wall
, _wlPathable = False
, _wlDraw = True
, _wlRotateTo = True
, _wlBlockID = Nothing
}
defaultBlock :: Wall
defaultBlock = Block
{ _wlLine = (V2 0 0,V2 50 0)
, _wlID = 0
, _wlColor = greyN 0.5
, _wlSeen = False
, _blIDs = []
, _wlIsSeeThrough = False
, _blVisible = True
, _blShadows = []
, _wlDraw = True
, _wlRotateTo = True
, _wlBlockID = 0
}
{- Indestructible see-through wall. -}
defaultCrystalWall :: Wall
defaultCrystalWall = defaultWall
src/Dodge/Initialisation.hs
-16
View File
@@ -57,24 +57,8 @@ initialWorld = defaultWorld
, _menuLayers = [TerminalScreen 300 rezText']
}
zonedBlockWalls :: World -> [String]
zonedBlockWalls = concatMap f . IM.toList . _znObjects . _wallsZone
where
f (x,ys) = map (show x ++) $ map g $ IM.toList ys
g (y,zs) = show y
testStringInit :: World -> [String]
testStringInit _ = []
--testStringInit w = map (show . _blWallIDs) . IM.elems $ _blocks w
--testStringInit w = (map (f w) . filter g . IM.elems $ _walls w)
-- ++ map (show . fst) (IM.toList $ _znObjects $ _wallsZone w)
-- ++ zonedBlockWalls w
where
g Block{} = True
g _ = False
f w' wl = show (_wlID wl) ++ " : " ++ show blid ++ show (_blWallIDs $ (_blocks w') IM.! blid)
where
blid = _wlBlockID wl
--testStringInit = mapMaybe f . IM.elems . flattenIMIMIM . _znObjects . _wallsZone
-- where
-- f dr | _wlColor dr == V4 0 1 0 1 = Just . show $ _wlLine dr
src/Dodge/LevelGen/Block.hs
+4 -86
View File
@@ -11,90 +11,14 @@ import Dodge.Zone
--import Dodge.SoundLogic.LoadSound
--import Dodge.WorldEvent.Sound
import Dodge.LevelGen.Pathing
import Dodge.Default.Wall
--import Dodge.RandomHelp
import Geometry
import qualified IntMapHelp as IM
import Color
import Control.Lens
--import Control.Monad.State
import Data.List
--import Data.Maybe
--import Data.Function
--import System.Random
--updateBlocks :: World -> World
--updateBlocks w
-- = w --(\w' -> seq (_wallsZone w') w')
-- $ flip (foldl' $ flip removeFromZone) deadPanes
-- $ over walls (\wls -> wls `seq` IM.filter (not . blockIsDead) wls) degradeBlocks
-- where
-- --degradeBlocks = deadBlocks `seq` foldl' (flip killBlock) w deadBlocks
-- removeFromZone :: Wall -> World -> World
-- removeFromZone bl = over (wallsZone . znObjects . ix x . ix y) (IM.delete (_wlID bl))
-- where
-- (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine bl)
-- deadPanes w' = filter (blockIsDead w') (IM.elems $ _walls w)
-- --deadBlocks = nubBy ((==) `on` _blIDs) deadPanes
-- blockIsDead w' wl = case IM.lookup (_wlBlockID wl) $ _blocks w of
-- Just x -> x <= 0
-- Nothing -> False
{- | Destroy a block.
Plays destruction sound and sets to be displayed other walls that were shadowed by this wall. -}
--killBlock :: Wall -> World -> World
--killBlock bl w = f bl . flip (foldl' $ flip unshadow) (_blShadows bl) $ w
-- where
-- f :: Wall -> World -> World
-- f bl'
-- | isJust (bl ^? blDegrades . ix 0) = degradeBlock bl' . breakHitSound bl
-- | otherwise = hitSound' bl'
-- pos = fst $ _wlLine bl
-- breakHitSound bl'
-- | _wlIsSeeThrough bl' = mkSoundBreakGlass pos
-- | otherwise = soundMultiFrom sos (fst $ _wlLine bl') impactSound Nothing
-- hitSound' bl'
-- | _wlIsSeeThrough bl' = mkSoundSplinterGlass pos
-- | otherwise = soundMultiFrom sos (fst $ _wlLine bl') impactSound Nothing
-- sos = [BlockDegradeSound 0,BlockDegradeSound 1]
-- impactSound = evalState (takeOne [impact1S,impact2S,impact3S,impact4S]) $ _randGen w
-- unshadow :: Int -> World -> World
-- unshadow bid w' = case w' ^? walls . ix bid of
-- Just b ->
-- let (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine b)
-- in w & wallsZone . znObjects . ix x . ix y . ix bid . blVisible %~ const True
-- & walls . ix bid . blVisible %~ const True
-- Nothing -> w
--degradeBlock :: Wall -> World -> World
--degradeBlock bl w =
-- let blid = _wlID bl
-- bls = map (\i -> _walls w IM.! i) (_blIDs $ _walls w IM.! blid)
-- ps = reverse $ orderPolygon $ nub $ concatMap ((\(a,b) -> [a,b]) . _wlLine) bls
-- (newPs,g) = runState (shrinkPolygon 0.5 ps) $ _randGen w
-- (x:xs) = _blDegrades bl
-- in addBlock newPs (x + _blHP bl) (_wlColor bl) (_wlIsSeeThrough bl) xs $ set randGen g w
{-
This does not have clear behaviour in my mind, and should probably be replaced with something more obvious...
-}
--pushPointTowardsBy
-- :: RandomGen g
-- => Float
-- -> Point2
-- -> [Point2]
-- -> State g Point2
--pushPointTowardsBy x p ps = do
-- xs <- replicateM (length ps) $ state $ randomR (0, x / fromIntegral (length ps))
-- let toAdd p' y = y *.* (p' -.- p)
-- return $ p +.+ foldl1' (+.+) (zipWith toAdd ps xs)
--shrinkPolygon
-- :: RandomGen g
-- => Float -- ^ Shrink parameter
-- -> [Point2]
-- -> State g [Point2]
--shrinkPolygon x ps = mapM (flip (pushPointTowardsBy x) ps) ps
addBlock
:: [Point2] -- ^ Block polygon
@@ -110,25 +34,19 @@ addBlock (p:ps) hp col isSeeThrough hps w
| otherwise = w
& wallsZone . znObjects %~ flip (IM.foldl' $ flip wallInZone) panes
& walls %~ IM.union panes
& blocks %~ IM.insert blid (Block' {_blID = blid,_blWallIDs = is, _blHPs = hp:hps, _blShadows'=[]})
& blocks %~ IM.insert blid (Block {_blID = blid,_blWallIDs = is, _blHPs = hp:hps, _blShadows=[]})
where
blid = IM.newKey $ _blocks w
lns = zip (p:ps) (ps ++ [p])
i = IM.newKey $ _walls w
is = [i.. i + length lns-1]
panes = IM.fromList $ zip is $ zipWith
(\j (a,b) -> Block
(\j (a,b) -> defaultWall
{ _wlLine = (a,b)
, _wlID = j
, _wlColor = col
, _wlSeen = False
, _blIDs = is
, _wlIsSeeThrough = isSeeThrough
, _blVisible = True
, _blShadows = []
, _wlDraw = True
, _wlRotateTo = True
, _wlBlockID = blid
, _wlBlockID = Just blid
}
) is lns
wallInZone wl
src/Dodge/LevelGen/LineBlock.hs
+6 -13
View File
@@ -18,8 +18,7 @@ putLineBlock
-> Point2 -- ^ End point (symmetric)
-> World
-> (Int, World)
putLineBlock basePane blockWidth depth a b w
= (,) 0
putLineBlock basePane blockWidth depth a b w = (,) 0
$ removePathsCrossing a b $ foldr insertBlock (insertBlocks' w) listBlocks
where
d = dist a b
@@ -29,17 +28,13 @@ putLineBlock basePane blockWidth depth a b w
blockCenPs = snd $ evenOddSplit psOnLine
numBlocks = length blockCenPs
is = [0.. numBlocks - 1]
cornerPoints = map toV2
[(-halfBlockWidth,-depth) -- goes anticlockwise around the block
,(-halfBlockWidth, depth)
,( halfBlockWidth, depth)
,( halfBlockWidth,-depth)
]
cornerPoints = reverse $ rectWH halfBlockWidth depth -- goes clockwise around the block
cornersAt p = fmap ( (p +.+) . rotateV rot) cornerPoints
linesAt p = makeLoopPairs $ cornersAt p
k = IM.newKey $ _walls w
blid = IM.newKey $ _blocks w
insertBlock' i = over blocks $ IM.insert (i+blid) Block' {_blID = i + blid, _blWallIDs = ksAtI i, _blHPs = [5,5], _blShadows' = shadowsAt i}
insertBlock' i = over blocks
$ IM.insert (i+blid) Block {_blID = i + blid, _blWallIDs = ksAtI i, _blHPs = [5,5], _blShadows = shadowsAt i}
insertBlocks' = flip (foldr insertBlock') is
ksAtI i = map ( + (k + i*4) ) [0,1,2,3]
visibilityAt i
@@ -54,11 +49,9 @@ putLineBlock basePane blockWidth depth a b w
makeBlockAt p i = zipWith3 (makePane i) (visibilityAt i) (ksAtI i) (linesAt p)
makePane i visStatus k' ps = basePane
{_wlID = k'
,_wlBlockID = i + blid
,_wlBlockID = Just $ i + blid
,_wlLine = ps
,_blIDs = ksAtI i
,_blShadows = shadowsAt i
,_blVisible = visStatus
,_wlDraw = visStatus
}
listBlocks = concat $ zipWith makeBlockAt blockCenPs is
insertBlock :: Wall -> World -> World
src/Dodge/Render/Picture.hs
+2 -11
View File
@@ -96,8 +96,6 @@ soundPics w
| _show_sound (_config w) = pictures $ M.map (soundPic w) $ _playingSounds w
| otherwise = []
soundPic :: World -> Sound -> Picture
soundPic w s = fixedSizePicClampArrow 50 50 thePic p w
where
@@ -126,7 +124,7 @@ wallFloorsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w
where
onScreen wall = uncurry (lineOnScreen w) $ _wlLine wall
isVisible wl
| wl ^? blVisible == Just False = False
| wl ^? wlDraw == Just False = False
| otherwise = onScreen wl
drawWallFloor :: Wall -> Picture
@@ -162,12 +160,6 @@ outsideScreenPolygon w = [tr,tl,bl,br]
br = scTran $ scRot $ scZoom $ V2 ( 3*halfWidth w ) (- (3* halfHeight w))
bl = scTran $ scRot $ scZoom $ V2 (- (3*halfWidth w)) (- (3* halfHeight w))
wallShadowsToDraw :: World -> [Wall]
wallShadowsToDraw w
= filter (fromMaybe True . (^? blVisible))
. IM.elems
$ wallsNearZones (zoneOfSight w) w
-- cannot only test if walls are on screen, but also if they are on the cone
-- towards the center of sight
lineOnScreenCone :: World -> Point2 -> Point2 -> Bool
@@ -256,11 +248,10 @@ wallsAndWindows
:: World
-> ( [((Point2,Point2),Point4)] ,[((Point2,Point2),Point4)] )
wallsAndWindows w
= (map f wls, map f $ filter (fromMaybe True . (^? blVisible)) wins)
= (map f wls, map f wins)
where
f wl = (_wlLine wl, _wlColor wl)
(wins,wls) = partition _wlIsSeeThrough . IM.elems . IM.filter _wlDraw $ wallsDoubleScreen w
--(wins,wls) = partition _wlIsSeeThrough . IM.elems $ wallsOnScreen w
wallsToList :: [((Point2,Point2),Point4)] -> [Float]
wallsToList = concatMap (\((V2 a b,V2 c d),V4 e f g h) -> [a,b,c,d,e,f,g,h])
src/Dodge/Room/Placement.hs
+2 -8
View File
@@ -91,27 +91,21 @@ windowLineType :: Point2 -> Point2 -> PSType
windowLineType = PutLineBlock baseWindowPane 8 8
baseBlockPane :: Wall
baseBlockPane = defaultBlock
baseBlockPane = defaultWall
{ _wlLine = (V2 0 0,V2 50 0)
, _wlID = 0
, _wlColor = greyN 0.5
, _wlSeen = False
, _blIDs = []
, _wlIsSeeThrough = False
, _blVisible = True
, _blShadows = []
, _wlDraw = True
}
baseWindowPane :: Wall
baseWindowPane = defaultBlock
baseWindowPane = defaultWall
{ _wlLine = (V2 0 0,V2 50 0)
, _wlID = 0
, _wlColor = withAlpha 0.2 cyan
, _wlSeen = False
, _blIDs = []
, _wlIsSeeThrough = True
, _blVisible = True
, _blShadows = []
, _wlDraw = True
}
{- Replaces instances of a given 'PutID' with 'PSType's drawn from a list. -}
src/Dodge/Update.hs
+7 -7
View File
@@ -82,8 +82,8 @@ functionalUpdate w = case _menuLayers w of
where
(x,y) = cloudZoneOfPoint $ stripZ $ _clPos cl
splinterBlock :: Block' -> World -> World
splinterBlock bl w = foldr unshadowBlock w (_blShadows' bl) -- foldr shiftTowardCen w (_blWallIDs bl)
splinterBlock :: Block -> World -> World
splinterBlock bl w = foldr unshadowBlock w (_blShadows bl) -- foldr shiftTowardCen w (_blWallIDs bl)
& blocks . ix (_blID bl) . blHPs %~ tail
& theSoundEffect cen
where
@@ -97,8 +97,8 @@ splinterBlock bl w = foldr unshadowBlock w (_blShadows' bl) -- foldr shiftToward
unshadowBlock :: Int -> World -> World
unshadowBlock wlid w = case w ^? walls . ix wlid of
Just wl -> w
& walls . ix wlid . blVisible .~ True
& wallsZone . znObjects . ix x . ix y . ix wlid . blVisible .~ True
& walls . ix wlid . wlDraw .~ True
& wallsZone . znObjects . ix x . ix y . ix wlid . wlDraw .~ True
where
(x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl)
Nothing -> w
@@ -108,10 +108,10 @@ updateBlocks w = foldr f w $ _blocks w
where
f bl w' = case _blHPs bl of
(x:_:_) | x < 1 -> splinterBlock bl w'
(x:[]) | x < 1 -> destroyBlock bl w'
[x] | x < 1 -> destroyBlock bl w'
_ -> w'
destroyBlock :: Block' -> World -> World
destroyBlock :: Block -> World -> World
destroyBlock bl w = w
& walls %~ removeIDs wlids
& flip (foldr removeFromZone) wlids
@@ -126,7 +126,7 @@ destroyBlock bl w = w
(x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl)
wl = _walls w IM.! wlid -- note the use of w not w'
-- | Note the explict use of record syntax. Using lens creates a space leak.
-- | Note the explict use of record syntax. Using lens created a space leak.
resetWorldEvents :: World -> World
resetWorldEvents w = w {_worldEvents = id}
src/Dodge/WorldEvent/DamageBlock.hs
+1 -1
View File
@@ -5,7 +5,7 @@ import Dodge.Data
import Control.Lens
damageBlocksBy :: Int -> Wall -> World -> World
damageBlocksBy x wl = case wl ^? wlBlockID of
damageBlocksBy x wl = case _wlBlockID wl of
Just blid -> blocks . ix blid . blHPs %~ reduceHeadBy x
Nothing -> id
where