Cleanup

src/Dodge/Annotation.hs

@@ -48,11 +48,6 @@ randomPadCorridors  (Node x xs) = do
     n <- state $ randomR (1, 3)
     xs' <- mapM randomPadCorridors xs
     return $ treeFromTrunk (replicate n [Corridor]) (Node x xs')
-{- | Add a corridor to a random out-link of a room.  -}
-roomThenCorridor :: RandomGen g => Room -> State g (Tree Room)
-roomThenCorridor theRoom = fmap 
-    (\r -> Node ( theRoom) [(pure . useAll) r]) 
-    (shuffleLinks corridor)
 
 {- | Create a random room tree structure from a list of annotations.  -}
 anoToRoomTree :: [Annotation] -> State StdGen (Room -> Maybe ([String],Room), Tree Room)
@@ -67,10 +62,8 @@ anoToRoomTree anos = case anos of
         let lr = snd lr'
         keyroom' <- fromJust $ lookup ii ks
         let keyroom = snd keyroom'
-        return (toOnward ("PassthroughLockKeyLists-"++show ii)
+        rToOnward ("PassthroughLockKeyLists-"++show ii) $ overwriteLabel i lr [keyroom]
-            , overwriteLabel 0 lr [keyroom]
+    _ -> rToOnward "no label" =<< anoToRoomTree' anos
-                )
-    _ -> (toOnward "no label" ,) <$> anoToRoomTree' anos
 
 {- | Create a random room tree structure from a list of annotations.  -}
 anoToRoomTree' :: [Annotation] -> State StdGen (Tree Room)

src/Dodge/LevelGen.hs

@@ -43,7 +43,7 @@ layoutLevelFromSeed i seed = do
     --putStrLn "Room cluster layout:"
     --putStrLn $ drawTreeSubLabelling $ fmap snd treecluster
     --let rmtree = inorderNumberTree $ expandTree $ fmap fst treecluster
-    let rmtree = inorderNumberTree $ tc
+    let rmtree = inorderNumberTree tc
     putStrLn "Room layout (compact): "
     putStrLn $ compactDrawTree $ fmap (show . snd) rmtree
     let nameshow (r,rid) = _rmName r ++ "-" ++ show rid

src/Dodge/LockAndKey.hs

@@ -115,7 +115,5 @@ someCrits = do
 corridorBoss :: RandomGen g => Creature -> State g (LabTree Room)
 corridorBoss cr = do
     endroom <- bossRoom cr
-    return ( toOnward ("corridorBoss-"++_crName cr)
+    rToOnward ("corridorBoss-"++_crName cr)
-        , treeFromPost (replicate 5 $  corridor) ( endroom)
+        $ treeFromPost (replicate 5 corridor) endroom
-        )
-

src/Dodge/Room/Branch.hs

@@ -22,7 +22,7 @@ branchRectWith t = do
     y <- state $ randomR (100,200)
     b <- t
     rt <- shuffleLinks $ roomRectAutoLinks x y
-    return $ Node ( rt) 
+    return $ Node rt 
         [ Node (useAll door) []
-        , useSide <$> treeFromTrunk [ door] b
+        , treeFromTrunk [door] b
         ]

src/Dodge/Room/LasTurret.hs

@@ -76,9 +76,9 @@ keyCardRoomRunPast keyid rmid = do
     cenroom <- shuffleLinks $ keyCardAnalyserByDoor keyid rmid $ roomNgon 6 200
     let doorroom = triggerDoorRoom rmid
     return (toOnward "keyCardRoomRunPast",
-        treeFromTrunk [door] $ Node (cenroom) 
+        treeFromTrunk [door] $ Node cenroom
         [ treeFromPost [doorroom] (useAll door)
-        , treeFromPost [door]     (useLabel 0 corridor)
+        , treeFromPost [door]     (useLabel rmid corridor)
         ])
 
 keyCardAnalyserByDoor :: Int -> Int -> Room -> Room
@@ -124,12 +124,11 @@ lasCenSensEdge :: RandomGen g => Int -> State g (LabTree Room)
 lasCenSensEdge n = do
     cenroom <- shuffleLinks $ lightSensByDoor n cenLasTur
     let doorroom = triggerDoorRoom n
-    return (toOnward "lasCenSensEdge"
+    rToOnward "lasCenSensEdge"
-        , treeFromTrunk [ door] $ Node ( cenroom) 
+        $ treeFromTrunk [ door] $ Node cenroom
         [ treeFromPost [ doorroom] (useAll door)
         , treeFromPost [ door]     (useLabel 0 corridor)
         ]
-        )
 
 lasTunnel :: RandomGen g => Float -> State g Room
 lasTunnel y = do
@@ -171,9 +170,7 @@ lasTunnelRunPast y = do
     r <- lasTunnel y
     r1 <- takeOne [door,corridor]
     r2 <- takeOne [door,corridor]
-    return (toOnward "lasTunnelRunPast"
+    rToOnward "lasTunnelRunPast" $ Node r
-        , Node ( r)
         [ pure $ useAll r1
         , return (useLabel 0 $ r2 & rmConnectsTo .~ S.member InLink)
         ]
-        )

src/Dodge/Room/LongDoor.hs

@@ -143,9 +143,7 @@ slowDoorRoom = do
 slowDoorRoomRunPast :: RandomGen g => State g (LabTree Room)
 slowDoorRoomRunPast = do
     r <- slowDoorRoom
-    return ( toOnward "slowDoorRoomRunPast"
+    rToOnward "slowDoorRoomRunPast" $ treeFromTrunk [ door] $ Node r
-        , treeFromTrunk [ door] $ Node ( r)
         [ pure $ useAll door
         , return (useLabel 0 $ door & rmConnectsTo .~ S.member InLink)
         ] 
-        )

src/Dodge/Room/LongRoom.hs

@@ -50,12 +50,9 @@ longRoom = do
 longRoomRunPast :: RandomGen g => State g (LabTree Room)
 longRoomRunPast = do
     r <- longRoom
-    return (toOnward "longRoomRunPast"
+    rToOnward "longRoomRunPast"
-        , treeFromTrunk [ door]
+        $ treeFromTrunk [ door] $ Node r
-        (Node ( r)
+            [ pure $ useAll door
-            [ pure door
             , treeFromPost [ corridor & rmConnectsTo .~ S.member InLink] 
                 (useLabel 0 door)
             ]
-        )
-        )

src/Dodge/Room/RezBox.hs

@@ -54,12 +54,10 @@ rezBoxesWp = do
     let n = length $ getLinksOfType (OnEdge North) $  _rmLinks centralRoom
     let rezrooms = map adddoor 
             $ wpAdd theweapon aroom : replicate (n-2) aroom
-    return $ treeFromTrunk [ rezBox thecol
+    return $ treeFromTrunk [ rezBox thecol ,  door ]
-        ,  door
+        $ Node centralRoom (rezrooms ++ [onwardpassage])
-        ] 
-        (Node ( centralRoom) (rezrooms ++ [onwardpassage]))
   where
-    adddoor rm = treeFromPost [ connectsToNorth door ] ( rm)
+    adddoor rm = treeFromPost [ connectsToNorth door ] rm
     connectsToNorth = rmConnectsTo .~ S.member (OnEdge North)
 maybeBlockedPassage :: RandomGen g => State g (Tree Room)
 maybeBlockedPassage = fmap (pure . useAll)
@@ -82,12 +80,10 @@ rezBoxesWpCrit = do
             $ insertAt i (wpAdd theweapon aroom) 
             $ insertAt j (crAdd aroom)
             $ replicate (n-3) aroom
-    return $ treeFromTrunk [ rezBox thecol
+    return $ treeFromTrunk [rezBox thecol , door]
-        ,  door
+        $ Node centralRoom (rezrooms ++ [onwardpassage])
-        ]
-        (Node ( centralRoom) (rezrooms ++ [onwardpassage]))
   where
-    adddoor rm = treeFromPost [ door & rmConnectsTo .~ S.member (OnEdge North)] ( rm)
+    adddoor rm = treeFromPost [ door & rmConnectsTo .~ S.member (OnEdge North)] rm
 
 crAdd :: Room -> Room
 crAdd = rmPmnts .:~ sPS (V2 20 10) (0.5*pi) randC1
@@ -103,10 +99,8 @@ rezBoxes = do
     centralRoom <- shuffleLinks $ (roomRectAutoLinks w h) {_rmPmnts = []}
             & rmLinks %~ setInLinks bottomEdgeTest
     let n = length $ filter bottomEdgeTest $_rmLinks centralRoom
-    return $ treeFromTrunk [ rezBox thecol
+    return $ treeFromTrunk [rezBox thecol,  door] 
-        ,  door
+        $ Node centralRoom (replicate (n-1) dbox ++ [Node (useAll door) []])
-        ] 
-        (Node ( centralRoom) (replicate (n-1) dbox ++ [Node (useAll door) []]))
 
 rezColor :: RandomGen g => State g LightSource
 rezColor = do

src/Dodge/Room/Room.hs

@@ -60,7 +60,7 @@ branchWith r ts = Node r $ return (useAll door) : ts
 
 
 manyDoors :: Int -> Tree Room
-manyDoors i = treeFromPost (replicate i ( door)) $ useAll door
+manyDoors i = treeFromPost (replicate i door) $ useAll door
 
 glassSwitchBack :: RandomGen g => State g Room
 glassSwitchBack = do
@@ -282,9 +282,9 @@ weaponLongCorridor = do
         ]
     i1 <- state $ randomR (2,5)
     i2 <- state $ randomR (2,5)
-    let branch1 = treeFromTrunk (replicate i1 $  corridorN) (pure . useAll $ putCrs connectingRoom)
+    let branch1 = treeFromTrunk (replicate i1 corridorN) (pure . useAll  $ putCrs connectingRoom)
-    let branch2 = treeFromTrunk (replicate i2 $  corridorN) (pure . useSide $ putWp corridor)
+    let branch2 = treeFromTrunk (replicate i2 corridorN) (pure . useSide $ putWp corridor)
-    return $ Node ( rt) [branch1,branch2]
+    return $ Node rt [branch1,branch2]
       where 
         putCrs = over 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)]
