Cleanup

src/Dodge/Annotation.hs

@@ -20,7 +20,7 @@ annoToRoomTree an = case an of
     AnRoom r -> MTree "SingleRoom" . NodeTree . pure . (rmClusterStatus . csLinks . at OnwardCluster ?~ ())  <$> zoom _1 r <*> return []
     OnwardList ans -> do
         mts <- mapM annoToRoomTree ans
-        return $ foldr1 attachOnward mts
+        return $ foldr1 attachOnward' mts
     IntAnno f -> do 
         (g,i) <- get
         put (g,i+1)

src/Dodge/PlacementSpot.hs

@@ -9,6 +9,7 @@ module Dodge.PlacementSpot
     , unusedSpotAwayFromLink
     , isUnusedLnk
     , isInLnk
+    , isOutLnk
     , unusedSpotNearInLink
     , randDirPS
     , unusedSpotAwayFromInLink
@@ -135,6 +136,10 @@ isInLnk :: RoomPos -> Bool
 isInLnk rp = case _rpLinkStatus rp of
     UsedInLink {} -> _rpPlacementUse rp == 0
     _ -> False
+isOutLnk :: RoomPos -> Bool
+isOutLnk rp = case _rpLinkStatus rp of
+    UsedOutLink {} -> _rpPlacementUse rp == 0
+    _ -> False
 
 useUnusedLnk :: PlacementSpot
 useUnusedLnk = rprBool isUnusedLnk

src/Dodge/Room/Modify/Girder.hs

@@ -2,6 +2,7 @@ module Dodge.Room.Modify.Girder
     ( addGirderLights
     , addGirderFrom
     , addHighGirder
+    , addHighGirder'
     , addGirderEW
     , addGirderNS
     , addGirderNS'
@@ -88,6 +89,22 @@ addGirder shapef col room = do
             $ \ps1 ps2 -> sps0 $ PutShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) 
             | i <- [1 .. numlnks - 2] ]
 
+addGirder' :: RandomGen g => (Point2 -> Point2 -> Shape) -> Color -> Room -> State g Room
+addGirder' shapef col room = do
+    let nslnks = length $ filter ((OnEdge North `S.member`) . _rlType) $ _rmLinks room
+        ewlnks = length $ filter ((OnEdge East `S.member`) . _rlType) $ _rmLinks room
+        nsgirds = girdson (FromEdge East) nslnks
+        ewgirds = girdson (FromEdge North) ewlnks
+    girders <- shuffle $ nsgirds ++ ewgirds
+    return $ room & rmPmnts .:~ foldr1 setFallback 
+        (sps0 PutNothing : girders)
+  where
+    girdson f numlnks = [ twoRoomPoss
+            (isUnusedLnkType (f i))
+            (isUnusedLnkType (f i))
+            $ \ps1 ps2 -> sps0 $ PutShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) 
+            | i <- [0 .. numlnks - 1] ]
+
 addHighGirder :: RandomGen g => Room -> State g Room
 addHighGirder r = do
     gsize <- takeOne [(20,10),(30,10),(40,10),(30,15)]
@@ -95,6 +112,13 @@ addHighGirder r = do
             [girder, girderZ, girderV]
     addGirder hgshape black r
 
+addHighGirder' :: RandomGen g => Room -> State g Room
+addHighGirder' r = do
+    gsize <- takeOne [(20,10),(30,10),(40,10),(30,15)]
+    hgshape <- takeOne $ map (\f -> uncurry (f 96) gsize)
+            [girder, girderZ, girderV]
+    addGirder' hgshape black r
+
 randomLightPositions :: RandomGen g => Room -> State g [(Int,Int)]
 randomLightPositions rm = do
     let rmtype = _rmType rm

src/Dodge/Room/Pillar.hs

@@ -1,5 +1,6 @@
 module Dodge.Room.Pillar where
 import Dodge.Data
+import Dodge.UseAll
 import Dodge.PlacementSpot
 import Dodge.Room.Modify.Girder
 import Dodge.LevelGen.Data
@@ -45,6 +46,7 @@ roomPillars pillarsize w h wn hn = do
                               && _rpLinkStatus rp == NotLink )
                 )
     addGirderLights $ rm 
