Start to implement lock and key system

src/Dodge/AIs.hs

@@ -1515,7 +1515,7 @@ basicShooterAI w (f,g) cr =
         cid  = _crID cr
         ypos = _crPos $ you w
         wp   = _crInv cr IM.! _crInvSel cr
-        (aimtime,g1) = randomR (80,120) g
+        (aimtime,g1) = randomR (60,80) g
         noAmmo = 0 == _wpLoadedAmmo wp
         turnCloseSlow p | errorAngleVV 22 (p -.- cpos) 
                                           (unitVectorAtAngle (_crDir cr)) < 0.4

src/Dodge/Creature.hs

@@ -74,7 +74,10 @@ armourChaseCrit = defaultCreature
     , _crHP = 300
     , _crPict = enemyPict green
     , _crState = defaultState {_goals = [[Wait]]}
-    , _crInv = IM.fromList [(0,frontArmour)]
+    , _crInv = IM.fromList 
+        [(0,frontArmour)
+        ,(1,medkit 200)
+        ]
     }
 miniGunCrit :: Creature
 miniGunCrit = defaultCreature

src/Dodge/Data.hs

@@ -1,3 +1,8 @@
+{-
+Contains base datatypes that cannot be seperated into 
+different modules because they are interdependent;
+circular imports are scary.
+ -}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE StrictData #-}

src/Dodge/Floor.hs

@@ -6,10 +6,12 @@ import Picture
 import Dodge.Data
 import Dodge.Room
 import Dodge.Room.Procedural
+import Dodge.Room.RoadBlock
 import Dodge.Room.Data
 import Dodge.Room.Link
 import Dodge.Room.Door
 import Dodge.Room.Branch
+import Dodge.Room.Boss
 import Dodge.Base
 import Dodge.Layout
 import Dodge.Layout.Tree.Polymorphic
@@ -22,6 +24,7 @@ import Dodge.SoundLogic
 import Dodge.RandomHelp
 import Dodge.LightSources
 import Dodge.LevelGen.Data
+import Dodge.Item.Weapon
 
 import Data.Tree
 import Data.Maybe (fromJust,isNothing)
@@ -33,15 +36,18 @@ import System.Random
 roomTreex :: RandomGen g => State g (Maybe [Room])
 roomTreex = do
     struct' <- aTreeStrut
---    let struct = treePost [[SpecificRoom $ fmap (pure . Right) pistolerRoom]] [EndRoom]
+--    let struct = treeFromPost [[SpecificRoom $ fmap (pure . Right) pistolerRoom]] [EndRoom]
-    let struct = treePost [[SpecificRoom $ fmap (pure . Right) testRoom]] [EndRoom]
+    let struct = treeFromPost [[SpecificRoom $ fmap (pure . Right) testRoom]] [EndRoom]
     let t' = padCorridors struct
