Add key card item lock/key system

src/Dodge/Combine/Data.hs

@@ -111,10 +111,13 @@ data CombineType
     -- bullet
     | INCENDIARYMODULE
     | BOUNCEMODULE
-    | NoCombineType
     --
     | TELEPORTMODULE
     | TIMEMODULE
     | SIZEMODULE
     | GRAVITYMODULE
+    --
+    | KEYCARD Int
+    --
+    | NoCombineType
   deriving (Eq,Ord,Show)

src/Dodge/Creature/Impulse/UseItem.hs

@@ -15,9 +15,7 @@ useItem cr' w = fromMaybe (f w) $ do
     it <- cr ^? crInv . ix (_crInvSel cr)
     return $ itemEffect cr it w
   where
-    f = case _crID cr' of 
+    f = creatures . ix (_crID cr') . crHammerPosition .~ HammerDown
-        0 -> youHammerPosition .~ HammerDown
-        _ -> id
 
 itemEffect :: Creature -> Item -> World -> World
 itemEffect cr it w = case it ^? itUse of
@@ -30,19 +28,17 @@ itemEffect cr it w = case it ^? itUse of
     Just NoUse -> setuhamdown w
     Nothing -> setuhamdown w
   where
-    hammerTest f = case _youHammerPosition w of
+    hammerTest f = case _crHammerPosition cr of
         HammerUp -> f w
-        _ -> w & youHammerPosition .~ HammerDown
+        _ -> w & setuhamdown
-    lhammer f' = w & case _youHammerPosition w of
+    lhammer f' = w & case _crHammerPosition cr 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'
     setEquipment = toggleEquipmentAt (_crInvSel cr)
-    setuhamdown = case _crID cr of 
+    setuhamdown = creatures . ix (_crID cr) . crHammerPosition .~ HammerDown
-        0 -> youHammerPosition .~ HammerDown
-        _ -> id
 
 toggleEquipmentAt :: Int -> Creature -> Creature
 toggleEquipmentAt invid cr = cr & crInvEquipped . at invid %~ f

src/Dodge/Creature/State.hs

@@ -17,6 +17,7 @@ import Dodge.RandomHelp
 import Dodge.WorldEvent
 --import Dodge.WallCreatureCollisions
 import Dodge.Creature.Action
+--import Dodge.Hammer
 import Geometry
 import Picture
 import qualified IntMapHelp as IM
@@ -51,9 +52,10 @@ stateUpdateDamage :: (Creature -> Creature)
 --    -> CRUpdate
     -> Creature -> World -> World
 stateUpdateDamage damageupdate u cr w = case u (updateMovement cr) w of
-    (f, upcr) -> invSideEff upcr . movementSideEff cr . deathEff . f $ w
+    (f, upcr) -> mvcrhammerup . invSideEff upcr . movementSideEff cr . deathEff . f $ w
         & creatures . at (_crID cr) .~  (stepReloading . damageupdate <$> crOrCorpse upcr)
   where
+    mvcrhammerup = creatures . ix (_crID cr) . crHammerPosition %~ moveHammerUp
     crOrCorpse cr' 
         | cr' ^. crHP > 0 = Just cr'
         | otherwise      = Nothing

src/Dodge/Data.hs

@@ -126,7 +126,6 @@ data World = World
     , _rewindWorlds         :: [World]
     , _timeFlow             :: TimeFlowStatus
     , _worldClock           :: Int
-    , _youHammerPosition    :: HammerPosition
     }
 
 data HUDElement = DisplayInventory {_subInventory :: SubInventory}
@@ -287,6 +286,7 @@ data Creature = Creature
     , _crGroup          :: CrGroup
     , _crIntention      :: Intention
     , _crMvType         :: CrMvType
+    , _crHammerPosition :: HammerPosition
     }
 data Vocalization 
     = Mute

src/Dodge/Default.hs

@@ -60,6 +60,7 @@ defaultCreature = Creature
     , _crIntention = defaultIntention
     , _crGroup   = LoneWolf
     , _crMvType  = defaultAimMvType
+    , _crHammerPosition = HammerUp
     }
 defaultInanimate :: Creature
 defaultInanimate = defaultCreature & crActionPlan .~ Inanimate

src/Dodge/Default/World.hs

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

src/Dodge/Floor.hs