+        & cleatSide
         & rmPmnts .~ plmnts
         & rmName .~ "rectPillars"
   where 

src/Dodge/Room/RezBox.hs

@@ -40,6 +40,18 @@ rezBox ls = roomRect 40 60 1 1
     & restrictOutLinks (\(V2 _ h,_)-> h > 59)
     & rmName .~ "rezBox"
 
+rezBox' :: RandomGen g => State g (MetaTree Room String)
+rezBox' = do
+    col <- rezColor
+    return $ tToBTree "rezBox'" $ treePost
+        [roomRect 40 60 1 1 
+            & rmPmnts .~ [ sPS (V2 20 1) 0 $ PutLS col]
+            & restrictInLinks  (\(V2 _ h,_)-> h < 1)
+            & restrictOutLinks (\(V2 _ h,_)-> h > 59)
+            & rmName .~ "rezBox"
+        , cleatOnward door
+        ]
+
 rezBoxesWp :: RandomGen g => State g (Tree Room)
 rezBoxesWp = do
     w <- state $ randomR (100,400)
@@ -50,7 +62,7 @@ rezBoxesWp = do
     let isnorth = S.member (OnEdge North) . _rlType
     centralRoom <- shuffleLinks $(roomRectAutoLinks w h) {_rmPmnts = []} 
         & rmLinks %~ setLinkType InLink isnorth
-    onwardpassage <- maybeBlockedPassage
+    onwardpassage <- shootOutPassage
     let n = length $ getLinksOfType (OnEdge North) $  _rmLinks centralRoom
     let rezrooms = map adddoor 
             $ wpAdd theweapon aroom : replicate (n-2) aroom
@@ -62,6 +74,10 @@ rezBoxesWp = do
 maybeBlockedPassage :: RandomGen g => State g (Tree Room)
 maybeBlockedPassage = fmap (pure . cleatOnward)
     $ join $ takeOne [return corridor, blockedCorridorCloseBlocks]
+
+shootOutPassage :: RandomGen g => State g (Tree Room)
+shootOutPassage = fmap (pure . cleatOnward)
+    $ join $ takeOne [ blockedCorridorCloseBlocks]
 rezBoxesWpCrit :: RandomGen g => State g (Tree Room)
 rezBoxesWpCrit = do
     w <- state $ randomR (200,400)
@@ -88,7 +104,7 @@ rezBoxesWpCrit = do
 crAdd :: Room -> Room
 crAdd = rmPmnts .:~ sPS (V2 20 10) (0.5*pi) randC1
 
-rezBoxes :: RandomGen g => State g (Tree Room)
+rezBoxes :: RandomGen g => State g (MetaTree Room String)
 rezBoxes = do
     w <- state $ randomR (100,400)
     h <- state $ randomR (40,40)
@@ -99,7 +115,7 @@ rezBoxes = do
     centralRoom <- shuffleLinks $ (roomRectAutoLinks w h) {_rmPmnts = []}
             & rmLinks %~ setInLinks bottomEdgeTest
     let n = length $ filter bottomEdgeTest $_rmLinks centralRoom
-    return $ treeFromTrunk [rezBox thecol,  door] 
+    return $ tToBTree "rezBoxes" $ treeFromTrunk [rezBox thecol,  door] 
         $ Node centralRoom (replicate (n-1) dbox ++ [Node (cleatOnward door) []])
 
 rezColor :: RandomGen g => State g LightSource

src/Dodge/Room/RoadBlock.hs

@@ -72,16 +72,17 @@ dirtPoly = PutBlock DirtBlock 1 [] dirtWall . reverse
 blockedCorridorCloseBlocks :: RandomGen g => State g Room
 blockedCorridorCloseBlocks = do
     r <- state $ randomR (0,pi)
+    r' <- state $ randomR (0,pi)
     theblocks <- takeOne 
