From a4ec4e4889e34ffefcc12d773ffcb29baea5e8a3 Mon Sep 17 00:00:00 2001 From: justin Date: Wed, 9 Mar 2022 10:51:01 +0000 Subject: [PATCH] Improve rooms, make consumable use type --- src/Dodge/Creature.hs | 1 + src/Dodge/Creature/Impulse/UseItem.hs | 23 +++++++++++----- src/Dodge/Data.hs | 5 +++- src/Dodge/Default/World.hs | 2 +- src/Dodge/Floor.hs | 4 +-- src/Dodge/Item/Consumable.hs | 9 +++---- src/Dodge/LockAndKey.hs | 7 ----- src/Dodge/Room.hs | 2 ++ src/Dodge/Room/Containing.hs | 20 ++++++++++++++ src/Dodge/Room/Door.hs | 1 + src/Dodge/Room/Procedural.hs | 19 ++++++------- src/Dodge/Room/RezBox.hs | 1 + src/Dodge/Room/Start.hs | 12 +++++++++ src/Dodge/Room/Tanks.hs | 1 + src/Dodge/Tree/Shift.hs | 39 ++++++++++++++++----------- src/Dodge/Update.hs | 2 +- 16 files changed, 98 insertions(+), 50 deletions(-) create mode 100644 src/Dodge/Room/Containing.hs diff --git a/src/Dodge/Creature.hs b/src/Dodge/Creature.hs index 151e908ee..366abd3d3 100644 --- a/src/Dodge/Creature.hs +++ b/src/Dodge/Creature.hs @@ -169,6 +169,7 @@ testInventory = IM.fromList $ zip [0..] [ makeTypeCraftNum 9 PIPE , incendiaryModule , bounceModule + , medkit 50 , teleportModule , makeTypeCraftNum 1 LIGHTER , makeTypeCraftNum 5 TUBE diff --git a/src/Dodge/Creature/Impulse/UseItem.hs b/src/Dodge/Creature/Impulse/UseItem.hs index 12345dfb1..5fa3c0020 100644 --- a/src/Dodge/Creature/Impulse/UseItem.hs +++ b/src/Dodge/Creature/Impulse/UseItem.hs @@ -3,31 +3,38 @@ module Dodge.Creature.Impulse.UseItem , useLeftItem ) where import Dodge.Data ---import Dodge.Inventory +import Dodge.Inventory import qualified Data.IntMap.Strict as IM import Control.Lens import Data.Maybe useItem :: Creature -> World -> World -useItem cr' w = fromMaybe w $ do +useItem cr' w = f $ fromMaybe w $ do cr <- w ^? creatures . ix (_crID cr') it <- cr ^? crInv . ix (_crInvSel cr) return $ itemEffect cr it w + where + f = case _crID cr' of + 0 -> youHammerPosition .~ HammerDown + _ -> id itemEffect :: Creature -> Item -> World -> World itemEffect cr it w = case it ^? itUse of Just RightUse {_rUse = eff,_useMods = usemods} -> foldr ($) eff usemods it cr w Just LeftUse {} -> lhammer setEquipLeftItem Just EquipUse{} -> lhammer setEquipment + -- ConsumeUse will cause problems if the item is not selected + Just (ConsumeUse eff) -> hammerTest $ eff it cr . rmInvItem (_crID cr) (_crInvSel cr) Just NoUse -> w Nothing -> w where - lhammer f' = w - & lSelHammerPosition .~ HammerDown - & case _lSelHammerPosition w of - HammerUp -> creatures . ix (_crID cr) %~ f' - _ -> id + hammerTest f = case _youHammerPosition w of + HammerUp -> f w + _ -> w + lhammer f' = w & case _youHammerPosition w of + HammerUp -> creatures . ix (_crID cr) %~ f' + _ -> id setEquipLeftItem cr' = case _crLeftInvSel cr' of Just i | i == _crInvSel cr' -> cr' & crLeftInvSel .~ Nothing _ -> cr' & crLeftInvSel ?~ _crInvSel cr' @@ -42,9 +49,11 @@ toggleEquipmentAt invid cr = cr & crInvEquipped . at invid %~ f useLeftItem :: Int -> World -> World useLeftItem cid w | _crInvLock cr = w + | isJust (citem ^? itUse . cUse) = useItem cr w | otherwise = fromMaybe w $ do invid <- _crLeftInvSel cr f <- cr ^? crInv . ix invid . itUse . lUse return $ f cr invid w where cr = _creatures w IM.! cid + citem = _crInv cr IM.! _crInvSel cr diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 66edce386..d6a8577ac 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -128,7 +128,7 @@ data World = World , _rewindWorlds :: [World] , _timeFlow :: TimeFlowStatus , _worldClock :: Int - , _lSelHammerPosition :: HammerPosition + , _youHammerPosition :: HammerPosition , _worldTerminal :: Maybe' WorldTerminal } data WorldTerminal = WorldTerminal Int [(Int,String)] @@ -334,6 +334,9 @@ data ItemUse , _useDelay :: UseDelay , _useHammer :: HammerType } + | ConsumeUse + { _cUse :: Item -> Creature -> World -> World + } | EquipUse { _eqUse :: Creature -> Int -> World -> World } diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index 26cb4f18e..a05622093 100644 --- a/src/Dodge/Default/World.hs +++ b/src/Dodge/Default/World.hs @@ -89,7 +89,7 @@ defaultWorld = World , _maybeWorld = Nothing' , _rewindWorlds = [] , _timeFlow = NormalTimeFlow - , _lSelHammerPosition = HammerUp + , _youHammerPosition = HammerUp , _worldTerminal = Nothing' } youLight :: TempLightSource diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 19b5683cc..3b5f66152 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -33,8 +33,8 @@ import System.Random initialAnoTree :: RandomGen g => Tree [Annotation g] initialAnoTree = padSucWithCorridors $ treeFromTrunk --- [[AnoApplyInt 0 startRoom] - [[SpecificRoom startRoom'] + [[AnoApplyInt 0 startRoom] +-- [[SpecificRoom startRoom'] -- , [SpecificRoom $ rezThenLasTurret] -- , [SpecificRoom $ fmap (return . PassDown) longRoom] , [PassthroughLockKeyLists 2 lockRoomKeyItems itemRooms] diff --git a/src/Dodge/Item/Consumable.hs b/src/Dodge/Item/Consumable.hs index f91323485..ccf3a7d06 100644 --- a/src/Dodge/Item/Consumable.hs +++ b/src/Dodge/Item/Consumable.hs @@ -3,23 +3,20 @@ import Dodge.Data --import Dodge.Picture.Layer import Dodge.Default import Dodge.SoundLogic -import Dodge.Inventory import Shape --import ShapePicture import Dodge.Item.Draw import Picture -import Data.Maybe +--import Data.Maybe import Control.Lens import qualified Data.IntMap.Strict as IM medkit :: Int -> Item medkit i = defaultConsumable { _itName = "MEDKIT" ++ show i - , _itUse = LeftUse - {_lUse = \cr invid w -> fromMaybe w (heal 25 (_crID cr) $ rmInvItem (_crID cr) invid w) - ,_useDelay = NoDelay - ,_useHammer = HasHammer HammerUp + , _itUse = ConsumeUse + {_cUse = \_ cr w -> w & creatures . ix (_crID cr) . crHP +~ i } , _itEquipPict = pictureItem $ (,) emptySH $ color blue $ circleSolid 3 , _itID = Nothing diff --git a/src/Dodge/LockAndKey.hs b/src/Dodge/LockAndKey.hs index 02efa5911..1515dbf61 100644 --- a/src/Dodge/LockAndKey.hs +++ b/src/Dodge/LockAndKey.hs @@ -64,13 +64,6 @@ someCrits = do -- crits <- takeN nCrits <=< shuffle $ fmap PutCrit $ [spreadGunCrit,pistolCrit,autoCrit,armourChaseCrit] -- return $ roomsContaining crits its -roomsContaining :: RandomGen g => [Creature] -> [Item] -> State g (SubCompTree Room) -roomsContaining crs its = do - endroom <- join $ takeOne - [ randomFourCornerRoomCrsIts crs its - , tanksRoom crs its - ] - return $ treeFromPost [] $ PassDown endroom corridorBoss :: RandomGen g => Creature -> State g (SubCompTree Room) corridorBoss cr = do diff --git a/src/Dodge/Room.hs b/src/Dodge/Room.hs index ca496a139..9d160ac8b 100644 --- a/src/Dodge/Room.hs +++ b/src/Dodge/Room.hs @@ -19,6 +19,7 @@ module Dodge.Room , module Dodge.Room.Treasure , module Dodge.Room.GlassLesson , module Dodge.Room.Tanks + , module Dodge.Room.Containing ) where import Dodge.Room.Room import Dodge.Room.RoadBlock @@ -39,3 +40,4 @@ import Dodge.Room.LongDoor import Dodge.Room.LongRoom import Dodge.Room.GlassLesson import Dodge.Room.Tanks +import Dodge.Room.Containing diff --git a/src/Dodge/Room/Containing.hs b/src/Dodge/Room/Containing.hs new file mode 100644 index 000000000..a599457e1 --- /dev/null +++ b/src/Dodge/Room/Containing.hs @@ -0,0 +1,20 @@ +module Dodge.Room.Containing where +import Dodge.Data +import Dodge.Tree +import Dodge.LevelGen.Data +import Dodge.RandomHelp +import Dodge.Room.Procedural +import Dodge.Room.Tanks +--import Dodge.Item.Equipment + +import System.Random +import Control.Monad.State + + +roomsContaining :: RandomGen g => [Creature] -> [Item] -> State g (SubCompTree Room) +roomsContaining crs its = do + endroom <- join $ takeOne + [ randomFourCornerRoomCrsIts crs its + , tanksRoom crs its + ] + return $ treeFromPost [] $ UseAll endroom diff --git a/src/Dodge/Room/Door.hs b/src/Dodge/Room/Door.hs index 2bef11880..2c50f63ac 100644 --- a/src/Dodge/Room/Door.hs +++ b/src/Dodge/Room/Door.hs @@ -20,6 +20,7 @@ door = defaultRoom , _rmPath = [(V2 20 35,V2 20 5)] -- door extends into side walls (for shadows as rendered 12/03) , _rmPmnts = [putAutoDoor (V2 0 20) (V2 40 20)] + , _rmName = "autoDoor" -- note no bounds } where diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index 5d914af90..140f89571 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/src/Dodge/Room/Procedural.hs @@ -67,15 +67,16 @@ roomRect x y xn yn = defaultRoom where yd = (y - 40) / fromIntegral yn xd = (x - 40) / fromIntegral xn - elnks = zip (map (+.+ V2 0 20) $ gridPoints 0 1 yd (yn+1)) (repeat ( pi/2)) - wlnks = zip (map (+.+ V2 x 20) $ gridPoints 0 1 yd (yn+1)) (repeat (-pi/2)) - nlnks = zip (map (+.+ V2 20 y) $ gridPoints xd (xn+1) 0 1 ) (repeat 0 ) - slnks = zip (map (+.+ V2 20 0) $ gridPoints xd (xn+1) 0 1 ) (repeat pi ) - lnks = zipWith (m North FromWest) [0..] nlnks - ++ zipWith (m East FromSouth) [0..] elnks - ++ zipWith (m West FromSouth) [0..] wlnks - ++ zipWith (m South FromWest) [0..] slnks - m edge = lnkBothAnd' (OnEdge edge) + somelnks poffset ps a = zip (map (+.+ poffset) ps) (repeat a) + elnks = somelnks (V2 0 20) (gridPoints 0 1 yd (yn+1)) ( pi/2) + wlnks = somelnks (V2 x 20) (gridPoints 0 1 yd (yn+1)) (-pi/2) + nlnks = somelnks (V2 20 y) (gridPoints xd (xn+1) 0 1 ) 0 + slnks = somelnks (V2 20 0) (gridPoints xd (xn+1) 0 1 ) pi + lnks = m North FromWest nlnks + ++ m East FromSouth elnks + ++ m West FromSouth wlnks + ++ m South FromWest slnks + m edge edgefrom = zipWith (lnkBothAnd' (OnEdge edge) edgefrom) [0..] pth = linksAndPath' lnks $ map (bimap (+.+ V2 20 20) (+.+ V2 20 20)) (makeGrid xd xn yd yn) posps = map (+.+ V2 20 20) $ gridPoints xd (xn+1) yd (yn+1) interposps = map (+.+ V2 (20 + xd/2) (20 + yd/2)) $ gridPoints xd xn yd yn diff --git a/src/Dodge/Room/RezBox.hs b/src/Dodge/Room/RezBox.hs index 4052ad304..6f95ceedd 100644 --- a/src/Dodge/Room/RezBox.hs +++ b/src/Dodge/Room/RezBox.hs @@ -40,6 +40,7 @@ rezBox ls = roomRect 40 60 1 1 & rmPmnts .~ [ sPS (V2 20 1) 0 $ PutLS ls] & restrictInLinks (\(V2 _ h,_)-> h < 1) & restrictOutLinks (\(V2 _ h,_)-> h > 59) + & rmName .~ "rezBox" rezBoxesWp :: RandomGen g => State g (SubCompTree Room) rezBoxesWp = do diff --git a/src/Dodge/Room/Start.hs b/src/Dodge/Room/Start.hs index f3ec89838..a49f69cb8 100644 --- a/src/Dodge/Room/Start.hs +++ b/src/Dodge/Room/Start.hs @@ -4,6 +4,7 @@ import Dodge.LevelGen.Data --import Dodge.PlacementSpot import Dodge.Room.RunPast import Dodge.Room.Tanks +import Dodge.Room.Containing --import Dodge.RoomLink --import Dodge.Data --import Dodge.Default @@ -56,6 +57,7 @@ startRoom i = join $ uncurry takeOneWeighted $ unzip , (,) 1 rezBoxThenWeaponRoom , (,) one rezBoxesWpCrit , (,) 1 $ runPastStart i + , (,) 5 $ startCrafts >>= roomsContaining [] >>= rezBoxThenRooms ] where one = 1::Float @@ -87,6 +89,16 @@ rezBoxThenWeaponRoom = do rcol <- rezColor treeFromTrunk [PassDown $ rezBox rcol,PassDown door] <$> weaponRoom +rezBoxThenRoom :: RandomGen g => Room -> State g (SubCompTree Room) +rezBoxThenRoom r = do + rcol <- rezColor + treeFromTrunk [PassDown $ rezBox rcol,PassDown door] <$> (return $ singleUseAll r) + +rezBoxThenRooms :: RandomGen g => SubCompTree Room -> State g (SubCompTree Room) +rezBoxThenRooms r = do + rcol <- rezColor + return . treeFromTrunk [PassDown $ rezBox rcol,PassDown door] $ r + startCrafts :: RandomGen g => State g [Item] startCrafts = takeOne $ map (map makeTypeCraft) [ [PIPE,PIPE,HARDWARE] diff --git a/src/Dodge/Room/Tanks.hs b/src/Dodge/Room/Tanks.hs index 1bd583af8..2f02b0adf 100644 --- a/src/Dodge/Room/Tanks.hs +++ b/src/Dodge/Room/Tanks.hs @@ -48,3 +48,4 @@ tanksRoom crs its = do ++ replicate ntanks thetank -- , sps0 $ PutShape $ colorSH orange $ pipePP 2 (V3 50 50 25) (V3 50 120 25) return $ room & rmPmnts .++~ plmnts + & rmName .~ "tanksRoom" diff --git a/src/Dodge/Tree/Shift.hs b/src/Dodge/Tree/Shift.hs index 864568ca9..f5e49bd7c 100644 --- a/src/Dodge/Tree/Shift.hs +++ b/src/Dodge/Tree/Shift.hs @@ -103,8 +103,11 @@ zipCount :: [a] -> [(Int,a)] zipCount = Prelude.zip [0..] printColumns :: [Int] -> [String] -> IO () -printColumns (i:is) (s:strs) = putStr (rightPad i ' ' s) >> printColumns is strs -printColumns _ strs = putStrLn $ concat strs +printColumns is ss = printPartialColumns is ss >> putStrLn "" + +printPartialColumns :: [Int] -> [String] -> IO () +printPartialColumns (i:is) (s:strs) = putStr (rightPad i ' ' s) >> printPartialColumns is strs +printPartialColumns _ strs = putStr $ concat strs theColumns :: [String] -> IO () theColumns = printColumns [20,5,20,20] @@ -112,21 +115,25 @@ theColumns = printColumns [20,5,20,20] printColumnTitles :: IO () printColumnTitles = theColumns ["Parent","Cnum","Child","Link pair"] -printInfo :: RoomInt -> Int -> RoomInt -> IO () -printInfo (parentrm,parenti) childn (childrm,childi) = do - putStr $ rpns 20 (_rmName parentrm ++ "-" ++ show parenti ) - ++ rpns 5 (show childn ++ " ") - ++ rpns 20 (_rmName childrm ++ "-" ++ show childi ) +printInfo :: (Show a) => RoomInt -> a -> RoomInt -> IO () +printInfo (parentrm,parenti) childn (childrm,childi) = printPartialColumns + [20,5,20] + [_rmName parentrm ++ "-" ++ show parenti + ,show childn ++ " " + ,_rmName childrm ++ "-" ++ show childi + ] + +printInfoCheckNum :: (Show a, Eq a, Num a) => RoomInt -> a -> RoomInt -> IO () +printInfoCheckNum (parentrm,parenti) childn (childrm,childi) = printPartialColumns + [20,5,20] + [rname + ,show childn + ,_rmName childrm ++ "-" ++ show childi + ] where - rpns x s = rightPadNoSquash x ' ' s -printInfoCheckNum :: RoomInt -> Int -> RoomInt -> IO () -printInfoCheckNum p 0 c = printInfo p 0 c -printInfoCheckNum _ childn (childrm,childi) = do - putStr $ rpns 20 "" - ++ rpns 5 (show childn ++ " ") - ++ rpns 20 (_rmName childrm ++ "-" ++ show childi ) - where - rpns x s = rightPadNoSquash x ' ' s + rname = case childn of + 0 -> _rmName parentrm ++ "-" ++ show parenti + _ -> "" doLnkEff :: (Point2,Float) -> Room -> Room doLnkEff x rm = case _rmLinkEff rm of diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 2acf212d9..b7c199d87 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -72,7 +72,7 @@ functionalUpdate cfig w = checkEndGame . updateCreatureGroups . updateBlocks . updateSeenWalls - . (lSelHammerPosition %~ moveHammerUp) + . (youHammerPosition %~ moveHammerUp) $ updateCloseObjects w where --updatedLightSources = mapMaybe (\b -> _tlsUpdate b w b) $ _tempLightSources w