@@ -37,7 +37,7 @@ initialAnoTree :: RandomGen g => Tree [Annotation g]
 initialAnoTree = padSucWithDoors $ treeFromTrunk 
     [[AnoApplyInt 0 startRoom]
     , [AnoApplyInt 100 healthTest]
-    , [SpecificRoom $ return . UseAll <$> tanksRoom [] []]
+--    , [SpecificRoom $ return . UseAll <$> tanksRoom [] []]
     , [PassthroughLockKeyLists 2 lockRoomKeyItems itemRooms]
     , [SpecificRoom randomChallenges]
     , [AnoApplyInt 1 lasSensorTurretTest]

src/Dodge/Initialisation.hs

@@ -41,8 +41,9 @@ initialWorld = defaultWorld
     }
 
 testStringInit :: World -> [String]
+testStringInit = const []
 --testStringInit = map (concatMap $ \(_,ct,_,_) -> show ct) . invertListInvMult . yourInv
-testStringInit w = [show $ _youHammerPosition w]
+--testStringInit w = fmap (show . _crHammerPosition) . IM.elems $ _creatures w
 --    w = [show $ f $ _roomClipping w]
 --  where
 --    f (x:xs) = any (convexPolysOverlap x) xs || f xs

src/Dodge/Item.hs

@@ -1,43 +1,8 @@
 module Dodge.Item 
-  where
+    ( module Dodge.Item.Weapon
-import Dodge.Data
+    , module Dodge.Item.Consumable
-import Dodge.Default
+    , module Dodge.Item.PassKey
-import Picture
+    ) where
-import Geometry.Data
+import Dodge.Item.Weapon
---import ShapePicture
+import Dodge.Item.Consumable
-import Shape
+import Dodge.Item.PassKey
-
-keyToken :: Int -> Item
-keyToken n = defaultEquipment
-    { _itType = NOTDEFINED
-    , _itName = "KEYTOKEN "++show n
-    , _itEquipPict = \_ _ -> (,) emptySH $ setDepth 0 $ translate (-5) (-5) $ rotate (pi/2.5) keyPic
-    , _itEffect = NoItEffect
-    , _itID = Nothing
---    , _itZoom = defaultItZoom
-    , _itInvColor = yellow
-    , _itInvDisplay = (:[]) . _itName
-    }
-keyPic :: Picture
-keyPic = color green $
-              pictures [translate (-4) 0 $ thickCircle 4 2
-                       ,thickLine 2 $ map toV2 [(0,0),(8,0),(8,-4)]
-                       ,thickLine 2 $ map toV2 [(4,0),(4,-4)]
-                       ]
-
-latchkey :: Int -> Item
-latchkey n = defaultEquipment
-    { _itType = NOTDEFINED
-    , _itName = "KEY "++show n
-    , _itEquipPict = \_ _ -> (,) emptySH $ setDepth 0 $ translate (-5) (-5) $ rotate (pi/2.5) latchkeyPic
-    , _itEffect = NoItEffect
-    , _itID = Nothing
---    , _itZoom = defaultItZoom
-    , _itInvColor = yellow
-    }
-latchkeyPic :: Picture
-latchkeyPic = color yellow $
-              pictures [translate (-4) 0 $ thickCircle 4 2
-                       ,thickLine 2 $ map toV2 [(0,0),(8,0),(8,-4)]
-                       ,thickLine 2 $ map toV2 [(4,0),(4,-4)]
-                       ]

src/Dodge/LockAndKey.hs

@@ -7,6 +7,7 @@ import Dodge.RandomHelp
 import Dodge.Creature
 import Dodge.Item.Craftable
 import Dodge.Item.Weapon.BulletGun.Rod
+import Dodge.Item
 --import Dodge.Item.Equipment
 
 import System.Random
@@ -14,14 +15,15 @@ import Control.Monad.State
 
 lockRoomKeyItems :: RandomGen g => [ (Int -> State g (SubCompTree Room) , State g CombineType ) ]
 lockRoomKeyItems = 
