Improve rooms, make consumable use type

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

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
+    hammerTest f = case _youHammerPosition w of
-        & lSelHammerPosition .~ HammerDown
+        HammerUp -> f w
-        & case _lSelHammerPosition w of
+        _ -> w
-            HammerUp -> creatures . ix (_crID cr) %~ f'
+    lhammer f' = w & case _youHammerPosition w of
-            _ -> id
+        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

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
         }

src/Dodge/Default/World.hs

@@ -89,7 +89,7 @@ defaultWorld = World
     , _maybeWorld = Nothing'
     , _rewindWorlds = []
     , _timeFlow = NormalTimeFlow
-    , _lSelHammerPosition = HammerUp
+    , _youHammerPosition = HammerUp
     , _worldTerminal = Nothing'
     }
 youLight :: TempLightSource

src/Dodge/Floor.hs

@@ -33,8 +33,8 @@ import System.Random
 
 initialAnoTree :: RandomGen g => Tree [Annotation g]
 initialAnoTree = padSucWithCorridors $ treeFromTrunk 
---    [[AnoApplyInt 0 startRoom]
+    [[AnoApplyInt 0 startRoom]
-    [[SpecificRoom startRoom']
+--    [[SpecificRoom startRoom']
 --    , [SpecificRoom $ rezThenLasTurret]
 --    , [SpecificRoom $ fmap (return . PassDown) longRoom]
     , [PassthroughLockKeyLists 2 lockRoomKeyItems itemRooms]

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 
+    , _itUse = ConsumeUse 
-        {_lUse = \cr invid w -> fromMaybe w (heal 25 (_crID cr) $ rmInvItem (_crID cr) invid w)
+        {_cUse = \_ cr w -> w & creatures . ix (_crID cr) . crHP +~ i
-        ,_useDelay = NoDelay
-        ,_useHammer = HasHammer HammerUp
         }
     , _itEquipPict = pictureItem $ (,) emptySH $ color blue $ circleSolid 3
     , _itID = Nothing

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

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

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

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 

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)) 
+    somelnks poffset ps a = zip (map (+.+ poffset) ps) (repeat a)
-    wlnks = zip (map (+.+ V2 x 20) $ gridPoints  0  1      yd (yn+1))  (repeat (-pi/2)) 
+    elnks = somelnks (V2 0 20) (gridPoints  0  1      yd (yn+1))  ( pi/2) 
-    nlnks = zip (map (+.+ V2 20 y) $ gridPoints xd (xn+1)  0  1     )  (repeat      0 ) 
+    wlnks = somelnks (V2 x 20) (gridPoints  0  1      yd (yn+1))  (-pi/2) 
-    slnks = zip (map (+.+ V2 20 0) $ gridPoints xd (xn+1)  0  1     )  (repeat     pi ) 
+    nlnks = somelnks (V2 20 y) (gridPoints xd (xn+1)  0  1     )       0  
-    lnks = zipWith (m North FromWest) [0..] nlnks 
+    slnks = somelnks (V2 20 0) (gridPoints xd (xn+1)  0  1     )      pi  
-        ++ zipWith (m East FromSouth) [0..] elnks
+    lnks = m North FromWest nlnks
-        ++ zipWith (m West FromSouth) [0..] wlnks
+        ++ m East FromSouth elnks
-        ++ zipWith (m South FromWest) [0..] slnks
+        ++ m West FromSouth wlnks
-    m edge = lnkBothAnd' (OnEdge edge)
+        ++ 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

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

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]

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"

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 is ss = printPartialColumns is ss >> putStrLn ""
-printColumns _ strs = putStrLn $ concat strs
+
+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 :: (Show a) => RoomInt -> a -> RoomInt -> IO ()
-printInfo (parentrm,parenti) childn (childrm,childi) = do
+printInfo (parentrm,parenti) childn (childrm,childi) = printPartialColumns
-    putStr $ rpns 20 (_rmName parentrm ++ "-" ++ show parenti )
+    [20,5,20]
-          ++ rpns 5  (show childn ++ " ")
+    [_rmName parentrm ++ "-" ++ show parenti 
-          ++ rpns 20 (_rmName childrm ++ "-" ++ show childi )
+    ,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
+    rname = case childn of
-printInfoCheckNum :: RoomInt -> Int -> RoomInt -> IO ()
+        0 -> _rmName parentrm ++ "-" ++ show parenti
-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
 
 doLnkEff :: (Point2,Float) -> Room -> Room
 doLnkEff x rm = case _rmLinkEff rm of

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