-        [  -- [sPS (V2 20 40) r $ dirtPoly $ square 10]
+        [   [sPS (V2 20 40) r $ dirtPoly $ square 8]
         --,   [ sPS (V2 5 40) r $ dirtPoly $ square 10
         --    , sPS (V2 35 40) (r+0.5) $ dirtPoly $ square 10
         --    ]
         --,   
           --[ sPS (V2 5 50) r $ dirtPoly $ square 10
           --, sPS (V2 35 35) (r+0.5) $ dirtPoly $ square 10
-            [ sPS (V2  6 25) r $ dirtPoly $ square 10
+        ,   [ sPS (V2  6 25) r  $ dirtPoly $ square 8
-            , sPS (V2 35 20) (r+0.5) $ dirtPoly $ square 10
+            , sPS (V2 35 20) r' $ dirtPoly $ square 8
             ]
         ]
     return $ corridor & rmPmnts .~ theblocks

src/Dodge/Room/Room.hs

@@ -13,7 +13,7 @@ import Dodge.Data
 import Dodge.PlacementSpot
 import Dodge.RoomLink
 import Dodge.Default.Room
-import Dodge.Item.Weapon.BulletGuns
+import Dodge.Item.Weapon
 import Dodge.Creature
 import Dodge.Room.Pillar
 import Dodge.Room.Girder
@@ -118,17 +118,20 @@ roomMiniIntro = do
     rToOnward "roomMiniIntro" midroom
 
 roomCenterPillar :: RandomGen g => State g Room
-roomCenterPillar = shuffleLinks . restrictInLinks ((\p -> dist p (V2 120 0) < 10) . fst) 
+roomCenterPillar = do
+    addHighGirder' =<< (shuffleLinks . restrictInLinks ((\p -> dist p (V2 120 0) < 10) . fst) 
+        $ cleatSide
         $ set rmPmnts plmnts 
         $ set rmName "roomCenterPillar"
         $ roomRect 240 240 2 2
+        )
   where 
     plmnts = 
         [ blockLine (V2 115 115) (V2 115 125)
         , blockLine (V2 125 115) (V2 125 125)
-        , mntLightLnkCond useUnusedLnk
+--        , mntLightLnkCond useUnusedLnk
-        , mntLightLnkCond useUnusedLnk
         , mntLightLnkCond (resetPLUse $ rprBool $ \rp _ -> isInLnk rp)       
+        , mntLightLnkCond (resetPLUse $ rprBool $ \rp _ -> isOutLnk rp)       
         ]
 
 {- Probabilites of the type of the first floor weapon.  -}
@@ -137,6 +140,8 @@ randFirstWeapon = takeOne $ map PutFlIt $
     replicate 10 pistol
     ++ replicate 5 (bangStick 4)
     ++ replicate 5 (bangCaneX 3)
+    ++ replicate 5 bangCone
+    ++ [lasGun]
 
 weaponEmptyRoom :: RandomGen g => State g (Tree Room)
 weaponEmptyRoom = do
@@ -151,7 +156,7 @@ weaponEmptyRoom = do
         f (V2 x y,a) = (a == pi && x > 25 && x < w - 25) || (a /= 0 && y > w - 30)
     rm <- addHighGirder >=> shuffleLinks 
         $ restrictRMInLinksPD f (roomRect w h 2 2 & rmPmnts .~ plmnts)
-    return $ treeFromTrunk [ corridor] (pure $ cleatOnward rm )
+    return $ treePost [ corridor, cleatSide $ cleatOnward rm ]
      
 weaponUnderCrits :: RandomGen g => Int -> State g (MetaTree Room String)
 weaponUnderCrits i = do
@@ -166,7 +171,7 @@ weaponUnderCrits i = do
             ]
     rcp <- roomCenterPillar
     rmpils <- roomPillars 30 240 240 2 2
-    deadEndRoom' <- takeOne [ addwpat (V2 120 20) rmpils , addwpat (V2 120 20) rcp]
+    deadEndRoom' <- takeOne [ addwpat (V2 120 20) rmpils , addwpat (V2 120 20) $ cleatSide rcp]
     junctionRoom <- takeOne [ tEast, tWest]
     rToOnward "weaponUnderCrits" $ treeFromTrunk [ corridorN , corridorN] 
         $ Node junctionRoom [continuationRoom ,pure deadEndRoom' ]
@@ -177,14 +182,14 @@ weaponBehindPillar  = do
     wpos <- takeOne [V2 120 160,V2 80 40,V2 160 40,V2 220 200,V2 40 200,V2 120 35]
     cpos <- takeOne $ [V2 x y | x <- [20,220], y <- [20,40]] ++ [V2 120 160,V2 120 200]
     rcp <- roomCenterPillar
-    return $ treeFromTrunk 
+    return $ treePost 
         [ corridor
         , rcp & rmPmnts ++.~
             [sPS wpos wpa $ RandPS randFirstWeapon
             ,sPS cpos (argV $ V2 120 80 -.- cpos) randC1
             ]
+        , cleatOnward $ set rmPmnts [sPS (V2 20 60) (negate $ pi/2) randC1] corridorN
         ]
-        (pure . cleatOnward $ set rmPmnts [sPS (V2 20 60) (negate $ pi/2) randC1] corridorN)
 
 weaponBetweenPillars :: RandomGen g => State g (Tree Room)
 weaponBetweenPillars = do
@@ -211,12 +216,13 @@ weaponLongCorridor = do
     connectingRoom <- takeOne [tEast  & rmPmnts .~ [spanLightI (V2 (-30) 40) (V2 (-30) 80)] ]
     i1 <- state $ randomR (2,5)
     i2 <- state $ randomR (2,5)
-    let branch1 = treeFromTrunk (replicate i1 corridorN) (pure . cleatOnward  $ putCrs connectingRoom)
+    let branch1 = treeFromTrunk (replicate i1 corridorN) 
+            (pure . cleatSide . cleatOnward  $ putCrs connectingRoom)
     let branch2 = treeFromTrunk (replicate i2 corridorN) (pure . cleatSide    $ putWp corridor)
     return $ Node rt [branch1,branch2]
   where 
-    putCrs = over rmPmnts (++ [sPS (V2 10 40) (-pi/2) randC1 ,sPS (V2 (-10) 40) (-pi/2) randC1 ])
+    putCrs = rmPmnts .++~ [sPS (V2 10 40) (-pi/2) randC1 ,sPS (V2 (-10) 40) (-pi/2) randC1 ]
-    putWp = set rmPmnts [sPS (V2 20 60) 0 $ RandPS randFirstWeapon ,spanLightI (V2 0 40) (V2 40 40)]
+    putWp  = rmPmnts .~ [sPS (V2 20 60) 0 $ RandPS randFirstWeapon ,spanLightI (V2 0 40) (V2 40 40)]
 
 critInDeadEnd :: Room
 critInDeadEnd = deadEndRoom & rmPmnts .~ [sPS (V2 0 0) 0 randC1]

src/Dodge/Room/Start.hs

@@ -1,5 +1,8 @@
 {-# LANGUAGE TupleSections #-}
-module Dodge.Room.Start where
+module Dodge.Room.Start 
+    ( startRoom
+    , randomChallenges
+    ) where
 import Dodge.UseAll
 import Dodge.Data
 import Dodge.LevelGen.Data
@@ -54,11 +57,12 @@ startRoom i = join (takeOne
      --       <&> (,TreeSubLabelling "chainUses <$> sequence [powerFakeout,weaponRoom i]" Nothing))
      --     wat
      -- rezBoxesWp                >>= rToOnward "rezBoxesWp"
---    , rezBoxThenWeaponRoom i
+    attachOnward "rezBoxThenWeaponRoom" <$> preCritStart <*> weaponRoom i
---    , rezBoxesWpCrit            >>= rToOnward "rezBoxesWpCrit"
+--     startThenWeaponRoom i
-     runPastStart i             >>= rToOnward ("runPastStart " ++ show i)
+--     rezBoxesWpCrit            >>= rToOnward "rezBoxesWpCrit"
---    , startCrafts >>= roomsContaining' [] >>= rezBoxThenRooms
+--     runPastStart i             >>= rToOnward ("runPastStart " ++ show i)
---        >>= rToOnward "startCrafts >>= roomsContaining [] >>= rezBoxThenRooms"
+--     startCrafts >>= roomsContaining' [] >>= preCritStart
+--        >>= rToOnward "startCrafts >>= roomsContaining [] >>= preCritStart"
     ])
 randomChallenges :: RandomGen g => State g (MetaTree Room String)
 randomChallenges = shootingRange
@@ -84,18 +88,21 @@ rezBoxesThenWeaponRoom :: RandomGen g => Int -> State g (MetaTree Room String)
 rezBoxesThenWeaponRoom i = do
     rboxes <- rezBoxes
     wroom  <- weaponRoom i
-    return $ tToBTree "rboxes" rboxes `attachOnward` wroom
+    return $ attachOnward "rezBoxesThenWeaponRoom" rboxes wroom
 
-rezBoxThenWeaponRoom :: RandomGen g => Int -> State g (MetaTree Room String)
+preCritStart :: RandomGen g => State g (MetaTree Room String)
-rezBoxThenWeaponRoom i = do
+preCritStart = join $ takeOne [rezBoxes,rezBox']
-    rcol <- rezColor
+
+startThenWeaponRoom :: RandomGen g => Int -> State g (MetaTree Room String)
+startThenWeaponRoom i = do
+    startrm <- preCritStart
     wroom <- weaponRoom i
-    return $ tToBTree "rezbox" (treePost [rezBox rcol, cleatOnward door]) `attachOnward` wroom
+    return $ attachOnward "rezBoxThenWeaponRoom" startrm wroom
 
 rezBoxThenRoom :: RandomGen g => Room -> State g (Tree Room)
 rezBoxThenRoom r = do
     rcol <- rezColor
-    return $ treeFromTrunk [ rezBox rcol, door] $ pure r
+    return $ treeFromTrunk [ rezBox rcol, cleatOnward door] $ pure r
 
 rezBoxThenRooms :: RandomGen g => Tree Room -> State g (Tree Room)
 rezBoxThenRooms r = do

src/Dodge/Room/Warning.hs

@@ -11,6 +11,7 @@ import Dodge.Tree
 import Dodge.Room.Door
 import Dodge.Room.Ngon
 import Dodge.Room.Procedural
+import Dodge.Room.Tanks
 --import Dodge.Room.Corridor
 import Dodge.Room.Link
 --import Dodge.Room.Procedural
@@ -39,7 +40,9 @@ import qualified Data.Map.Strict as M
 
 warningRooms :: RandomGen g => Int -> State g (MetaTree Room String)
 warningRooms n = do
-    rm <- takeOne [roomNgon 8 200, roomRectAutoLinks 200 200]
+    rm <- do
+        tr <- tanksRoom [] []
+        takeOne [roomNgon 8 200, roomRectAutoLinks 200 200,tr]
     cenroom <- shuffleLinks $ addWarningTerminal n rm
     rToOnward "warningRooms" $ treePost [ door, cenroom, triggerDoorRoom n, cleatOnward door]
 

src/Dodge/Tree/Compose.hs

@@ -13,6 +13,7 @@ module Dodge.Tree.Compose
     , attachTree
     , toOnward
     , attachOnward
+    , attachOnward'
     , showIntsString
     , module Dodge.Tree.Compose.Data
     ) where
@@ -90,8 +91,11 @@ attachBranch mb = safeUpdateSingleNode (isJust . upf . snd)
 tToBTree :: String -> Tree Room -> MetaTree Room String
 tToBTree str t = MTree str (NodeTree t) []
 
-attachOnward :: MetaTree Room b -> MetaTree Room b -> MetaTree Room b
+attachOnward :: b -> MetaTree Room b -> MetaTree Room b -> MetaTree Room b
-attachOnward t1 t2 = t1 & mtBranches .:~ MBranch toOnward t2
+attachOnward s t1 t2 = MTree s (NodeMTree t1) [MBranch toOnward t2]
+
+attachOnward' :: MetaTree Room b -> MetaTree Room b -> MetaTree Room b
+attachOnward' t1 t2 = MTree (_mtLabel t1) (NodeMTree t1) [MBranch toOnward t2]
 
 toOnward :: Room -> Maybe Room
 toOnward rm

src/Dodge/UseAll.hs

@@ -25,7 +25,7 @@ cleatOnward :: Room -> Room
 cleatOnward = rmClusterStatus . csLinks .~ S.singleton OnwardCluster
 
 cleatSide :: Room -> Room
-cleatSide = rmClusterStatus . csLinks .~ S.singleton SideCluster
+cleatSide = rmClusterStatus . csLinks . at SideCluster ?~ ()
 
 cleatLabel :: Int -> Room -> Room
 cleatLabel i = rmClusterStatus . csLinks .~ S.singleton (LabelCluster i)