-    [(lasCenSensEdge, takeOne [LAUNCHER,LASGUN,SPARKGUN,FLATSHIELD] )
+--    [(lasCenSensEdge, takeOne [LAUNCHER,LASGUN,SPARKGUN,FLATSHIELD] )
-    ,(sensorRoomRunPast Electrical, return SPARKGUN )
+--    ,(sensorRoomRunPast Electrical, return SPARKGUN )
-    ,(sensorRoomRunPast Flaming, return FLAMESPITTER )
+--    ,(sensorRoomRunPast Flaming, return FLAMESPITTER )
-    ,(sensorRoomRunPast Lasering, return LASGUN )
+--    ,(sensorRoomRunPast Lasering, return LASGUN )
-    ,(const slowDoorRoomRunPast, return MINIGUN)
+--    ,(const slowDoorRoomRunPast, return MINIGUN)
-    ,(const longRoomRunPast, takeOne [SNIPERRIFLE,FLATSHIELD])
+--    ,(const longRoomRunPast, takeOne [SNIPERRIFLE,FLATSHIELD])
-    ,(const glassLessonRunPast, takeOne [LASGUN])
+--    ,(const glassLessonRunPast, takeOne [LASGUN])
-    ,(const $ lasTunnelRunPast 400, return FLATSHIELD)
+--    ,(const $ lasTunnelRunPast 400, return FLATSHIELD)
+    [(keyCardRoomRunPast 0, return (KEYCARD 0))
     ]
 
 itemRooms :: RandomGen g => [(CombineType, State g (SubCompTree Room))]
@@ -56,6 +58,10 @@ itemRooms =
         [rc [sniperRifle]
         ]
       )
+    , (KEYCARD 0   , join $ takeOne 
+        [rc [keyCard 0]
+        ]
+      )
     ]
   where
     rc its = do

src/Dodge/Placement/Instance/Analyser.hs

@@ -115,10 +115,11 @@ analyser starts sucs fails afters upf pslight psmc = extTrigLitPos pslight $ \tp
         _ -> (fails,red)
     updatebuttontext = plType . putButton . btText .~ "ANALYSER"
 
-testYourHealth :: Int -> Machine -> World -> World
+analyserTest :: (World -> Bool) -> Machine -> World -> World
-testYourHealth hp mc w = case (_sensCloseToggle sens
+analyserTest t mc w = case 
+        (_sensCloseToggle sens
         , _sensToggle sens
-        , _crHP ycr >= hp 
+        , t w 
         , dist (_crPos ycr) (_mcPos mc) < 40) of
     (_,True,_,_) -> w
     (_,False,True,True) -> w 
@@ -133,3 +134,9 @@ testYourHealth hp mc w = case (_sensCloseToggle sens
     playsound sid = soundContinue (MachineAltSound (_mcID mc)) (_mcPos mc) sid Nothing
     ycr = you w
     sens = _mcSensor mc
+
+testYouHave :: CombineType -> Machine -> World -> World
+testYouHave ct = analyserTest (\w -> any (\itm -> _itType itm == ct) (_crInv (you w)))
+
+testYourHealth :: Int -> Machine -> World -> World
+testYourHealth hp = analyserTest (\w -> _crHP (you w) >= hp)

src/Dodge/Room/LasTurret.hs

@@ -72,6 +72,28 @@ lightSensByDoor outplid rm = rm
     covershape = rectNSEW 10 (-10) 20 (-20)
     sensorshift (p,a) = (p +.+ rotateV a (V2 60 (-20)), a)
 
+keyCardRoomRunPast :: RandomGen g => Int -> Int -> State g (SubCompTree Room)
+keyCardRoomRunPast keyid rmid = do
+    cenroom <- shuffleLinks $ keyCardAnalyserByDoor keyid rmid $ roomNgon 6 200
+    let doorroom = triggerDoorRoom rmid
+    return $ treeFromTrunk [PassDown door] $ Node (PassDown cenroom) 
+        [ treeFromPost [PassDown doorroom] (UseAll door)
+        , treeFromPost [PassDown door]     (UseLabel 0 corridor)
+        ]
+
+keyCardAnalyserByDoor :: Int -> Int -> Room -> Room
+keyCardAnalyserByDoor keyid = analyserByDoor 
+    [ bar
+    , hic
+    , bar ] 
+    "UNLOCKED" 
+    ("REQUIRES KEYCARD-"++ show keyid)
+    (bar : replicate 2 "")
+    (machineAddSound fridgeHumS $ testYouHave (KEYCARD 0))
+  where
+    hic = "HEALTH INTEGRITY CHECK"
+    bar = replicate (length hic) '-'
+
 healthAnalyserByDoor :: Int -> Room -> Room
 healthAnalyserByDoor = analyserByDoor 
     [ bar

src/Dodge/Update.hs

@@ -5,7 +5,6 @@ Description : Simulation update
 module Dodge.Update ( updateUniverse ) where
 import Dodge.Data
 import Dodge.Menu
-import Dodge.Hammer
 import Dodge.Block
 import Dodge.Distortion
 import Dodge.SoundLogic
@@ -72,7 +71,7 @@ functionalUpdate cfig w = checkEndGame
     . updateCreatureGroups
     . updateBlocks
     . updateSeenWalls 
-    . (youHammerPosition %~ moveHammerUp)
+--    . (youHammerPosition %~ moveHammerUp)
     . updateTerminal
     $ updateCloseObjects w
   where