diff --git a/src/Dodge/Annotation.hs b/src/Dodge/Annotation.hs index 6e3ed9c34..2aea8ea09 100644 --- a/src/Dodge/Annotation.hs +++ b/src/Dodge/Annotation.hs @@ -45,13 +45,13 @@ anoToRoomTree anos = case anos of [AnoApplyInt i f] -> f i [SetLabel i randrm] -> do rm <- randrm - return . connectRoom $ rm & rmLabel ?~ i + return . singleUseAll $ rm & rmLabel ?~ i [UseLabel i randrm] -> do rm <- randrm - return $ connectRoom $ rm & rmTakeFrom ?~ i + return $ singleUseAll $ rm & rmTakeFrom ?~ i [ChainAnos ass] -> do rms <- mapM anoToRoomTree ass - return $ linkEitherTrees rms + return $ chainUses rms [OrAno as] -> do a <- takeOne as anoToRoomTree a @@ -60,7 +60,7 @@ anoToRoomTree anos = case anos of [FirstWeapon] -> do branchWP <- branchRectWith weaponRoom blockedC <- longBlockedCorridor - join $ takeOne $ return (appendEitherTree branchWP [blockedC]) : replicate 5 weaponRoom + join $ takeOne $ return (passUntilUseAll branchWP [blockedC]) : replicate 5 weaponRoom [EndRoom] -> fmap (pure . UseAll) (telRoomLev 1) (SpecificRoom rt:_) -> rt (BossAno cr : _) -> do diff --git a/src/Dodge/Annotation/Data.hs b/src/Dodge/Annotation/Data.hs index f40e87803..2d12884da 100644 --- a/src/Dodge/Annotation/Data.hs +++ b/src/Dodge/Annotation/Data.hs @@ -5,7 +5,6 @@ import Dodge.Data import Dodge.Room import Dodge.Tree.Compose.Data -import Data.Tree import Control.Monad.State import Control.Lens data Annotation g diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index bca65dba7..9d84d15bd 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -94,7 +94,7 @@ initialAnoTree = padSucWithCorridors $ treeFromTrunk {- | A test level tree. -} initialRoomTree :: RandomGen g => State g (Tree Room) initialRoomTree = do - expandTreeBy id <$> mapM anoToRoomTree initialAnoTree + expandTree <$> mapM anoToRoomTree initialAnoTree layoutLevelFromSeed :: Int -> Int -> IO [Room] layoutLevelFromSeed i seed = do diff --git a/src/Dodge/Room/Branch.hs b/src/Dodge/Room/Branch.hs index c10d85e2f..bbece0614 100644 --- a/src/Dodge/Room/Branch.hs +++ b/src/Dodge/Room/Branch.hs @@ -21,7 +21,5 @@ branchRectWith t = do y <- state $ randomR (100,200) b <- t root <- randomiseOutLinks $ roomRectAutoLinks x y - return $ Node (PassDown root) [Node (UseAll door) [], rToL <$> treeFromTrunk [PassDown door] b] - where - rToL (UseAll r) = PassDown r - rToL (PassDown r) = PassDown r + return $ Node (PassDown root) [Node (UseAll door) [], changeToPassDown <$> + treeFromTrunk [PassDown door] b] diff --git a/src/Dodge/Room/RoadBlock.hs b/src/Dodge/Room/RoadBlock.hs index f0cae05fb..23ae17b28 100644 --- a/src/Dodge/Room/RoadBlock.hs +++ b/src/Dodge/Room/RoadBlock.hs @@ -14,7 +14,6 @@ import Dodge.RandomHelp import Dodge.Creature import Dodge.Tree -import Data.Tree import Control.Monad.State import Control.Lens import System.Random diff --git a/src/Dodge/Room/Room.hs b/src/Dodge/Room/Room.hs index 1a3a04318..f1598d7bb 100644 --- a/src/Dodge/Room/Room.hs +++ b/src/Dodge/Room/Room.hs @@ -77,7 +77,7 @@ glassLesson = do corridors <- replicateM i $ PassDown <$> randomiseOutLinks corridor return $ Node (PassDown botRoom) [singleUseNone door,uppers, treeFromPost (PassDown door : corridors) $ UseAll door] where - uppers = Node (PassDown door) [deadRoom topRoom] + uppers = Node (PassDown door) [singleUseNone topRoom] botRoom = set rmPmnts botplmnts $ roomRect 200 200 1 1 topRoom = set rmPmnts topplmnts $ roomRect 200 200 1 1 botplmnts = @@ -171,7 +171,7 @@ miniRoom3 = do ,sPS cp (pi/8+7*pi/4) b ,sPS (V2 (w/2) (h/2)) 0 putLamp ] - fmap connectRoom $ randomiseOutLinks $ set rmPmnts plmnts $ roomRectAutoLinks w h + fmap singleUseAll $ randomiseOutLinks $ set rmPmnts plmnts $ roomRectAutoLinks w h rot90Around :: Point2 -> Point2 -> Point2 rot90Around cen p = cen +.+ vNormal (p -.- cen) @@ -179,17 +179,9 @@ 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 (SubCompTree Room) -roomMiniIntro = fmap (g . expandTreeBy f) $ sequence $ treeFromPost - [return $ connectRoom door - ,join $ takeOne [miniTree2,glassLesson] - ] - $ connectRoom <$> randomiseOutLinks corridor - where - f (Node (UseAll x) xs) = Node (UseAll (UseAll x)) $ map f xs - f (Node (PassDown x) xs) = Node (PassDown (PassDown x)) $ map f xs - g (Node (UseAll x) []) = Node (UseAll x) [] - g (Node (UseAll x) xs) = Node (PassDown x) $ map g xs - g (Node y ys) = Node y $ map g ys +roomMiniIntro = do + midroom <- join $ takeOne [miniTree2,glassLesson] + return $ chainUses $ [return $ UseAll door, midroom,return $ UseAll corridor] roomCenterPillar :: RandomGen g => State g Room roomCenterPillar = changeLinkTo ((\p -> dist p (V2 120 0) < 10) . fst) @@ -272,7 +264,7 @@ weaponEmptyRoom = do ,mntLightLnkCond unusedLnkToPS ] treeFromTrunk [PassDown corridor] - <$> ((fmap connectRoom . randomiseOutLinks) =<< + <$> ((fmap singleUseAll . randomiseOutLinks) =<< changeLinkTo ((\p -> dist p (V2 (w/2) 0) < 10) . fst) (set rmPmnts plmnts $ roomRect w h 2 2) ) @@ -285,14 +277,14 @@ weaponUnderCrits = do ] let continuationRoom = treeFromTrunk [PassDown corridorN,PassDown corridorN] - (connectRoom (set rmPmnts plmnts corridorN)) + (singleUseAll (set rmPmnts plmnts corridorN)) rcp <- roomCenterPillar deadEndRoom' <- takeOne [roomPillars,rcp] junctionRoom <- takeOne [PassDown tEast,PassDown tWest] return $ treeFromTrunk [PassDown corridorN,PassDown corridorN] $ Node junctionRoom [continuationRoom - ,deadRoom deadEndRoom' + ,singleUseNone deadEndRoom' ] weaponBehindPillar :: RandomGen g => State g (SubCompTree Room) @@ -310,7 +302,7 @@ weaponBehindPillar = do [PassDown corridor ,PassDown $ over rmLinks tail $ over rmPmnts (++ plmnts1) rcp ] - (connectRoom $ set rmPmnts [sPS (V2 20 60) (negate $ pi/2) randC1] corridorN) + (singleUseAll $ set rmPmnts [sPS (V2 20 60) (negate $ pi/2) randC1] corridorN) weaponBetweenPillars :: RandomGen g => State g (SubCompTree Room) weaponBetweenPillars = do @@ -324,7 +316,7 @@ weaponBetweenPillars = do ,sPS crPos2 (d crPos2) randC1 ] theRoom = roomPillars & rmPmnts %~ (++ plmnts) - (fmap connectRoom . randomiseOutLinks) =<< filterLinks f theRoom + (fmap singleUseAll . randomiseOutLinks) =<< filterLinks f theRoom where f (_,a) = a == 0 @@ -336,8 +328,8 @@ weaponLongCorridor = do ] i1 <- state $ randomR (2,5) i2 <- state $ randomR (2,5) - let branch1 = treeFromTrunk (replicate i1 $ PassDown corridorN) (connectRoom $ putCrs connectingRoom) - let branch2 = treeFromTrunk (replicate i2 $ PassDown corridorN) (deadRoom $ putWp corridor) + let branch1 = treeFromTrunk (replicate i1 $ PassDown corridorN) (singleUseAll $ putCrs connectingRoom) + let branch2 = treeFromTrunk (replicate i2 $ PassDown corridorN) (singleUseNone $ putWp corridor) return $ Node (PassDown root) [branch1,branch2] where putCrs = over rmPmnts (++ [sPS (V2 10 40) (-pi/2) randC1 ,sPS (V2 (-10) 40) (-pi/2) randC1 ]) @@ -512,4 +504,4 @@ spawnerRoom = do roomWithSpawner <- roomC x y <&> rmPmnts %~ (spNoID (PSRoomRand 0) (PutCrit spawnerCrit) :) aRoom <- airlock - return $ treeFromTrunk [PassDown aRoom,PassDown corridor] $ connectRoom roomWithSpawner + return $ treeFromTrunk [PassDown aRoom,PassDown corridor] $ singleUseAll roomWithSpawner diff --git a/src/Dodge/Room/Start.hs b/src/Dodge/Room/Start.hs index 97c8a6ce2..587de0867 100644 --- a/src/Dodge/Room/Start.hs +++ b/src/Dodge/Room/Start.hs @@ -80,11 +80,12 @@ rezThenLasTurret = do cenroom <- randomiseOutLinks $ centralLasTurret {_rmLabel = Just 0} let doorroom = switchDoorRoom {_rmTakeFrom = Just 0} contTree = treeFromPost [PassDown cenroom,PassDown doorroom] (UseAll door) - return $ rbox `appendEitherTree` [contTree] + return $ rbox `passUntilUseAll` [contTree] startRoom :: RandomGen g => Int -> State g (SubCompTree Room) startRoom i = join $ takeOne - [ minigunfakeout + [-- roomMiniIntro + minigunfakeout , rezBoxesWp , rezBoxesThenWeaponRoom , rezBoxThenWeaponRoom @@ -96,7 +97,7 @@ runPastStart :: RandomGen g => Int -> State g (SubCompTree Room) runPastStart i = do s <- rezBoxStart rp <- runPastRoom i - return $ s `appendEitherTree` [rp] + return $ s `passUntilUseAll` [rp] rezBoxStart :: RandomGen g => State g (SubCompTree Room) rezBoxStart = do @@ -135,7 +136,7 @@ rezBoxesThenWeaponRoom :: RandomGen g => State g (SubCompTree Room) rezBoxesThenWeaponRoom = do rboxes <- rezBoxes wroom <- weaponRoom - return $ rboxes `appendEitherTree` [wroom] + return $ rboxes `passUntilUseAll` [wroom] rezBoxThenWeaponRoom :: RandomGen g => State g (SubCompTree Room) rezBoxThenWeaponRoom = do diff --git a/src/Dodge/Tree/Compose.hs b/src/Dodge/Tree/Compose.hs index fa4fa7f06..b51946313 100644 --- a/src/Dodge/Tree/Compose.hs +++ b/src/Dodge/Tree/Compose.hs @@ -1,17 +1,12 @@ {-| Combining and composing trees of trees. -} module Dodge.Tree.Compose - ( expandTreeBy - , appendEitherTree - , connectRoom - , connectTrunk - , deadRoom - , linkEitherTrees - , expandTree + ( expandTree , singleUseAll , singleUseNone , passUntilUseAll , chainUses , useAllAtEnd + , changeToPassDown ) where import Dodge.Tree.Compose.Data import Data.Tree @@ -25,95 +20,25 @@ expandTree (Node root extChildren) = case root of Node (SplitDown x) xs -> Node x $ map expandTree $ zipWith Node xs $ map (:[]) extChildren ++ repeat [] -expandTreeBy - :: (a -> SubCompTree b) -- ^ Node function - -> Tree a -- ^ Base tree - -> Tree b -expandTreeBy f (Node x []) = fmap _unCompose (f x) -expandTreeBy f (Node x xs) = appendAndRemove $ f x - where - appendAndRemove (Node (PassDown y) ys) = Node y (map appendAndRemove ys) - appendAndRemove (Node (UseAll y) _ ) = Node y (map (expandTreeBy f) xs) - - ----- | 'Left' elements get new children as given by the node function, ----- 'Right' elements inherit the children from the base tree ---expandTreeBy --- :: (a -> Tree (Either b b)) -- ^ Node function --- -> Tree a -- ^ Base tree --- -> Tree b ---expandTreeBy f (Node x []) = fmap removeEither (f x) ---expandTreeBy f (Node x xs) = appendAndRemove $ f x --- where --- appendAndRemove (Node (Left y) ys) = Node y (map appendAndRemove ys) --- appendAndRemove (Node (Right y) _ ) = Node y (map (expandTreeBy f) xs) - --- | Appends a second either forest at the 'Right' elements of a first either --- tree. --- Makes such 'Right' elements into 'Left's. ---appendEitherTree --- :: Tree (Either a a) -- ^ The first tree --- -> [Tree (Either a a)] -- ^ The forest to append --- -> Tree (Either a a) ---appendEitherTree (Node (Left x) ts) ts' = Node (Left x) $ map (`appendEitherTree` ts') ts ---appendEitherTree (Node (Right x) _) ts' = Node (Left x) ts' - -appendEitherTree = passUntilUseAll - passUntilUseAll :: SubCompTree a -> [SubCompTree a] -> SubCompTree a passUntilUseAll (Node (UseAll x) _) ts' = Node (PassDown x) ts' passUntilUseAll (Node cn ts) ts' = Node (PassDown (_unCompose cn)) $ map (`passUntilUseAll` ts') ts ---linkEitherTrees :: [Tree (Either a a)] -> Tree (Either a a) ---linkEitherTrees (t:s:ts) = linkEitherTrees (appendEitherTree t [s]:ts) ---linkEitherTrees [t] = t ---linkEitherTrees [] = error "tried to concatenate an empty list of either trees" - -linkEitherTrees = chainUses - chainUses :: [SubCompTree a] -> SubCompTree a chainUses (t:s:ts) = chainUses (passUntilUseAll t [s]:ts) chainUses [t] = t chainUses [] = error "tried to concatenate an empty list of SubCompTrees" -removeEither = _unCompose - --- this is _unCompose ---removeEither :: Either p p -> p ---removeEither (Left y) = y ---removeEither (Right y) = y - -{- | -Make a singleton connection of an Either Tree. --} ---connectRoom :: a -> Tree (Either a a) ---connectRoom r = Node (Right r) [] - -connectRoom = singleUseAll - singleUseAll :: a -> Tree (ComposingNode a) singleUseAll x = Node (UseAll x) [] -{- | -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) [] --- -connectTrunk = useAllAtEnd useAllAtEnd :: Tree a -> SubCompTree a useAllAtEnd tree = case tree of Node x (t:ts) -> Node (PassDown x) (useAllAtEnd t : map (fmap UseNone) ts) Node x [] -> Node (UseAll x) [] -{- | -Make a singleton dead end of an Either Tree. --} ---deadRoom :: a -> Tree (Either a a) ---deadRoom r = Node (Left r) [] - -deadRoom = singleUseNone - singleUseNone :: a -> SubCompTree a singleUseNone x = Node (UseNone x) [] + +changeToPassDown :: ComposingNode a -> ComposingNode a +changeToPassDown x = PassDown (_unCompose x)