@@ -307,11 +307,11 @@ deadEndRoom = defaultRoom
 {- A random Either tree with a weapon and melee monster challenge.  -}
 weaponRoom :: RandomGen g => Int -> State g (LabTree Room)
 weaponRoom i = join $ takeOne 
-    [ weaponEmptyRoom      <&>  (f "weaponEmptyRoom")
+    [ weaponEmptyRoom       <&>  f "weaponEmptyRoom"
     , weaponUnderCrits i
-    , weaponBehindPillar<&>     (f "weaponBehindPillar")
+    , weaponBehindPillar    <&>  f "weaponBehindPillar"
-    , weaponBetweenPillars<&>   (f "weaponBetweenPillars")
+    , weaponBetweenPillars  <&>  f "weaponBetweenPillars"
-    , weaponLongCorridor<&>     (f "weaponLongCorridor")
+    , weaponLongCorridor    <&>  f "weaponLongCorridor"
     ]
   where
     f str = ( toOnward str ,)

src/Dodge/Room/RunPast.hs

@@ -60,10 +60,10 @@ runPastRoom i = do
             }
         switchdoor = triggerDoorRoom i 
         n = length $ filter theedgetest $ map lnkPosDir $ _rmLinks cenroom
-        controom = treeFromPost [ switchdoor, linkcor] (useAll door)
+        controom = treeFromPost [ switchdoor, linkcor,corridor,corridor] (useAll door)
         critrooms :: [Tree Room]
