diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index db385a17d..fd20f4ede 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -560,8 +560,10 @@ data Wall = Wall , _wlPathable :: Bool , _wlDraw :: Bool , _wlRotateTo :: Bool - , _wlBlockID :: Maybe Int + , _wlBlockID :: Maybe' Int } +-- | Strict maybe +data Maybe' a = Just' a | Nothing' data ForceField = FF { _ffLine :: [Point2] , _ffID :: Int , _ffColor :: Color diff --git a/src/Dodge/Default/Wall.hs b/src/Dodge/Default/Wall.hs index 7c956bc72..388a0f6e5 100644 --- a/src/Dodge/Default/Wall.hs +++ b/src/Dodge/Default/Wall.hs @@ -14,7 +14,7 @@ defaultWall = Wall , _wlPathable = False , _wlDraw = True , _wlRotateTo = True - , _wlBlockID = Nothing + , _wlBlockID = Nothing' } {- Indestructible see-through wall. -} defaultCrystalWall :: Wall diff --git a/src/Dodge/LevelGen/Block.hs b/src/Dodge/LevelGen/Block.hs index 486ac0342..d016384dd 100644 --- a/src/Dodge/LevelGen/Block.hs +++ b/src/Dodge/LevelGen/Block.hs @@ -4,15 +4,10 @@ module Dodge.LevelGen.Block ) where import Dodge.Data ---import Dodge.Data.SoundOrigin import Dodge.Base import Dodge.Zone ---import Dodge.SoundLogic ---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 @@ -31,7 +26,7 @@ addBlock addBlock (p:ps) hp col isSeeThrough hps w | hp <= 0 && null hps = w | hp <= 0 = addBlock (p:ps) (head hps + hp) col isSeeThrough (tail hps) w - | otherwise = 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=[]}) @@ -40,13 +35,13 @@ addBlock (p:ps) hp col isSeeThrough hps 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) -> defaultWall + panes = IM.fromList $ zipWith + (\j (a,b) -> (,) j defaultWall { _wlLine = (a,b) , _wlID = j , _wlColor = col , _wlIsSeeThrough = isSeeThrough - , _wlBlockID = Just blid + , _wlBlockID = Just' blid } ) is lns wallInZone wl @@ -59,7 +54,6 @@ addBlock (p:ps) hp col isSeeThrough hps w ips = map zoneOfPoint $ uncurry (divideLine (2*zoneSize)) (_wlLine wl) addBlock _ _ _ _ _ _ = error "Trying to add a block with incomplete polygon" ----- TODO add block list to world putBlock :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> (Int,World) putBlock (p:ps) i c b is w = (0, foldr (uncurry removePathsCrossing) wWithBlock pairs) where diff --git a/src/Dodge/LevelGen/LineBlock.hs b/src/Dodge/LevelGen/LineBlock.hs index 654b947d0..17b2d2e4c 100644 --- a/src/Dodge/LevelGen/LineBlock.hs +++ b/src/Dodge/LevelGen/LineBlock.hs @@ -19,7 +19,7 @@ putLineBlock -> World -> (Int, World) putLineBlock basePane blockWidth depth a b w = (,) 0 - $ removePathsCrossing a b $ foldr insertBlock (insertBlocks' w) listBlocks + $ removePathsCrossing a b $ foldr insertWall (insertBlocks w) listWalls where d = dist a b rot = argV (b -.- a) @@ -33,9 +33,9 @@ putLineBlock basePane blockWidth depth a b w = (,) 0 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} - insertBlocks' = flip (foldr insertBlock') is + 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 | i == 0 = [ True,True,False,True] @@ -45,14 +45,12 @@ putLineBlock basePane blockWidth depth a b w = (,) 0 | i == 0 = ksAtI 1 | i == numBlocks - 1 = ksAtI $ numBlocks - 2 | otherwise = ksAtI (i-1) ++ ksAtI (i+1) - makeBlockAt :: Point2 -> Int -> [Wall] - makeBlockAt p i = zipWith3 (makePane i) (visibilityAt i) (ksAtI i) (linesAt p) + makeWallAt p i = zipWith3 (makePane i) (visibilityAt i) (ksAtI i) (linesAt p) makePane i visStatus k' ps = basePane {_wlID = k' - ,_wlBlockID = Just $ i + blid + ,_wlBlockID = Just' $ i + blid ,_wlLine = ps ,_wlDraw = visStatus } - listBlocks = concat $ zipWith makeBlockAt blockCenPs is - insertBlock :: Wall -> World -> World - insertBlock wl = over walls $ IM.insert (_wlID wl) wl + listWalls = concat $ zipWith makeWallAt blockCenPs is + insertWall wl = over walls $ IM.insert (_wlID wl) wl diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index c3673e688..da447116b 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -11,7 +11,6 @@ import Dodge.Config.Data import Dodge.Base import Dodge.Zone import Dodge.WallCreatureCollisions ---import Dodge.LevelGen.Block import Dodge.Update.Camera import Dodge.SoundLogic import Dodge.Inventory @@ -178,12 +177,14 @@ ppEvents :: World -> World ppEvents w = IM.foldl' (flip $ \pp w' -> _ppEvent pp pp w') w $ _pressPlates w updateSeenWalls :: World -> World -updateSeenWalls w = foldl' (flip markSeen) w wallsToUpdate +updateSeenWalls w = foldl' markWallSeen w wallsToUpdate where vPos = _cameraViewFrom w wallsToUpdate = concatMap (\p -> visibleWalls vPos (vPos +.+p) $ wallsAlongLine vPos (vPos +.+ p) w) $ nRays 20 - markSeen i = set (walls . ix i . wlSeen) True + +markWallSeen :: World -> Wall -> World +markWallSeen w wl = w & walls . ix (_wlID wl) . wlSeen .~ True --setTestStringIO :: IO World -> IO World --setTestStringIO = fmap (\ w -> set testString (show $ s w) w) @@ -301,15 +302,14 @@ rotateToOverlappingWall w = case theWall of theWall = overlapCircWallsReturnWall p (_crRad cr + 5) (IM.filter _wlRotateTo $ wallsNearPoint p w) {- -Finds the IDs of visible walls from a point to another point. -} -visibleWalls :: Point2 -> Point2 -> IM.IntMap Wall -> [Int] +Finds the visible walls from a point to another point. -} +visibleWalls :: Point2 -> Point2 -> IM.IntMap Wall -> [Wall] visibleWalls p1 p2 ws - = map fst - . takeUntil (_wlIsSeeThrough . snd) + = takeUntil _wlIsSeeThrough . map snd . sortOn (dist p1 . fromJust . fst) . filter ((/=) Nothing . fst) . map f $ IM.toList ws where - f (i,wl) = (uncurry intersectSegSeg (_wlLine wl) p1 p2, (i,wl)) + f (i,wl) = (uncurry intersectSegSeg (_wlLine wl) p1 p2, wl) diff --git a/src/Dodge/WorldEvent/DamageBlock.hs b/src/Dodge/WorldEvent/DamageBlock.hs index 759812bab..8c3666186 100644 --- a/src/Dodge/WorldEvent/DamageBlock.hs +++ b/src/Dodge/WorldEvent/DamageBlock.hs @@ -6,8 +6,8 @@ import Control.Lens damageBlocksBy :: Int -> Wall -> World -> World damageBlocksBy x wl = case _wlBlockID wl of - Just blid -> blocks . ix blid . blHPs %~ reduceHeadBy x - Nothing -> id + Just' blid -> blocks . ix blid . blHPs %~ reduceHeadBy x + Nothing' -> id where reduceHeadBy y (z:zs) = z - y : zs reduceHeadBy _ [] = []