diff --git a/src/Dodge/Annotation.hs b/src/Dodge/Annotation.hs index 053098b5d..c6a07a731 100644 --- a/src/Dodge/Annotation.hs +++ b/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) - , overwriteLabel 0 lr [keyroom] - ) - _ -> (toOnward "no label" ,) <$> anoToRoomTree' anos + rToOnward ("PassthroughLockKeyLists-"++show ii) $ overwriteLabel i lr [keyroom] + _ -> rToOnward "no label" =<< anoToRoomTree' anos {- | Create a random room tree structure from a list of annotations. -} anoToRoomTree' :: [Annotation] -> State StdGen (Tree Room) diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index f571aee57..907445375 100644 --- a/src/Dodge/LevelGen.hs +++ b/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 diff --git a/src/Dodge/LockAndKey.hs b/src/Dodge/LockAndKey.hs index 4c439fe9c..96d9941da 100644 --- a/src/Dodge/LockAndKey.hs +++ b/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) - , treeFromPost (replicate 5 $ corridor) ( endroom) - ) - + rToOnward ("corridorBoss-"++_crName cr) + $ treeFromPost (replicate 5 corridor) endroom diff --git a/src/Dodge/Room/Branch.hs b/src/Dodge/Room/Branch.hs index 66a17231a..b3cc6cf58 100644 --- a/src/Dodge/Room/Branch.hs +++ b/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 ] diff --git a/src/Dodge/Room/LasTurret.hs b/src/Dodge/Room/LasTurret.hs index 8fd403b49..92249112b 100644 --- a/src/Dodge/Room/LasTurret.hs +++ 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" - , treeFromTrunk [ door] $ Node ( cenroom) + rToOnward "lasCenSensEdge" + $ 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" - , Node ( r) + rToOnward "lasTunnelRunPast" $ Node r [ pure $ useAll r1 , return (useLabel 0 $ r2 & rmConnectsTo .~ S.member InLink) ] - ) diff --git a/src/Dodge/Room/LongDoor.hs b/src/Dodge/Room/LongDoor.hs index 079801721..37c792225 100644 --- a/src/Dodge/Room/LongDoor.hs +++ b/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" - , treeFromTrunk [ door] $ Node ( r) + rToOnward "slowDoorRoomRunPast" $ treeFromTrunk [ door] $ Node r [ pure $ useAll door , return (useLabel 0 $ door & rmConnectsTo .~ S.member InLink) ] - ) diff --git a/src/Dodge/Room/LongRoom.hs b/src/Dodge/Room/LongRoom.hs index 8a6ee0882..f60abdbcf 100644 --- a/src/Dodge/Room/LongRoom.hs +++ b/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" - , treeFromTrunk [ door] - (Node ( r) - [ pure door + rToOnward "longRoomRunPast" + $ treeFromTrunk [ door] $ Node r + [ pure $ useAll door , treeFromPost [ corridor & rmConnectsTo .~ S.member InLink] (useLabel 0 door) ] - ) - ) diff --git a/src/Dodge/Room/RezBox.hs b/src/Dodge/Room/RezBox.hs index f80db213a..95641cb21 100644 --- a/src/Dodge/Room/RezBox.hs +++ b/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 - , door - ] - (Node ( centralRoom) (rezrooms ++ [onwardpassage])) + return $ treeFromTrunk [ rezBox thecol , door ] + $ 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 - , door - ] - (Node ( centralRoom) (rezrooms ++ [onwardpassage])) + return $ treeFromTrunk [rezBox thecol , door] + $ 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 - , door - ] - (Node ( centralRoom) (replicate (n-1) dbox ++ [Node (useAll door) []])) + return $ treeFromTrunk [rezBox thecol, door] + $ Node centralRoom (replicate (n-1) dbox ++ [Node (useAll door) []]) rezColor :: RandomGen g => State g LightSource rezColor = do diff --git a/src/Dodge/Room/Room.hs b/src/Dodge/Room/Room.hs index f01751c4a..2d02bb0a6 100644 --- a/src/Dodge/Room/Room.hs +++ b/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 branch2 = treeFromTrunk (replicate i2 $ corridorN) (pure . useSide $ putWp corridor) - return $ Node ( rt) [branch1,branch2] + let branch1 = treeFromTrunk (replicate i1 corridorN) (pure . useAll $ putCrs connectingRoom) + let branch2 = treeFromTrunk (replicate i2 corridorN) (pure . useSide $ 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 ]) 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") - , weaponBetweenPillars<&> (f "weaponBetweenPillars") - , weaponLongCorridor<&> (f "weaponLongCorridor") + , weaponBehindPillar <&> f "weaponBehindPillar" + , weaponBetweenPillars <&> f "weaponBetweenPillars" + , weaponLongCorridor <&> f "weaponLongCorridor" ] where f str = ( toOnward str ,) diff --git a/src/Dodge/Room/RunPast.hs b/src/Dodge/Room/RunPast.hs index dc17ae875..ba4eb872b 100644 --- a/src/Dodge/Room/RunPast.hs +++ b/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) : - replicate (n-2) (treeFromPost [ switchdoor] ( linkcor)) - return $ Node ( cenroom) $ + critrooms = treeFromPost [ switchdoor] critroom + : replicate (n-2) (treeFromPost [ switchdoor] linkcor) + return $ Node cenroom $ map (over root $ rmConnectsTo .~ S.member (OnEdge theedge)) (controom : critrooms) - ++ [return $ aswitchroom] + ++ [return aswitchroom] diff --git a/src/Dodge/Room/Start.hs b/src/Dodge/Room/Start.hs index d3c414678..5c99bc6d8 100644 --- a/src/Dodge/Room/Start.hs +++ b/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",)) - , (rezBoxThenWeaponRoom i) - , (rezBoxesWpCrit <&> (toOnward "rezBoxesWpCrit",)) - , (runPastStart i <&> (toOnward ("runPastStart " ++ show i),)) --- , ((startCrafts >>= roomsContaining' [] >>= rezBoxThenRooms) <&> --- (toOnward "startCrafts >>= roomsContaining [] >>= rezBoxThenRooms",)) + rezBoxesWp >>= rToOnward "rezBoxesWp" + , rezBoxThenWeaponRoom i + , rezBoxesWpCrit >>= rToOnward "rezBoxesWpCrit" + , runPastStart i >>= rToOnward ("runPastStart " ++ show i) + , 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 diff --git a/src/Dodge/Tree/Compose.hs b/src/Dodge/Tree/Compose.hs index 3179e1677..c93b80dc3 100644 --- a/src/Dodge/Tree/Compose.hs +++ b/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)) - ((branches .~ ts) . (root . rmClusterStatus . csLinks . at (LabelCluster 0) .~ Nothing)) + (\rm -> LabelCluster i `elem` (rm ^?! rmClusterStatus . csLinks)) + ((branches .~ ts) . (root . rmClusterStatus . csLinks . at (LabelCluster i) .~ Nothing)) t --overwriteLabel :: Int -> (a -> ComposingNode a) -> Tree a -> [Tree a] -> Tree a diff --git a/src/Dodge/UseAll.hs b/src/Dodge/UseAll.hs index f50e004d4..f6a9e0a53 100644 --- a/src/Dodge/UseAll.hs +++ b/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) diff --git a/src/TreeHelp.hs b/src/TreeHelp.hs index 1c4277891..feff40bea 100644 --- a/src/TreeHelp.hs +++ b/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]]