-        critrooms = treeFromPost [ switchdoor] ( critroom) : 
+        critrooms = treeFromPost [ switchdoor] critroom 
-            replicate (n-2) (treeFromPost [ switchdoor] ( linkcor))
+            : replicate (n-2) (treeFromPost [ switchdoor] linkcor)
-    return $ Node ( cenroom) $ 
+    return $ Node cenroom $ 
         map (over root $ rmConnectsTo .~ S.member (OnEdge theedge)) (controom : critrooms) 
-            ++ [return $  aswitchroom]
+            ++ [return aswitchroom]

src/Dodge/Room/Start.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE TupleSections #-}
+--{-# LANGUAGE TupleSections #-}
 module Dodge.Room.Start where
 import Dodge.UseAll
 import Dodge.Data
@@ -6,7 +6,7 @@ import Dodge.LevelGen.Data
 --import Dodge.PlacementSpot
 import Dodge.Room.RunPast
 import Dodge.Room.Containing
-import Dodge.Room.LongDoor
+--import Dodge.Room.LongDoor
 --import Dodge.RoomLink
 --import Dodge.Data
 --import Dodge.Default
@@ -49,20 +49,17 @@ powerFakeout = do
         `treeFromPost` useAll door
 
 startRoom :: RandomGen g => Int -> State g (LabTree Room)
-startRoom i = join (takeOne $ 
+startRoom i = join (takeOne
     [-- (,) (0.5::Float) ((chainUses <$> sequence [powerFakeout,fmap fst $weaponRoom i]) 
      --       <&> (,TreeSubLabelling "chainUses <$> sequence [powerFakeout,weaponRoom i]" Nothing))
      --     wat
-      (rezBoxesWp <&>      (toOnward "rezBoxesWp",))
+      rezBoxesWp                >>= rToOnward "rezBoxesWp"
-    , (rezBoxThenWeaponRoom i)
+    , rezBoxThenWeaponRoom i
-    , (rezBoxesWpCrit <&> (toOnward "rezBoxesWpCrit",))
+    , rezBoxesWpCrit            >>= rToOnward "rezBoxesWpCrit"
-    , (runPastStart i <&> (toOnward ("runPastStart " ++ show i),))
+    , runPastStart i            >>= rToOnward ("runPastStart " ++ show i)
---    , ((startCrafts >>= roomsContaining' [] >>= rezBoxThenRooms) <&> 
+    , startCrafts >>= roomsContaining' [] >>= rezBoxThenRooms
---        (toOnward "startCrafts >>= roomsContaining [] >>= rezBoxThenRooms",))
+        >>= rToOnward "startCrafts >>= roomsContaining [] >>= rezBoxThenRooms"
     ])
-  where
-    roomsContaining' a b = fst <$> roomsContaining a b
-    one = 1::Float
 randomChallenges :: RandomGen g => State g (LabTree Room)
 randomChallenges = shootingRange
 --        join (takeOne

src/Dodge/Tree/Compose.hs

@@ -43,8 +43,8 @@ import Data.Maybe
 
 overwriteLabel :: Int -> Tree Room -> [Tree Room] -> Tree Room
 overwriteLabel i t ts = safeUpdateSingleNode 
-    (\rm -> LabelCluster 0 `elem` (rm ^?! rmClusterStatus . csLinks))
+    (\rm -> LabelCluster i `elem` (rm ^?! rmClusterStatus . csLinks))
-    ((branches .~ ts) . (root . rmClusterStatus . csLinks . at (LabelCluster 0) .~ Nothing))
+    ((branches .~ ts) . (root . rmClusterStatus . csLinks . at (LabelCluster i) .~ Nothing))
     t
 
 --overwriteLabel :: Int -> (a -> ComposingNode a) -> Tree a -> [Tree a] -> Tree a

src/Dodge/UseAll.hs

@@ -1,6 +1,8 @@
+{-# LANGUAGE TupleSections #-}
 module Dodge.UseAll where
 import Dodge.Data
 
+import Data.Tree
 import Control.Lens
 import qualified Data.Set as S
 
@@ -9,6 +11,9 @@ toOnward s rm
     | OnwardCluster `elem` rm ^?! rmClusterStatus . csLinks = Just ([s],rm)
     | otherwise = Nothing
 
+rToOnward :: Monad m => String -> Tree Room -> m (Room -> Maybe ([String],Room), Tree Room)
+rToOnward s = return . (toOnward s ,)
+
 toClusterLabel :: Int -> String ->  Room -> Maybe ([String],Room)
 toClusterLabel i s rm
     | LabelCluster i `elem` rm ^?! rmClusterStatus . csLinks = Just ([s],rm)

src/TreeHelp.hs

@@ -115,7 +115,7 @@ msafeUpdateSingleNode :: Monoid b => (a -> Bool) -> (Tree a -> (b, Tree a)) -> T
 msafeUpdateSingleNode f g t = fromMaybe (mempty,t) $ listToMaybe $ mupdateSingleNodes f g t
 
 msubMap :: Functor m => (a -> [m a]) -> [a] -> [m [a]]
-msubMap f (x:xs) = (f x <&> fmap (: xs))  ++ ( (fmap (x :)) <$> msubMap f xs ) 
+msubMap f (x:xs) = (f x <&> fmap (: xs))  ++ ( fmap (x :) <$> msubMap f xs ) 
 msubMap _ [] = []
 
 subMap :: (a -> [a]) -> [a] -> [[a]]