Refactoring, add screen when generating level

src/Dodge/Creature.hs

@@ -265,11 +265,11 @@ Items you start with.
 startInventory = IM.fromList (zip [0..20] 
     (
     [bezierGun
+    ,autoGun
     ,remoteLauncher
     ,grenade
-    --,spawnGun lamp
+    ,spawnGun lamp
     --,poisonSprayer
-    --,autoGun
     --,launcher
     --,lasGun
     --,grenade

src/Dodge/Data/Menu.hs

@@ -9,5 +9,5 @@ data MenuLayer
     | SoundOptionMenu
     | GraphicsOptionMenu
     | ControlList
-    | WaitMessage String
+    | WaitMessage String Int
   deriving (Eq,Ord)

src/Dodge/Default.hs

@@ -25,8 +25,7 @@ import qualified Data.Map as M
 import qualified Data.Set as S
 import Data.Graph.Inductive.Graph hiding ((&))
 import Data.List
-{-
+{- Indestructible wall.  -}
-Indestructible wall.  -}
 defaultWall = Wall 
     { _wlLine = [(0,0),(50,0)]
     , _wlID = 0
@@ -34,6 +33,15 @@ defaultWall = Wall
     , _wlSeen = False
     , _wlIsSeeThrough = False
     }
+{- Indestructible see-through wall.  -}
+defaultCrystalWall = Wall 
+    { _wlLine = [(0,0),(50,0)]
+    , _wlID = 0
+    , _wlColor = withAlpha 0.5 aquamarine
+    , _wlSeen = False
+    , _wlIsSeeThrough = True
+    }
+
 {-
 Door that opens on approach.
 Pathable.  -}

src/Dodge/Event/Menu.hs

@@ -65,8 +65,11 @@ handlePressedKeyInMenu mState scode w = case mState of
     pushMenu ml w   = Just $ w & menuLayers %~ (ml :)
     popMenu w       = Just $ w & menuLayers %~ tail
     sw = w & sideEffects %~ (setVol (_config w) : )
-    startNewGame = Just $ updateFramebufferSize $ generateFromList levx 
+    startNewGame = Just $ w
-        $ initialWorld 
+        & menuLayers .~ [WaitMessage "GENERATING..." 1]
+        & worldEvents .~ const aNewGame
+    aNewGame :: World
+    aNewGame = updateFramebufferSize $ generateFromList levx $ initialWorld 
         & randGen .~ _randGen w
         & config .~ _config w
 

src/Dodge/Floor.hs

@@ -15,6 +15,8 @@ import Dodge.Room.Door
 import Dodge.Room.Branch
 import Dodge.Room.Boss
 import Dodge.Room.Airlock
+import Dodge.Room.LongDoor
+import Dodge.Room.NoNeedWeapon
 import Dodge.Base
 import Dodge.Layout
 import Dodge.Layout.Tree.Polymorphic
@@ -46,12 +48,11 @@ roomTreex = do
         t = treeFromTrunk 
             [[StartRoom]
             ,[Corridor]
-            ,[BossAno $ addArmour launcherCrit & crHP +~ 800
+            ,[SpecificRoom . fmap (pure . Right) $ twinSlowDoorChasers 30]
-                & crState . crDropsOnDeath .~ DropSpecific [0] ]
             ,[Corridor]
             ,[DoorAno]
             ,[SpecificRoom $ fmap (pure . Right) 
-                $ randomiseLinksBy shuffleTail =<< centerVaultRoom 1 200 200 50]
+                $ centerVaultExplosiveExit 50]
             ,[SpecificRoom blockedCorridor]
             ,[OrAno [[DoorAno]
                     ,[Corridor]
@@ -62,7 +63,7 @@ roomTreex = do
             ,[SpecificRoom $ fmap (pure . Right) randomFourCornerRoom]
             ,[Corridor]
             ,[OrAno 
-                [[SpecificRoom $ branchRectWith $ fmap (pure . Left) armouredChasers]
+                [[SpecificRoom $ branchRectWith $ fmap (fmap Left) armouredChasers]
                 ,[BossAno $ addArmour launcherCrit & crHP +~ 800
                     & crState . crDropsOnDeath .~ DropSpecific [0] ]
                 ]

src/Dodge/Layout/Tree/Either.hs

@@ -5,6 +5,7 @@ module Dodge.Layout.Tree.Either
     ( expandTreeBy
     , appendEitherTree
     , connectRoom
+    , connectTrunk
     , deadRoom
     ) where
 import Data.Tree
@@ -40,6 +41,13 @@ Make a singleton connection of an Either Tree.
 connectRoom :: a -> Tree (Either a a)
 connectRoom r = Node (Right r) [] 
 
+{-  |
+Make a single Either connection at the end of a tree.
+-}
+connectTrunk :: Tree a -> Tree (Either a a)
+connectTrunk (Node x (t:ts)) = Node (Left x) (connectTrunk t : map (fmap Left) ts)
+connectTrunk (Node x []) = Node (Right x) []
+
 {- |
 Make a singleton dead end of an Either Tree.
 -}

src/Dodge/LevelGen.hs

@@ -88,8 +88,8 @@ placeSpot ps w = case ps of
     PS {_psPos = p, _psRot = rot, _psType = PutLineBlock wl width depth a b}
         -> putLineBlock wl width depth (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
 
-    PS {_psPos = p, _psRot = rot, _psType = PutWindow { _pwPoly = ps, _pwColor = c }}
+    PS {_psPos = p, _psRot = rot, _psType = PutWall { _pwPoly = ps, _pwWall = wl }}
-        -> rmCrossPaths $ over walls (addWindow (q:qs) c) w
+        -> rmCrossPaths $ over walls (addWalls (q:qs) wl) w
                 where (q:qs) = map (shiftPointBy (p,rot)) ps
                       rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ zip (q:qs) (qs++[q])
 
@@ -119,18 +119,17 @@ instance Shiftable PlacementSpot where
 
 shiftPointBy (pos,rot) p = pos +.+ rotateV rot p
 
-addWindow :: [Point2] -> Color -> IM.IntMap Wall -> IM.IntMap Wall
+addWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall
-addWindow qs c wls = foldr (addPane c) wls pairs
+addWalls qs wl wls = foldr (addPane wl) wls pairs
-    where (p:ps) = orderPolygon qs
+  where 
+    (p:ps) = orderPolygon qs
     pairs = zip (ps ++ [p]) (p:ps)
-addPane :: Color -> (Point2,Point2) -> IM.IntMap Wall -> IM.IntMap Wall
+addPane :: Wall -> (Point2,Point2) -> IM.IntMap Wall -> IM.IntMap Wall
-addPane c (p0,p1) wls = IM.insert (newKey wls) (Wall { _wlLine = [p0,p1]
+addPane wl (p0,p1) wls = IM.insert (newKey wls) (wl
+    { _wlLine = [p0,p1]
     , _wlID = newKey wls
-                                                     , _wlColor = c
+    })
-                                                     , _wlSeen = False 
+    wls
-                                                     , _wlIsSeeThrough = True
-                                                     }
-                                               ) wls
 
 
 placeBt bt p rot w = over buttons addBT w

src/Dodge/LevelGen/Data.hs

@@ -17,6 +17,7 @@ data PSType = PutCrit Creature
     | PutAutoDoor Point2 Point2
     | PutBlock [Int] Color [Point2]
     | PutLineBlock Wall Float Float Point2 Point2
+    | PutWall { _pwPoly :: [Point2] , _pwWall :: Wall }
     | PutDoubleDoor Color (World -> Bool) Point2 Point2
     | PutDoor Color (World -> Bool) [(Point2,Point2)]
     | PutBtDoor Color Point2 Float Point2 Point2
@@ -30,7 +31,6 @@ data PSType = PutCrit Creature
         , _collectiveFunction :: [Int] -> State StdGen [PSType]
         }
     | LabelPS { _psLabel :: Int, _ps :: PSType}
-    | PutWindow { _pwPoly :: [Point2] , _pwColor :: Color }
 data PlacementSpot = PS
     { _psPos :: Point2
     , _psRot :: Float

src/Dodge/LevelGen/LineBlock.hs

@@ -17,7 +17,14 @@ import qualified Data.IntMap as IM
 evenOddSplit = foldr f ([],[])
     where f a (ls,rs) = (rs, a : ls)
 
-putLineBlock :: Wall -> Float -> Float -> Point2 -> Point2 -> World -> World
+putLineBlock 
+    :: Wall     -- Base pane
+    -> Float    -- Block width
+    -> Float    -- Block depth
+    -> Point2   -- Start point (symmetric)
+    -> Point2   -- End point (symmetric)
+    -> World 
+    -> World
 putLineBlock basePane blockWidth depth a b w = removePathsCrossing a b $ foldr insertBlock w listBlocks
   where 
     d = dist a b

src/Dodge/Render/MenuScreen.hs

@@ -50,7 +50,7 @@ menuScreen cfig hw hh mLays = case mLays of
         ,tst (-100) 100 0.4 "CONTROLS"
         ,controlsList
         ]
-    (WaitMessage s : _) -> optionsList hw hh s []
+    (WaitMessage s _ : _) -> optionsList hw hh s []
     _ -> blank
   where 
     tst x y sc t = translate x y $ scale sc sc $ color white $ text t

src/Dodge/Room.hs

@@ -28,6 +28,7 @@ import Dodge.Room.Link
 import Dodge.Room.Branch
 import Dodge.Room.Door
 import Dodge.Room.Airlock
+import Dodge.Room.LongDoor
 import Geometry
 import Picture
 
@@ -84,22 +85,6 @@ roomPillars = over rmLinks init $ set rmPS plmnts $ roomRect 240 240 2 2
     g a b c d = f a b a b ++ f a b c d ++ f c d a b ++ f c d c d
 
 
-putBlockRect a x b y =  [ blockLine (a,b) (a,y)
-                        , blockLine (a,y) (x,y)
-                        , blockLine (x,y) (x,b)
-                        , blockLine (x,b) (a,b)
-                        ]
-putBlockV a x b y = [ blockLine (a,b) (a,y)
-                    , blockLine (x,b) (a,b)
-                    ]
-putBlockC a x b y = [ blockLine (a,b) (a,y)
-                    , blockLine (x,b) (a,b)
-                    , blockLine (a,y) (x,y)
-                    ]
-putBlockN a x b y = [ blockLine (a,b) (a,y)
-                    , blockLine (x,b) (a,b)
-                    , blockLine (x,y) (x,b)
-                    ]
 
 branchWith :: Room -> [Tree Room] -> Tree (Either Room Room)
 branchWith r ts = Node (Left r) $ [return $ Right door] ++ fmap (fmap Left) ts
@@ -134,8 +119,8 @@ glassLesson = do
                                  $ roomRect 200 200 1 1
               topRoom = set rmPS topplmnts 
                                  $ roomRect 200 200 1 1
-              botplmnts = [PS (0,0) 0 $ PutWindow (rectNSWE (200) 0 (90) (110)) 
+              botplmnts = [PS (0,0) 0 $ PutWall (rectNSWE (200) 0 (90) (110)) 
-                                      $ withAlpha 0.5 aquamarine
+                                      $ defaultCrystalWall
                           ,PS (50,100) 0 $ PutCrit miniGunCrit
                           ,PS (50,50) 0 putLamp
                           ]
@@ -275,7 +260,6 @@ randFirstWeapon = do
 --        ++ [flamer]
 
 --randC1 :: State StdGen PSType
-randC1 = RandPS $ takeOne $ map PutCrit $ (armourChaseCrit : replicate 50 chaseCrit)
 
 randC = randC1
 
@@ -396,53 +380,18 @@ roomCCrits = do
     return $ connectRoom $ over rmPS ((lamps ++) . (plmnts ++)) $ roomC 200 200
 
 
-slowDoorRoom :: RandomGen g => State g (Tree (Either Room Room))
-slowDoorRoom = do
-     x <- state $ randomR (400,800)
-     y <- state $ randomR (400,800)
-     h <- state $ randomR (200,min (y-100) 500)
-     (butPos,butRot) <- takeOne [( (x/2-50,5),0)
-                                ,( (x/2+50,5),0)
-                                ]
-     let n = 25
-     xs <- sequence $ replicate n $ state $ randomR (10,x-10)
-     ys <- sequence $ replicate n $ state $ randomR (h+20,y)
-     rs <- sequence $ replicate n $ state $ randomR (0,2*pi)
-     let ps = zip xs ys
-     xs' <- sequence $ replicate 5 $ state $ randomR (10,x-10)
-     ys' <- sequence $ replicate 5 $ state $ randomR (h+20,y)
-     let crits = zipWith (\p r -> PS p r randC1) ps rs
-         lsources = [PS (x/2,30) 0 putLamp, PS (x/2,y-30) 0 putLamp]
-     let barrels = zipWith (\x y -> PS (x,y) 0 $ PutCrit explosiveBarrel) xs' ys'
-     let pillarsa = []
-     let pillarsb = putBlockRect (x/5-20) (x/5+20) (h/2-20) (h/2+20)
-                   ++ putBlockRect (2*x/5-20) (2*x/5+20) (h/2-20) (h/2+20)
-                   ++ putBlockRect (3*x/5-20) (3*x/5+20) (h/2-20) (h/2+20)
-                   ++ putBlockRect (4*x/5-20) (4*x/5+20) (h/2-20) (h/2+20)
-     let pillarsc = putBlockRect (x/3-20) (x/3+20) (h/2-20) (h/2+20)
-                   ++ putBlockRect (2*x/3-20) (2*x/3+20) (h/2-20) (h/2+20)
-     pillars <- takeOne [pillarsa, pillarsb, pillarsc]
-     let cond x = (snd . fst) x > h + 40
-     let cond2 x = (snd . fst) x < h - 40
-     but <- takeOne [PutBtDoor (dim $ light red) butPos butRot (0,h) (x,h)
-                  --  ,PutSwitchDoor (dim $ light red) butPos butRot (0,h) (x,h)
-                    ]
-     fmap connectRoom (filterLinks cond =<< (changeLinkTo cond2
-                                             $ set rmPS ([PS (0,0) 0 but] ++ crits ++ pillars ++ barrels ++ lsources) 
-                                             $ roomRectAutoLinks x y
-                                             ))
 longRoom :: RandomGen g => State g Room
 longRoom = do
     h <- state $ randomR (1500,1500)
     let w = 75
     let cond x = (snd . fst) x < h - 40
-    let ws = map (\ps -> PS (0,0) 0 $ PutWindow ps $ withAlpha 0.5 aquamarine)
+    let ws = map (\ps -> PS (0,0) 0 $ PutWall ps defaultCrystalWall)
                     [rectNSWE (h-35) (h-135) (-10) 10
                     ,rectNSWE (h-35) (h-135) 15 35
                     ,rectNSWE (h-35) (h-135) 40 60
                     ,rectNSWE (h-35) (h-135) 65 85
                     ]
-    let wsDefense = map (\ps -> PS (0,0) 0 $ PutWindow ps $ withAlpha 0.5 aquamarine)
+    let wsDefense = map (\ps -> PS (0,0) 0 $ PutWall ps defaultCrystalWall)
                     [rectNSWE (95) (70)  0 25
                     ,rectNSWE (95) (70) 50 75
                     ]
@@ -577,8 +526,8 @@ spawnerRoom :: RandomGen g => State g (Tree (Either Room Room))
 spawnerRoom = do
     x <- state $ randomR (250,300)
     y <- state $ randomR (300,400)
-    wl <- takeOne [PS (0,0) 0 $ PutWindow (rectNSWE (y-60) 0 (x/2-10) (x/2+10)) 
+    wl <- takeOne [PS (0,0) 0 $ PutWall (rectNSWE (y-60) 0 (x/2-10) (x/2+10)) 
-                              $ withAlpha 0.5 aquamarine
+                              defaultCrystalWall
                   ,windowLine (x/2,0) (x/2,y-60)
                   ]
     let plmnts = [PS (x/4, y/4) (pi/2) $ PutCrit spawnerCrit

src/Dodge/Room/Boss.hs

@@ -5,12 +5,17 @@ module Dodge.Room.Boss
   where
 import Dodge.Data
 import Dodge.Room.Data
+import Dodge.Room.Procedural
 import Dodge.Room.Placement
+import Dodge.Room.Link
+import Dodge.Room.Corridor
 import Dodge.LevelGen.Data
 import Dodge.Creature
 import Dodge.RandomHelp
+import Dodge.Layout.Tree.Polymorphic
 import Geometry
 
+import Data.Tree
 import Control.Monad.State
 import Control.Lens
 import System.Random
@@ -21,7 +26,10 @@ roomOctogon x = Room
     { _rmPolys = [rectNSWE x (-x) (-x) x
                  ,rectNSWE 0 (-(x + 40)) (-20) 20
                  ]
-    , _rmLinks = [((0,x),0),((0,-(x+40)),pi)]
+    , _rmLinks = 
+        [((0,x),0)
+        ,((0,-(x+40)),pi)
+        ]
     , _rmPath  = [((0,x),(0,-(x+40)))
                  ,((0,-(x+40)),(0,x))]
     , _rmPS = 
@@ -41,19 +49,26 @@ roomOctogon x = Room
     fx = 4 * x / 5
 
 bossRoom :: RandomGen g => Creature -> State g Room
---bossRoom cr = pure $ roomOctogon 300 & rmPS %~ ( PS (0,100) (negate $ pi/2) (PutCrit cr) :)
+bossRoom cr = randomMediumRoom <&> rmPS %~ ( PS (0,100) (negate $ pi/2) (PutCrit cr) :)
-bossRoom cr = pure $ roomCross 200 300 & rmPS %~ ( PS (0,100) (negate $ pi/2) (PutCrit cr) :)
 
-armouredChasers :: RandomGen g => State g Room
+armouredChasers :: RandomGen g => State g (Tree Room)
 armouredChasers = do
-    ps <- takeN 5 [(x,y) | x <- [-200,-120 .. 200] ,y <- [-200,-120 .. 200] ]
+    ps <- takeN 5 [(x,y) | x <- [-100,-80 .. 100] ,y <- [-100,-80 .. 100] ]
     as <- replicateM 5 . state $ randomR (0,2*pi)
     let theCrits = zipWith3 (\p a c -> PS p a (PutCrit c)) ps as cs
-    pure $ roomOctogon 300 & rmPS %~ (++ theCrits)
+    treeFromPost [corridor,corridor] <$> (randomMediumRoom <&> rmPS %~ (++ theCrits))
   where
     cs = (armourChaseCrit & crState . crDropsOnDeath .~ DropSpecific [0]) 
             : replicate 4 chaseCrit
 
+randomMediumRoom :: RandomGen g => State g Room
+randomMediumRoom = takeOne 
+    [ roomOctogon 300
+    , roomCross 180 300
+    , roomShuriken 200 300
+    , roomTwistCross 230 300 (0)
+    ]
+
 roomCross 
     :: Float -- ^ First width/2
     -> Float -- ^ Second width/2
@@ -62,7 +77,16 @@ roomCross x y = Room
     { _rmPolys = [rectNSWE y (-y) (-x) x
                  ,rectNSWE (-x) x y (-y)
                  ]
-    , _rmLinks = [((x,y-20),negate $ pi/2)]
+    , _rmLinks = 
+        [((x,y-20),negate $ pi/2)
+        ,((x,20-y),negate $ pi/2)
+        ,((20-y,x),0)
+        ,((y-20,x),0)
+        ,((-x,y-20),pi/2)
+        ,((-x,20-y),pi/2)
+        ,((20-y,-x),pi)
+        ,((y-20,-x),pi)
+        ]
     , _rmPath  = []
     , _rmPS = 
         [PS ( x, 0) 0 putLamp
@@ -70,6 +94,52 @@ roomCross x y = Room
         ,PS ( 0, x) 0 putLamp
         ,PS ( 0,-x) 0 putLamp
         ]
-    , _rmBound = [rectNSWE x (-x) (-x) x]
+    , _rmBound = 
+        [rectNSWE y (-y) (-x) x
+        ,rectNSWE x (-x) (-y) y
+        ]
     }
-  where
+{- | TODO: pathing -}
+roomShuriken 
+    :: Float -- ^ First width/2
+    -> Float -- ^ Second width/2
+    -> Room
+roomShuriken x y = 
+    let ps = [
+            [ (0,-20)
+            , (x,-20)
+            , (x,y)
+            , (0,x)
+            ]   ]
+        corner = Room
+            { _rmPolys  = ps
+            , _rmLinks  = [((x-1,y-20),negate $ pi/2)]
+            , _rmPath   = []
+            , _rmPS     = [PS (x/2,x/2) 0 putLamp]
+            , _rmBound  = ps
+            }
+    in foldr1 combineRooms $ map (\r -> shiftRoomBy ((0,0), r) corner) [0,pi/2,pi,3*pi/2]
+{- | TODO: pathing 
+Precondition: first float is less than the second by at least 40. -}
+roomTwistCross 
+    :: Float -- ^ First width/2, 
+    -> Float -- ^ Second width/2, should be biggest
+    -> Float -- ^ Third width, should be smallest, possibly negative
+    -> Room
+roomTwistCross x y z = 
+    let ps = [  [ (x,negate $ z+20)
+                , (x,x)
+                , (z,y)
+                , (z-20,x)
+                , (z,negate $ z+20)
+                ]   
+            , rectNSWE (x-5) 0 0 (x-5)
+            ]
+        corner = Room
+            { _rmPolys  = ps
+            , _rmLinks  = [((z,y-20), pi/2)]
+            , _rmPath   = []
+            , _rmPS     = [PS (x/2,x/2) 0 putLamp]
+            , _rmBound  = ps
+            }
+    in foldr1 combineRooms $ map (\r -> shiftRoomBy ((0,0), r) corner) [0,pi/2,pi,3*pi/2]

src/Dodge/Room/Link.hs

@@ -43,13 +43,13 @@ filterLinks :: RandomGen g => ((Point2,Float) -> Bool) -> Room -> State g Room
 filterLinks cond r = do
     newLinks <- shuffle $ filter cond $ init $ _rmLinks r
     return $ r {_rmLinks = newLinks ++ [last $ _rmLinks r]}
-
+{- | Swaps the last link in the list with one that satisfies a given
+ - property (it might swap with itself). Unsafe. -}
 changeLinkTo :: RandomGen g => ((Point2,Float) -> Bool) -> Room -> State g Room
 changeLinkTo cond r = do
     l <- takeOne $ filter cond $ _rmLinks r
     let newLinks = delete l (_rmLinks r) ++ [l]
     return $ r {_rmLinks = newLinks}
-
 {- | Move a room so that the last link in '_rmLinks' lines up to 
 an external point and direction.
 This is intended to work when the external point is an outgoing link from another room.

src/Dodge/Room/LockAndKeyList.hs

@@ -14,6 +14,6 @@ lockAndKeyRoomList :: RandomGen g =>
         )                                   ]
 lockAndKeyRoomList =
     [   ( fmap (pure . Right) armouredCorridor
-        , fmap (pure . Left) armouredChasers
+        , fmap (fmap Left) armouredChasers
         )
     ]

src/Dodge/Room/LongDoor.hs

@@ -0,0 +1,112 @@
+{-# LANGUAGE TupleSections #-}
+{- | Rooms containing long doors, probably with a big reveal behind them.
+ -}
+module Dodge.Room.LongDoor
+    where
+import Dodge.Data
+import Dodge.Room.Data
+import Dodge.Room.Placement
+import Dodge.Room.Link
+import Dodge.Room.Procedural
+import Dodge.Layout.Tree.Either
+import Dodge.LevelGen.Data
+import Dodge.LevelGen.Switch
+import Dodge.RandomHelp
+import Dodge.Creature.Inanimate
+import Dodge.Creature
+import Picture
+import Geometry
+
+import System.Random
+import Control.Lens
+import Control.Monad.State
+import Data.Tree
+import qualified Data.Map as M
+
+twinSlowDoorRoom 
+    :: Int      -- ^ Door id
+    -> Float    -- ^ Half width
+    -> Float    -- ^ Half height
+    -> Float    -- ^ Inner width
+    -> Room
+twinSlowDoorRoom drID w h x = Room
+    { _rmPolys  = ps
+    , _rmLinks  =
+        [ ((w,h/2) , negate $ pi/2)
+        , ((-w,h/2) , pi/2)
+        , ((0,-h), pi)
+        ]
+    , _rmPath   = []
+    , _rmPS     = 
+        [ PS (0,h/2) 0 putLamp
+        , PS (25,5) 0 putLamp
+        , PS (negate $ 25,5) 0 putLamp
+        , PS (0,0) 0 $ PutDoor col (not . cond) drL
+        , PS (0,0) 0 $ PutDoor col (not . cond) drR
+        , PS (0,h-5) pi $ PutButton $ makeButton col 
+            (over worldState (M.insert (DoorNumOpen drID) True))
+        ]
+    , _rmBound  = ps
+    }
+  where
+    ps = 
+        [rectNSWE h (-2) (-w) w
+        ,rectNSWE 20 (-h) (negate x) x
+        ]
+    drL = fmap ((\h' -> ((x,-h'),(x,h-h'))) . (* h) . (/ fromIntegral nDrp) . fromIntegral) 
+        [0..nDrp]
+    drR = fmap ((\h' -> ((-x,-h'),(-x,h-h'))) . (* h) . (/ fromIntegral nDrp) . fromIntegral) 
+        [0..nDrp]
+    nDrp = ceiling $ h
+    cond w = or $ M.lookup (DoorNumOpen drID) (_worldState w)
+    col = dim $ dim $ bright red
+
+twinSlowDoorChasers 
+    :: RandomGen g 
+    => Int  -- ^ Door id
+    -> State g Room
+twinSlowDoorChasers drid = do
+    let lps = (-65 ,) <$> [20,40 .. 180]
+        rps = (65 ,) <$> [20,40 .. 180]
+    ps <- takeN 4 $ lps ++ rps
+    let plmnts = map (\p -> PS p 0 $ PutCrit chaseCrit) ps
+    return $ twinSlowDoorRoom drid 80 200 40 & rmPS %~ (plmnts ++)
+
+slowDoorRoom :: RandomGen g => State g (Tree (Either Room Room))
+slowDoorRoom = do
+     x <- state $ randomR (400,800)
+     y <- state $ randomR (400,800)
+     h <- state $ randomR (200,min (y-100) 500)
+     (butPos,butRot) <- takeOne 
+        [( (x/2-50,5),0)
+        ,( (x/2+50,5),0)
+        ]
+     let n = 25
+     xs <- sequence $ replicate n $ state $ randomR (10,x-10)
+     ys <- sequence $ replicate n $ state $ randomR (h+20,y)
+     rs <- sequence $ replicate n $ state $ randomR (0,2*pi)
+     let ps = zip xs ys
+     xs' <- sequence $ replicate 5 $ state $ randomR (10,x-10)
+     ys' <- sequence $ replicate 5 $ state $ randomR (h+20,y)
+     let crits = zipWith (\p r -> PS p r randC1) ps rs
+         lsources = [PS (x/2,30) 0 putLamp, PS (x/2,y-30) 0 putLamp]
+     let barrels = zipWith (\x y -> PS (x,y) 0 $ PutCrit explosiveBarrel) xs' ys'
+     let pillarsa = []
+     let pillarsb = putBlockRect (x/5-20) (x/5+20) (h/2-20) (h/2+20)
+                   ++ putBlockRect (2*x/5-20) (2*x/5+20) (h/2-20) (h/2+20)
+                   ++ putBlockRect (3*x/5-20) (3*x/5+20) (h/2-20) (h/2+20)
+                   ++ putBlockRect (4*x/5-20) (4*x/5+20) (h/2-20) (h/2+20)
+     let pillarsc = putBlockRect (x/3-20) (x/3+20) (h/2-20) (h/2+20)
+                   ++ putBlockRect (2*x/3-20) (2*x/3+20) (h/2-20) (h/2+20)
+     pillars <- takeOne [pillarsa, pillarsb, pillarsc]
+     let cond x = (snd . fst) x > h + 40
+     let cond2 x = (snd . fst) x < h - 40
+     but <- takeOne [PutBtDoor (dim $ light red) butPos butRot (0,h) (x,h)
+                  --  ,PutSwitchDoor (dim $ light red) butPos butRot (0,h) (x,h)
+                    ]
+     fmap connectRoom (filterLinks cond =<< (changeLinkTo cond2
+                                             $ set rmPS ([PS (0,0) 0 but] ++ crits ++ pillars ++ barrels ++ lsources) 
+                                             $ roomRectAutoLinks x y
+                                             ))
+
+randC1 = RandPS $ takeOne $ map PutCrit $ (armourChaseCrit : replicate 50 chaseCrit)

src/Dodge/Room/NoNeedWeapon.hs

@@ -0,0 +1,38 @@
+{- | Rooms that can be successfully tackled without having any items. -}
+module Dodge.Room.NoNeedWeapon
+    ( centerVaultExplosiveExit
+    ) where
+import Dodge.Data
+import Dodge.Creature
+import Dodge.Creature.Inanimate
+import Dodge.Room.Data
+import Dodge.Room.Procedural
+import Dodge.Room.Link
+import Dodge.RandomHelp
+import Dodge.LevelGen.Data
+
+import Control.Lens
+import Control.Monad
+import Control.Monad.State
+import System.Random
+{- |
+A room designed to be /passable/ with no weapons.
+Highlights an issue: when trying to place next door rooms, if the level generation fails it will try a different link.
+So if there are multiple such, we cannot assume that a given link will be chosen.
+To solve this, here we delete unwanted links.
+-}
+centerVaultExplosiveExit
+    :: RandomGen g 
+    => Int      -- ^ Door id
+    -> State g Room
+centerVaultExplosiveExit drID = do
+    cr <- takeOne [miniGunCrit, autoCrit]
+    let extraPS = 
+            [PS (0,175) 0 $ PutCrit explosiveBarrel
+            ,PS (5,195) 0 $ PutCrit explosiveBarrel
+            ,PS (0,200) 0 $ PutCrit explosiveBarrel
+            ,PS (-4,195) 0 $ PutCrit explosiveBarrel
+            ,PS (0,0) 0 $ PutCrit (cr & crState . crDropsOnDeath .~ DropAll)
+            ]
+    r <- centerVaultRoom drID 200 200 50 <&> rmPS %~ (extraPS ++)
+    randomiseLinksBy shuffleTail r <&> rmLinks %~ take 2

src/Dodge/Room/Placement.hs

@@ -2,6 +2,7 @@
 module Dodge.Room.Placement
   where
 import Dodge.Data
+import Dodge.Default
 import Dodge.LevelGen.Data
 import Dodge.Room.Data
 import Dodge.Creature.Inanimate
@@ -47,7 +48,7 @@ crystalLine :: Point2 -> Point2 -> PlacementSpot
 crystalLine a b = PS 
     { _psPos    = (0,0)
     , _psRot    = 0
-    , _psType   = PutWindow ps $ withAlpha 0.5 aquamarine
+    , _psType   = PutWall ps defaultCrystalWall
     }
   where
     ps = 
@@ -58,6 +59,24 @@ crystalLine a b = PS
         ]
     left = 7 *.* normalizeV (a-.-b)
     up   = vNormal left
+{- Places an unbreakable wall between two points.
+Depth 15, does not extend wider than points.
+ -}
+wallLine :: Point2 -> Point2 -> PlacementSpot
+wallLine a b = PS 
+    { _psPos    = (0,0)
+    , _psRot    = 0
+    , _psType   = PutWall ps defaultWall
+    }
+  where
+    ps = 
+        [ a  +.+ up
+        , a  -.- up
+        , b  -.- up
+        , b  +.+ up
+        ]
+    left = 15 *.* normalizeV (a-.-b)
+    up   = vNormal left
 
 windowLineType :: Point2 -> Point2 -> PSType
 windowLineType = PutLineBlock baseWindowPane 8 8
@@ -88,10 +107,7 @@ baseWindowPane = Block
     , _blShadows = []
     , _blDegrades = [5,5]
     }
-
+{- Replaces instances of a given 'PutID' with 'PSType's drawn from a list.  -}
-{-
-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
@@ -99,12 +115,9 @@ replacePutID
     -> 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 
-{-
-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.
+the new zipped list and the other (unchanged) half.  -}
--}
 subZipWith 
     :: (a -> Bool)      -- ^ Filter: elements to apply zip to
     -> (a -> b -> a)    -- ^ Combining function
@@ -116,3 +129,20 @@ subZipWith f g xs ys =
     in  zipWith g zs ys ++ ws
 
 isPutID i ps = Just i == ps ^? psType . putID
+
+putBlockRect a x b y =  [ blockLine (a,b) (a,y)
+                        , blockLine (a,y) (x,y)
+                        , blockLine (x,y) (x,b)
+                        , blockLine (x,b) (a,b)
+                        ]
+putBlockV a x b y = [ blockLine (a,b) (a,y)
+                    , blockLine (x,b) (a,b)
+                    ]
+putBlockC a x b y = [ blockLine (a,b) (a,y)
+                    , blockLine (x,b) (a,b)
+                    , blockLine (a,y) (x,y)
+                    ]
+putBlockN a x b y = [ blockLine (a,b) (a,y)
+                    , blockLine (x,b) (a,b)
+                    , blockLine (x,y) (x,b)
+                    ]

src/Dodge/Room/Procedural.hs

@@ -6,6 +6,7 @@ module Dodge.Room.Procedural
     , roomRectAutoLinks
     , randomFourCornerRoom
     , centerVaultRoom
+    , combineRooms
     ) where
 import Dodge.Data
 import Dodge.Room.Data
@@ -230,7 +231,6 @@ centerVaultRoom n w h d = do
         weDoors = rectNSWE 20 (-20) (d + 20) (negate (d +20)) 
         centerPoly = rectWdthHght (d - 20) (d - 20)
         polys = centerPoly : nsDoors : weDoors : (take 4 $ iterate (map vNormal) northPoly)
-    cr <- takeOne [miniGunCrit, autoCrit]
     return $ Room
         { _rmPolys  = polys
         , _rmLinks  = 
@@ -246,11 +246,6 @@ centerVaultRoom n w h d = do
             ,PS (w-5,5-h) 0 putLamp
             ,PS (5-w,h-5) 0 putLamp
             ,PS (5-w,5-h) 0 putLamp
-            ,PS (0,h-5) 0 $ PutCrit explosiveBarrel
-            ,PS (5,h-5) 0 $ PutCrit explosiveBarrel
-            ,PS (0,h) 0 $ PutCrit explosiveBarrel
-            ,PS (-4,h-5) 0 $ PutCrit explosiveBarrel
-            ,PS (0,0) 0 $ PutCrit (cr & crState . crDropsOnDeath .~ DropAll)
             ]
             ++ concat (zipWith (\i r -> map (shiftPSBy ((0,0),r)) $ theDoor i) 
                         [n, n+1, n+2, n+3] [0,pi/2,pi,3*pi/2])
@@ -265,3 +260,4 @@ centerVaultRoom n w h d = do
                            (over worldState (M.insert (DoorNumOpen i) False))
         ]
     cond i w = or $ M.lookup (DoorNumOpen i) (_worldState w)
+

src/Dodge/Update.hs

@@ -41,11 +41,14 @@ pushSideEffects w = w
 For most menus the only way to change the world is using event handling.  -}
 update' :: World -> World
 update' w = case _menuLayers w of
-    (WaitMessage _ : ls) -> w & menuLayers .~ ls
+    (WaitMessage s i: ls) 
+        | i < 1     -> w & doubleArgumentFor _worldEvents
+        | otherwise -> w & menuLayers %~ ( (WaitMessage s (i-1) :) . tail )
     (GameOverMenu : _) -> updateParticles 
         . updateProjectiles 
         . updateLightSources
-        $ updateClouds
+        . updateClouds
+        $ updateSoundQueue
         w
     (_ : _) -> w
     []  -> checkEndGame