-        t = treeTrunk 
+        t = treeFromTrunk 
                 [[StartRoom]
                 ,[Corridor]
-                ,[BossAno $ addArmour launcherCrit & crHP +~ 800
+                ,[SpecificRoom $ fmap (pure . Right) armouredCorridor]
-                                                & crState . crDropsOnDeath .~ DropSpecific [0]
+                ,[Corridor]
-                   ]
+                ,[TreasureAno [addArmour autoCrit,addArmour autoCrit] [launcher]]
+--                ,[BossAno $ addArmour launcherCrit & crHP +~ 800
+--                                                & crState . crDropsOnDeath .~ DropSpecific [0]
+--                   ]
                 ,[Corridor]
                 ,[OrAno [[DoorAno]
                         ,[Corridor]
@@ -49,6 +55,7 @@ roomTreex = do
                         ]
                 ,[FirstWeapon]
                 ,[Corridor]
+                ,[SpecificRoom $ branchRectWith $ fmap (pure . Left) armouredChasers]
                 ] 
                 t'
     fmap (shiftExpandTree . expandTreeBy id) $ mapM annoToRoomTree t
@@ -60,7 +67,7 @@ lev1' :: RandomGen g => State g (Tree Room)
 lev1' = do
     firstWeapon <- takeOne $ [[branchRectWith weaponRoom,blockedCorridor]] ++ replicate 5 [weaponRoom]
     iterateWhile boundClip $ fmap (shiftRoomTree . expandTreeBy id) 
-        $ sequence $ treePost 
+        $ sequence $ treeFromPost 
         (
         [return $ return $ Right deadEndRoom
         ]

src/Dodge/Item/Weapon.hs

@@ -124,15 +124,12 @@ autoGun = defaultGun
     , _itInvDisplay = displayAutoGun
     }
 autoFireMode = shootWithSound (fromIntegral autoGunSound) 
-                   . withRecoil 40
     . torqueBefore 0.05
-                   . withRandomDir (autogunSpread/2)
+    $ autoGunNonTwistEff
-                   . withMuzFlare
-                   . withVelWthHiteff (50,0) 3 
-                   $ destroyOnImpact bulIncCr' bulIncWall' bulHitFF'
 singleFireMode = shootWithSound (fromIntegral autoGunSound) 
-                   . withRecoil 40
     . torqueAfter 0.03
+    $ autoGunNonTwistEff
+autoGunNonTwistEff = withRecoil 40
     . withRandomDir (autogunSpread/2)
     . withMuzFlare
     . withVelWthHiteff (50,0) 3 

src/Dodge/Layout/Tree/Annotate.hs

@@ -11,6 +11,7 @@ import Dodge.Room.Procedural
 import Dodge.Room.Branch
 import Dodge.Room.Door
 import Dodge.Room.Boss
+import Dodge.Room.Treasure
 import Dodge.Room.Link
 import Dodge.Room.Data
 import Dodge.Room
@@ -34,7 +35,7 @@ data Annotation g
     | OrAno [[Annotation g]]
     | SpecificRoom (State g (Tree (Either Room Room)))
     | BossAno Creature
-    | TreasureAno [Creature] Item
+    | TreasureAno [Creature] [Item]
 
 addLock :: RandomGen g => Int -> Tree [Annotation g] -> State g (Tree [Annotation g])
 addLock i t = do
@@ -49,12 +50,13 @@ randomPadCorridors :: RandomGen g => Tree [Annotation g] -> State g (Tree [Annot
 randomPadCorridors  (Node x xs) = do
     n <- state $ randomR (1, 3)
     xs' <- mapM randomPadCorridors xs
-    return $ treeTrunk (replicate n [Corridor]) (Node x xs')
+    return $ treeFromTrunk (replicate n [Corridor]) (Node x xs')
 
 roomThenCorridor :: RandomGen g => Room -> State g (Tree (Either Room Room))
 roomThenCorridor theRoom = fmap (\r -> Node (Left theRoom) [(pure . Right) r]) 
                                 (randomiseOutLinks corridor)
 
+
 annoToRoomTree :: RandomGen g => [Annotation g] -> State g (Tree (Either Room Room))
 annoToRoomTree [OrAno as] = do
     a <- takeOne as
@@ -74,6 +76,8 @@ annoToRoomTree [StartRoom] = do
     fmap (pure . Right) $ randomiseOutLinks (shiftRoomBy ((-20,-20),0) $ roomRectAutoLinks w h)
 annoToRoomTree (SpecificRoom rt:_) = rt
 annoToRoomTree (BossAno cr : _) = branchRectWith . fmap (pure . Left) $ bossRoom cr
+annoToRoomTree (TreasureAno crs loot : _) =
+    branchRectWith . fmap (pure . Left) $ lootRoom crs loot
 annoToRoomTree _ = do
     w <- state $ randomR (100,400)
     h <- state $ randomR (200,400)

src/Dodge/Layout/Tree/Polymorphic.hs

@@ -1,3 +1,12 @@
+{-
+Helpers for the manipulation of rose trees.
+Throughout, the _trunk_ refers to successive first children in the tree.
+For example, in the tree 
+
+>   Node a [ Node b [], Node c [Node d []] ]
+
+the nodes in the trunk are [a,b] (note that d is not the first child of b).
+ -}
 module Dodge.Layout.Tree.Polymorphic
     where
 import Dodge.RandomHelp
@@ -10,20 +19,20 @@ import System.Random
 Creates a linear tree.
 Safe.
 -}
-treePost :: [a] -> a -> Tree a
+treeFromPost :: [a] -> a -> Tree a
-treePost []     y = Node y []
+treeFromPost []     y = Node y []
-treePost (x:xs) y = Node x [treePost xs y]
+treeFromPost (x:xs) y = Node x [treeFromPost xs y]
 
 {-
 Creates a tree with one trunk branch, 
 input as a list, that ends in another tree.
 -}
-treeTrunk 
+treeFromTrunk 
     :: [a]      -- ^ The trunk
     -> Tree a   -- ^ The end of the tree
     -> Tree a
-treeTrunk [] t     = t
+treeFromTrunk [] t     = t
-treeTrunk (x:xs) t = Node x [treeTrunk xs t]
+treeFromTrunk (x:xs) t = Node x [treeFromTrunk xs t]
 
 {-
 Applies a function to the root of a tree.
@@ -43,6 +52,15 @@ applyToNode (i:is) f (Node x xs) = Node x (ys ++ [applyToNode is f z] ++ zs)
   where
     (ys, z:zs) = splitAt i xs
 
+{-
+Applies a function to the first node along a trunk that satisfies a given property.
+-}
+applyToSubTrunkBy :: (a -> Bool) -> (Tree a -> Tree a) -> Tree a -> Tree a
+applyToSubTrunkBy cond f (Node x (t:ts))
+    | cond x    = f (Node x (t:ts))
+    | otherwise = Node x (applyToSubTrunkBy cond f t : ts)
+applyToSubTrunkBy _ _ t = t
+
 zipTree :: Tree a -> Tree b -> Tree (a,b)
 zipTree (Node x xs) (Node y ys) = Node (x,y) $ zipWith zipTree xs ys
 
@@ -79,7 +97,7 @@ applyToRandomNode f t = do
     return $ applyToNode p f t
 
 {-
-Add a forest to the end of a tree.
+Add a forest to the end of a tree (along the trunk).
 -}
 addToTrunk :: Tree a -> [Tree a] -> Tree a
 addToTrunk (Node x []) f = Node x f

src/Dodge/LevelGen.hs

@@ -106,10 +106,6 @@ instance (Shiftable a) => Shiftable [a] where
     translateS p x = map (translateS p) x
     rotateS    r x = map (rotateS r)    x
 
-instance Shiftable RoomLink where
-    translateS q (RL p r) = RL (p +.+ q) r
-    rotateS    s (RL p r) = RL (rotateV s p) (r+s)
-
 instance Shiftable PlacementSpot where
     translateS p' (PS p r x) = PS (p +.+ p') r x
     rotateS    r' (PS p r x) = PS (rotateV r' p) (r + r') x
@@ -133,9 +129,21 @@ addPane c (p0,p1) wls = IM.insert (newKey wls) (Wall { _wlLine = [p0,p1]
 
 
 placeBt bt p rot w = over buttons addBT w
-    where addBT bts = IM.insert (newKey bts) (bt {_btPos = p, _btRot = rot, _btID = newKey bts}) bts
+  where 
-placeFlIt itm p rot w = over floorItems addFI w
+    addBT bts = IM.insert (newKey bts) (bt {_btPos = p, _btRot = rot, _btID = newKey bts}) bts
-    where addFI fis = IM.insert (newKey fis) 
+
+{-
+Creates a floor item at a given point.
+Assigns an id correctly.
+-}
+placeFlIt
+    :: Item
+    -> Point2   -- ^ Position
+    -> Float    -- ^ Rotation
+    -> World
+    -> World
+placeFlIt itm p rot = floorItems %~ 
+    \ fis -> IM.insert (newKey fis) 
         (FlIt
             { _flItPos = p
             , _flItRot = rot
@@ -143,6 +151,7 @@ placeFlIt itm p rot w = over floorItems addFI w
             , _flIt = itm
             }
         ) fis
+
 placePressPlate pp p rot w = over pressPlates addPP w
     where addPP pps = IM.insert (newKey pps) (pp {_ppPos = p,_ppRot = rot}) pps
 

src/Dodge/LevelGen/Data.hs

@@ -22,7 +22,7 @@ data PSType = PutCrit Creature
     | PutSwitchDoor Color Point2 Float Point2 Point2
     | RandPS (State StdGen PSType)
     | PutNothing
-    | PutID Int
+    | PutID { _putID :: Int}
     | CollectivePS 
         { _collectiveID  :: Int 
         , _collectiveNum :: Int 

src/Dodge/Lock.hs

@@ -0,0 +1,2 @@
+module Dodge.Lock
+    where

src/Dodge/Lock/Data.hs

@@ -0,0 +1,15 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE StrictData #-}
+module Dodge.Lock.Data
+    where
+import Dodge.Data
+import Control.Lens
+
+data Lock = Lock
+    { _lkUnlocker :: Unlocker
+    }
+
+data Unlocker
+    = ItemUnlocker Item
+
+makeLenses ''Lock

src/Dodge/Room.hs

@@ -164,12 +164,12 @@ glassSwitchBack = do
     return $ set rmPS plmnts $ roomRect wth hgt 2 6
 
 manyDoors :: Int -> Tree (Either Room Room)
-manyDoors i = treePost (replicate i (Left door)) $ Right door
+manyDoors i = treeFromPost (replicate i (Left door)) $ Right door
 
 glassLesson :: RandomGen g => State g (Tree (Either Room Room))
 glassLesson = do
     corridors <- sequence $ replicate 3 $ fmap Left $ randomiseOutLinks corridor
-    return $ Node (Left $ botRoom) [deadRoom door,uppers, treePost (Left door : corridors) $ Right door]
+    return $ Node (Left $ botRoom) [deadRoom door,uppers, treeFromPost (Left door : corridors) $ Right door]
         where uppers = Node (Left door) [deadRoom topRoom]
               botRoom = set rmPS botplmnts 
                                  $ roomRect 200 200 1 1
@@ -212,7 +212,7 @@ miniRoom1 = do
 
 miniTree2 :: RandomGen g => State g (Tree (Either Room Room))
 miniTree2 = miniRoom1 >>= randomiseOutLinks >>= changeLinkTo (\p -> (snd . fst) p < 70) 
-                         >>= return . flip branchWith (replicate 3 $ treePost [door,corridor] 
+                         >>= return . flip branchWith (replicate 3 $ treeFromPost [door,corridor] 
                                                                               critInDeadEnd   )
 
 miniRoom3 :: RandomGen g => State g (Tree (Either Room Room))
@@ -252,7 +252,7 @@ rot90Around cen p = cen +.+ vNormal (p -.- cen)
 -- So, the idea is to attach outer children to the bottommost right nodes
 -- inside an inner tree
 roomMiniIntro :: RandomGen g => State g (Tree (Either Room Room))
-roomMiniIntro = fmap (g . expandTreeBy f) $ sequence $ treePost
+roomMiniIntro = fmap (g . expandTreeBy f) $ sequence $ treeFromPost
                   [return $ connectRoom door
                   ,join $ takeOne [miniTree2,glassLesson]
 --                  ,join $ takeOne [miniRoom1]
@@ -298,22 +298,22 @@ allPairs xs = [(x,y) | x <- xs, y <- xs, x /= y]
 randomCorridorFrom :: RandomGen g => [a] -> State g (Tree (Either a a))
 randomCorridorFrom xs = do
     rooms <- sequence $ replicate 5 $ takeOne xs
-    return $ treeTrunk (map Left $ init rooms) (Node (Right (last rooms)) [])
+    return $ treeFromTrunk (map Left $ init rooms) (Node (Right (last rooms)) [])
-
 
+{-
+Probabilites of the type of the first floor weapon.
+-}
 randFirstWeapon :: State StdGen PSType
 randFirstWeapon = do
---    r <- state $ randomR (-pi,pi)
+    takeOne $ map PutFlIt $
-    takeOne $ map PutFlIt 
+        replicate 10 pistol
-                                    [  pistol
+        ++ replicate 5 ltAutoGun
-                                    ,  ltAutoGun
+        ++ replicate 5 spreadGun
---                                    ,  autoGun
+        ++ replicate 5 multGun
-                                    ,  spreadGun
+        ++ replicate 2 autoGun
-                                    ,  multGun
+        ++ [launcher]
-                                    ,  launcher
+        ++ [lasGun]
---                                    ,  lasGun
+        ++ [flamer]
---                                    ,  flamer
-                                    ]
 
 --randC1 :: State StdGen PSType
 randC1 = RandPS $ takeOne $ map PutCrit $ (armourChaseCrit : replicate 50 chaseCrit)
@@ -341,13 +341,13 @@ weaponUnderCrits = do
                    ,PS (20,0) (0-pi/2) $ randC1
                    ,PS (20,20) (0-pi/2) $ randC1
                    ]
-      let continuationRoom = treeTrunk [Left corridorN,Left corridorN] 
+      let continuationRoom = treeFromTrunk [Left corridorN,Left corridorN] 
                                        (connectRoom (set rmPS plmnts $ corridorN))
       rcp' <- roomCenterPillar
       let rcp = over rmPS ( PS (120,80) 0 putLamp : ) rcp'
       deadEndRoom <- takeOne [roomPillars,rcp]
       junctionRoom <- takeOne [Left tEast,Left tWest]
-      return $ treeTrunk [Left corridorN,Left corridorN] 
+      return $ treeFromTrunk [Left corridorN,Left corridorN] 
                          $ Node junctionRoom
                                 [continuationRoom
                                 ,deadRoom deadEndRoom
@@ -362,7 +362,7 @@ weaponBehindPillar  = do
                     ,PS crPos (d crPos) $ randC1
                     ]
       rcp <- roomCenterPillar
-      return $ treeTrunk [Left door
+      return $ treeFromTrunk [Left door
                          ,Left $ over rmLinks tail $ over rmPS (++ plmnts1) rcp]
                          (connectRoom $ set rmPS [PS (20,60) (0-pi/2) $ randC1]
                                                   $ corridorN)
@@ -389,7 +389,7 @@ blockedCorridor = do
                                           $ reverse $ rectNSWE 10 (-10) (-10) 10
                  ,PS (20,15) 0 $ putLamp
                  ]
-    sequence $ treePost (replicate n $ fmap Left $ randomiseOutLinks corridor) 
+    sequence $ treeFromPost (replicate n $ fmap Left $ randomiseOutLinks corridor) 
                         $ fmap Right $ return $ set rmPS plmnts corridor
 
 weaponLongCorridor :: RandomGen g => State g (Tree (Either Room Room))
@@ -401,8 +401,8 @@ weaponLongCorridor = do
         ]
     i1 <- state $ randomR (2,5)
     i2 <- state $ randomR (2,5)
-    let branch1 = treeTrunk (replicate i1 $ Left corridorN) (connectRoom $ putCrs connectingRoom)
+    let branch1 = treeFromTrunk (replicate i1 $ Left corridorN) (connectRoom $ putCrs connectingRoom)
-    let branch2 = treeTrunk (replicate i2 $ Left corridorN) (deadRoom $ putWp corridor)
+    let branch2 = treeFromTrunk (replicate i2 $ Left corridorN) (deadRoom $ putWp corridor)
     return $ Node (Left root) [branch1,branch2]
         where putCrs = over rmPS (++ [PS (10,40) (-pi/2) $ randC
                                  ,PS (-10,40) (-pi/2) $ randC
@@ -618,7 +618,7 @@ shootingRange = do
                         >>= filterLinks  (\((_,y),r) -> y > 200 && r /= 0)
     rm3 <- shootersRoom >>= changeLinkTo (\((x,y),_) -> y < 10 && x > 20 && x < 180)
                         >>= filterLinks  (\(_,r) -> r == 0)
-    return $ treePost [Left rm1
+    return $ treeFromPost [Left rm1
                       ,Left $ roomPadCut (rectNSWE 20 (-20) (-80) 80) (0,20)
                       ,Left rm2
                       ,Left $ roomPadCut (rectNSWE 20 (-20) (-80) 80) (0,20)
@@ -639,4 +639,4 @@ spawnerRoom = do
                  ]
     let f ((lx,_),_) = lx < x/2-5 
     roomWithSpawner <- (fmap connectRoom . randomiseOutLinks) =<< filterLinks f (set rmPS plmnts $ roomRect x y 2 2) 
-    return $ treeTrunk [Left (airlock 0)] roomWithSpawner
+    return $ treeFromTrunk [Left (airlock 0)] roomWithSpawner

src/Dodge/Room/Boss.hs

@@ -7,6 +7,8 @@ import Dodge.Data
 import Dodge.Room.Data
 import Dodge.Room.Placement
 import Dodge.LevelGen.Data
+import Dodge.Creature
+import Dodge.RandomHelp
 import Geometry
 
 import Control.Monad.State
@@ -40,3 +42,13 @@ roomOctogon x = Room
 
 bossRoom :: RandomGen g => Creature -> State g Room
 bossRoom cr = pure $ roomOctogon 300 & rmPS %~ ( PS (0,100) (negate $ pi/2) (PutCrit cr) :)
+
+armouredChasers :: RandomGen g => State g Room
+armouredChasers = do
+    ps <- takeN 5 [(x,y) | x <- [-200,-120 .. 200] ,y <- [-200,-120 .. 200] ]
+    as <- replicateM 5 . state $ randomR (0,2*pi)
+    let theCrits = zipWith3 (\p a c -> PS p a (PutCrit armourChaseCrit)) ps as cs
+    pure $ roomOctogon 300 & rmPS %~ (++ theCrits)
+  where
+    cs = (armourChaseCrit & crState . crDropsOnDeath .~ DropSpecific [0]) 
+            : replicate 4 (armourChaseCrit & crState . crDropsOnDeath .~ DropSpecific [1])

src/Dodge/Room/Branch.hs

@@ -21,7 +21,7 @@ branchRectWith t = do
     y <- state $ randomR (100,200)
     b <- t
     root <- randomiseOutLinks $ roomRectAutoLinks x y
-    return $ Node (Left root) [Node (Right door) [], fmap rToL $ treeTrunk [Left door] b]
+    return $ Node (Left root) [Node (Right door) [], fmap rToL $ treeFromTrunk [Left door] b]
         where rToL :: Either a a -> Either a a
               rToL (Right r) = Left r
               rToL (Left r)  = Left r

src/Dodge/Room/Data.hs

@@ -7,6 +7,15 @@ import Geometry
 
 import Control.Lens
 
+{- 
+The '_rmPolys' list states which polygons should be cut out to form the indestructible walls of the room.
+Link pairs contain a position and rotation to attach to another room;
+0 is for links going to another room to the north, pi/2 for links going to a room to the west, etc.
+TODO : Explain path, does it need both directions?
+Placement spots allow things to be put in the room during level generation.
+Room bounds between a new room and previously placed rooms are checked during level generation,
+assigning no bounds will allow rooms to overlap.
+ -}
 data Room = Room
     { _rmPolys  :: [ [Point2] ]
     , _rmLinks  :: [(Point2,Float)]
@@ -14,21 +23,4 @@ data Room = Room
     , _rmPS :: [PlacementSpot]
     , _rmBound :: [Point2]
     }
-data RoomLink = RL {_rlPos :: Point2, _rlRot :: Float}
-
 makeLenses ''Room
-makeLenses ''RoomLink
-
--- want to split a room into its dimensions and contents
-
-data Room' = Room'
-    { _dimensions   :: Dimensions
-    , _contents     :: [PlacementSpot]
-    }
-
-data Dimensions = Dimensions
-    { _dmPolys  :: [[Point2]]
-    , _dmLinks  :: [(Point2,Float)]
-    , _dmPath   :: [(Point2, Point2)]
-    , _dmBound  :: [Point2]
-    }

src/Dodge/Room/LockAndKeyList.hs

@@ -0,0 +1,19 @@
+module Dodge.Room.LockAndKeyList
+    where
+import Dodge.Room.Data
+import Dodge.Room.RoadBlock
+import Dodge.Room.Boss
+
+import Control.Monad.State
+import System.Random
+import Data.Tree
+
+lockAndKeyRoomList :: RandomGen g => 
+    [   (State g (Tree (Either Room Room))
+        ,State g (Tree (Either Room Room))
+        )                                   ]
+lockAndKeyRoomList =
+    [   ( fmap (pure . Right) armouredCorridor
+        , fmap (pure . Left) armouredChasers
+        )
+    ]

src/Dodge/Room/Placement.hs

@@ -3,18 +3,20 @@ module Dodge.Room.Placement
   where
 import Dodge.Data
 import Dodge.LevelGen.Data
-import Picture
+import Dodge.Room.Data
 import Dodge.Creature.Inanimate
-
+import Picture
 import Geometry
 
+import Data.List
+import Control.Lens
+
 
 putLamp = PutCrit lamp
 
 singleBlock :: Point2 -> [PlacementSpot]
 singleBlock a = [PS a 0 $ PutBlock [5,20,20] (greyN 0.5)
                                         $ reverse $ rectNSWE 10 (-10) (-10) 10]
-
 {-
 Places a line of blocks between two points.
 Width 9, also extends out from each point by 9.
@@ -88,3 +90,31 @@ baseWindowPane = Block
     , _blShadows = []
     , _blDegrades = [5,5]
     }
+
+{-
+Replaces instances of a given 'PutID' with 'PSType's drawn from a list.
+-}
+replacePutID 
+    :: Int      -- ^ The id of 'PutID' to be replaced
+    -> [PSType] -- ^ List of replacements
+    -> Room 
+    -> Room
+replacePutID i psts r =
+    r & rmPS %~ flip (subZipWith (isPutID i) (\ps pt -> ps & psType .~ pt)) psts
+
+{-
+Partition a list by a predicate, apply a zip to those elements 
+that satisfy the predicate, concatenate 
+the new zipped list and the other (unchanged) half.
+-}
+subZipWith 
+    :: (a -> Bool)      -- ^ Filter: elements to apply zip to
+    -> (a -> b -> a)    -- ^ Combining function
+    -> [a]              -- ^ List to be partition
+    -> [b]              -- ^ Modifying list
+    -> [a]
+subZipWith f g xs ys =
+    let (zs,ws) = partition f xs
+    in  zipWith g zs ys ++ ws
+
+isPutID i ps = Just i == ps ^? psType . putID

src/Dodge/Room/RoadBlock.hs

@@ -0,0 +1,48 @@
+{-
+Connecting rooms designed with a pass-through technique in mind.
+-}
+module Dodge.Room.RoadBlock
+    where
+import Geometry
+import Dodge.Room.Data
+import Dodge.Room.Link
+import Dodge.Room.Placement
+import Dodge.LevelGen.Data
+import Dodge.RandomHelp
+import Dodge.Creature
+
+import Data.Tree
+import Control.Monad.State
+import System.Random
+
+armouredCorridor :: RandomGen g => State g Room
+armouredCorridor = fmap (replacePutID 0 [PutCrit $ addArmour autoCrit]) litCorridor90
+
+{-
+A corridor of random length with a 90 degree link at the end.
+-}
+litCorridor90 :: RandomGen g => State g Room
+litCorridor90 = do
+    h <- state $ randomR (500,800)
+    let poly = rectNSWE h 0 0 40
+        poly2 = rectNSWE (h-60) (h-100) (-60) 5
+    pure $ Room
+        { _rmPolys = [poly,poly2]
+        , _rmLinks = [ ((40,h - 80), -pi/2)
+                     , ((20,     0), pi)
+                     ]
+        , _rmPath  = concatMap doublePair 
+            [((20,0),(20,h-40))
+            ,(( 0,h-40),(20,h-40))
+            ,((40,h-40),(20,h-40))
+            ]
+        , _rmPS    = 
+            [ PS (20,h-5) 0 $ putLamp
+            , windowLine (0,h-20) (40,h-20)
+            , PS (-50,h-85) 0 $ putLamp
+            , windowLine (0-40,h-60) (0-40,h-100)
+            , PS ( 20,h-40) 0 $ PutID 0
+            , PS (-20,h-80) 0 $ PutID 2
+            ]
+        , _rmBound = poly
+        }

src/Dodge/Room/Treasure.hs

@@ -5,10 +5,14 @@ Typically dead ends.
 module Dodge.Room.Treasure
     where
 import Geometry
+import Dodge.Data
 import Dodge.Room.Data
+import Dodge.Room.Placement
 import Dodge.LevelGen.Data
 
+import Data.List
 import Control.Monad.State
+import Control.Lens
 import System.Random
 
 {-
@@ -21,18 +25,24 @@ triLootRoom
     -> Float    -- Height
     -> State g Room
 triLootRoom w h = pure $ Room
-    { _rmPolys  = [poly]
+    { _rmPolys  = [ tri
-    , _rmLinks  = [((0,10),pi)]
+                  , base
-    , _rmPath   = doublePair ((0,10),(0,h/2))
+                    ]
+    , _rmLinks  = [((0,-80),pi)]
+    , _rmPath   = doublePair ((0,-80),(0,h/2))
     , _rmPS     =
         [PS (15-w,15) 0 $ PutID 0
-        ,PS (w-15,15) 0 $ PutID 0
+        ,PS (w-15,15) pi $ PutID 0
-        ,PS (0,h-15) 0   $ PutID 2
+        ,PS (0,h-35)  0 $ PutID 2
+        ,PS (-5,h-10)  0 putLamp
+        ,PS (5,h-10)  0 putLamp
+        ,PS (0,h-15)  0 putLamp
+        ,PS (0,-60)  0 putLamp
         ]
-    , _rmBound  = poly
+    , _rmBound  = convexHull $ tri ++ base
     }
   where
-    poly = 
+    tri = 
         [ ( -w,30)
         , ( -w, 0)
         , (  w, 0)
@@ -40,3 +50,10 @@ triLootRoom w h = pure $ Room
         , ( 20, h)
         , (-20, h)
         ]
+    base = rectNSWE 20 (-80) (-20) 20
+
+lootRoom :: RandomGen g => [Creature] -> [Item] -> State g Room
+lootRoom crs itms = do
+    let w = 300
+        h = 700
+    fmap (replacePutID 0 (map PutCrit crs) . replacePutID 2 (map PutFlIt itms)) $ triLootRoom w h