diff --git a/src/Dodge/Annotation.hs b/src/Dodge/Annotation.hs index 57d207acb..1c52bc1f6 100644 --- a/src/Dodge/Annotation.hs +++ b/src/Dodge/Annotation.hs @@ -7,7 +7,8 @@ module Dodge.Annotation import Dodge.UseAll import RandomHelp import Dodge.Tree -import Dodge.Room +import Dodge.Tree.Compose +--import Dodge.Room import Dodge.Data import Dodge.Annotation.Data import LensHelp @@ -15,44 +16,17 @@ import LensHelp --import Control.Lens import Data.Maybe -{- | Add one corridor between each parent-child link of a tree of annotations. -} ---padWithCorridors :: Annotation -> Annotation ---padWithCorridors = padWithAno [Corridor] --- ---padWithAno :: [Annotation] -> Tree [Annotation] -> Tree [Annotation] ---padWithAno ano (Node x xs) = Node ano [Node x (map (padWithAno ano) xs)] --- ---padSucWithCorridors :: Tree [Annotation] -> Tree [Annotation] ---padSucWithCorridors (Node x xs) = Node x (map padWithCorridors xs) --- ---padSucWithDoors :: Tree [Annotation] -> Tree [Annotation] ---padSucWithDoors (Node x xs) = Node x (map (padWithAno [SpecificRoom thetree]) xs) --- where --- thetree = do --- thecor <- shuffleLinks corridor --- takeOne --- [ (toOnward "door", return (cleatOnward door)) --- , (toOnward "twoDoors" ,treePost [ door, thecor, cleatOnward door]) --- ] --- ---{- Add one to three corridors between each parent-child link of a tree of annotations. -} ---randomPadCorridors :: Tree [Annotation] -> State StdGen (Tree [Annotation]) ---randomPadCorridors (Node x xs) = do --- n <- state $ randomR (1, 3) --- xs' <- mapM randomPadCorridors xs --- return $ treeFromTrunk (replicate n [Corridor]) (Node x xs') - -annoToRoomTree' :: Annotation -> State (StdGen,Int) (MetaTree Room) -annoToRoomTree' an = case an of +annoToRoomTree :: Annotation -> State (StdGen,Int) (MetaTree Room) +annoToRoomTree an = case an of SpecificRoom r -> zoom _1 r OnwardList ans -> do - mts <- mapM annoToRoomTree' ans + mts <- mapM annoToRoomTree ans return $ foldr1 attachOnward mts IntAnno f -> do (g,i) <- get put (g,i+1) - annoToRoomTree' (f i) - PadWith r an -> annoToRoomTree' an + annoToRoomTree (f i) + ModifyTree f a -> f <$> annoToRoomTree a PassthroughLockKeyLists ls ks i -> zoom _1 $ do (functionlockroom,randomitemidentity) <- takeOne ls lr <- functionlockroom i @@ -62,7 +36,3 @@ annoToRoomTree' an = case an of (MTree "" lr [MBranch "" (toLabel' i) keyroom]) [] -attachOnward :: MetaTree Room -> MetaTree Room -> MetaTree Room -attachOnward t1 t2 = case t1 of - MTree {} -> t1 & mtBranches .:~ MBranch "Onward" toOnward' t2 - BTree {} -> MTree "ConstructedOnward" t1 [MBranch "Onward" toOnward' t2] diff --git a/src/Dodge/Annotation/Data.hs b/src/Dodge/Annotation/Data.hs index 6e61d2cfd..c6e85d70b 100644 --- a/src/Dodge/Annotation/Data.hs +++ b/src/Dodge/Annotation/Data.hs @@ -3,22 +3,17 @@ module Dodge.Annotation.Data where import Dodge.Data --import Dodge.Room -import TreeHelp +--import TreeHelp import Dodge.Tree.Compose.Data import Control.Monad.State import Control.Lens import System.Random data Annotation - = -- Corridor --- | AirlockAno - PadWith Room Annotation + = ModifyTree (MetaTree Room -> MetaTree Room) Annotation | OnwardList [Annotation] --- | IntAnno Int (Int -> Annotation) | IntAnno (Int -> Annotation) --- | OrAno [[Annotation]] | SpecificRoom (State StdGen (MetaTree Room)) - | AnoApplyInt Int (Int -> State StdGen (LabTree Room)) | PassthroughLockKeyLists [(Int -> State StdGen (MetaTree Room), State StdGen ItemBaseType)] [(ItemBaseType, State StdGen (MetaTree Room))] diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index ac0a01800..cf897bcb3 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -38,7 +38,7 @@ import Data.List (intersperse) initialAnoTree :: Annotation initialAnoTree = OnwardList - $ intersperse (SpecificRoom $ (tToBTree . pure) <$> shuffleLinks (cleatOnward corridor)) + $ intersperse (SpecificRoom $ tToBTree . pure <$> shuffleLinks (cleatOnward corridor)) [ IntAnno $ SpecificRoom . startRoom -- , (SpecificRoom . return . tToBTree $ treePost [corridor,corridor,cleatOnward corridor]) , IntAnno $ PassthroughLockKeyLists @@ -50,7 +50,7 @@ initialAnoTree = OnwardList [ spNoID anyUnusedSpot (PutCrit invisibleChaseCrit) , spNoID anyUnusedSpot (PutCrit armourChaseCrit) ] --- , [AnoApplyInt 100 healthTest] + , IntAnno $ SpecificRoom . fmap tToBTree . healthTest , SpecificRoom (tanksRoom [] [] >>= rToOnward "empty tanksRoom" . pure . cleatOnward) , IntAnno $ PassthroughLockKeyLists lockRoomKeyItems itemRooms , SpecificRoom randomChallenges @@ -101,4 +101,4 @@ initialAnoTree = OnwardList {- | A test level tree. -} initialRoomTree :: State (StdGen,Int) (MetaTree Room) -initialRoomTree = annoToRoomTree' initialAnoTree +initialRoomTree = annoToRoomTree initialAnoTree diff --git a/src/Dodge/Room/GlassLesson.hs b/src/Dodge/Room/GlassLesson.hs index bac3d85cb..86effcf08 100644 --- a/src/Dodge/Room/GlassLesson.hs +++ b/src/Dodge/Room/GlassLesson.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TupleSections #-} +--{-# LANGUAGE TupleSections #-} module Dodge.Room.GlassLesson where import Dodge.UseAll import Dodge.RoomLink @@ -54,6 +54,6 @@ glassLesson = do ] ] glassLessonRunPast :: RandomGen g => State g (MetaTree Room) -glassLessonRunPast = (f <$> glassLesson) >>= rToOnward "glassLessonRunPast" +glassLessonRunPast = glassLesson >>= rToOnward "glassLessonRunPast" . f where f (Node r rs) = Node r $ return (cleatLabel 0 $ door & rmConnectsTo .~ S.member (OnEdge West)) : rs diff --git a/src/Dodge/Room/Room.hs b/src/Dodge/Room/Room.hs index 992444719..946cd6b27 100644 --- a/src/Dodge/Room/Room.hs +++ b/src/Dodge/Room/Room.hs @@ -192,7 +192,7 @@ weaponEmptyRoom = do $ restrictRMInLinksPD f (roomRect w h 2 2 & rmPmnts .~ plmnts) return $ treeFromTrunk [ corridor] (pure $ cleatOnward rm ) -weaponUnderCrits :: RandomGen g => Int -> State g (LabTree Room) +weaponUnderCrits :: RandomGen g => Int -> State g (MetaTree Room) weaponUnderCrits i = do let plmnts = [--sPS (V2 20 0) 0 $ RandPS randFirstWeapon @@ -211,19 +211,7 @@ weaponUnderCrits i = do junctionRoom <- takeOne [ tEast, tWest] let thetree = treeFromTrunk [ corridorN , corridorN] $ Node junctionRoom [continuationRoom ,pure deadEndRoom' ] - return (toOnward "weaponUnderCrits" , thetree ) --- TODO addSubmessages - ---composingNodeName :: ComposingNode Room -> TreeSubLabelling ---composingNodeName cn = case cn of --- rm -> f $ _rmName rm ++ "-" --- SplitDown rm -> f $ _rmName rm ++ "-SplitDown" --- useAll rm -> f $ _rmName rm ++ "-useAll" --- UseSome is rm -> f $ _rmName rm ++ "-" ++ show is ++ "-UseSome" --- UseNone rm -> f $ _rmName rm ++ "-UseNone" --- useLabel i rm -> f $ _rmName rm ++ "-" ++ show i ++ "-useLabel" --- where --- f str = TreeSubLabelling str Nothing + rToOnward "weaponUnderCrits" thetree weaponBehindPillar :: RandomGen g => State g (Tree Room) weaponBehindPillar = do @@ -291,16 +279,14 @@ deadEndRoom = defaultRoom where lnks = [(V2 0 30 ,0) ] {- A random Either tree with a weapon and melee monster challenge. -} -weaponRoom :: RandomGen g => Int -> State g (LabTree Room) +weaponRoom :: RandomGen g => Int -> State g (MetaTree Room) weaponRoom i = join $ takeOne - [ weaponEmptyRoom <&> f "weaponEmptyRoom" + [ weaponEmptyRoom >>= rToOnward "weaponEmptyRoom" , weaponUnderCrits i - , weaponBehindPillar <&> f "weaponBehindPillar" - , weaponBetweenPillars <&> f "weaponBetweenPillars" - , weaponLongCorridor <&> f "weaponLongCorridor" + , weaponBehindPillar >>= rToOnward "weaponBehindPillar" + , weaponBetweenPillars >>= rToOnward "weaponBetweenPillars" + , weaponLongCorridor >>= rToOnward "weaponLongCorridor" ] - where - f str = ( toOnward str ,) roomCCrits :: RandomGen g => State g Room roomCCrits = roomC 200 200 diff --git a/src/Dodge/Room/RunPast.hs b/src/Dodge/Room/RunPast.hs index 748bf2eca..8e3870ee4 100644 --- a/src/Dodge/Room/RunPast.hs +++ b/src/Dodge/Room/RunPast.hs @@ -43,8 +43,8 @@ roomCritLS = do smallRoom :: Room smallRoom = corridorWallN & rmRandPSs .~ [psRandRanges (15,25) (30,45) (pi,2*pi)] -runPastRoom :: RandomGen g => Int -> State g (Tree Room) -runPastRoom i = do +lookedStart :: RandomGen g => Int -> State g (Tree Room) +lookedStart i = do h <- state $ randomR (200,400::Float) thels <- roomCritLS theweapon <- randBlockBreakWeapon diff --git a/src/Dodge/Room/Start.hs b/src/Dodge/Room/Start.hs index 87c15d467..36c8dd1e6 100644 --- a/src/Dodge/Room/Start.hs +++ b/src/Dodge/Room/Start.hs @@ -71,10 +71,8 @@ randomChallenges = shootingRange runPastStart :: RandomGen g => Int -> State g (Tree Room) runPastStart i = do s <- rezBoxStart - rp <- runPastRoom i - --return $ s `passUntiluseAll` [rp] + rp <- lookedStart i return . shiftChildren $ attachTree toOnward' rp $ fmap ([],) s --- return . shiftChildren $ attachTree toOnward' (pure $ useAll corridor) $ fmap ([],) s rezBoxStart :: RandomGen g => State g (Tree Room) @@ -82,18 +80,17 @@ rezBoxStart = do ls <- rezColor return $ treePost [ rezBox ls, cleatOnward door ] -rezBoxesThenWeaponRoom :: RandomGen g => Int -> State g (Tree Room,String) +rezBoxesThenWeaponRoom :: RandomGen g => Int -> State g (MetaTree Room) rezBoxesThenWeaponRoom i = do rboxes <- rezBoxes - wroom <- snd <$> weaponRoom i - return (rboxes `passUntiluseAll` [wroom] , "rezBoxesThenWeaponRoom " ++ show i) + wroom <- weaponRoom i + return $ MTree "rezBoxesThenWeaponRoom" (tToBTree rboxes) [MBranch "" toOnward' wroom] rezBoxThenWeaponRoom :: RandomGen g => Int -> State g (MetaTree Room) rezBoxThenWeaponRoom i = do rcol <- rezColor - (_,wroom) <- weaponRoom i - rToOnward ("rezBoxThenWeaponRoom "++ show i) - $ treeFromTrunk [ rezBox rcol, door] wroom + wroom <- weaponRoom i + return $ tToBTree (treePost [ rezBox rcol, cleatOnward door]) `attachOnward` wroom rezBoxThenRoom :: RandomGen g => Room -> State g (Tree Room) rezBoxThenRoom r = do diff --git a/src/Dodge/Tree/Compose.hs b/src/Dodge/Tree/Compose.hs index 867e74bf8..3cad59215 100644 --- a/src/Dodge/Tree/Compose.hs +++ b/src/Dodge/Tree/Compose.hs @@ -9,6 +9,7 @@ module Dodge.Tree.Compose --, changeTo --, applyToCompRoot passUntiluseAll -- this should be moved, and the dependency on Dodge.Data removed + , tToBTree , overwriteLabel , composeTree , composeTree' @@ -16,8 +17,11 @@ module Dodge.Tree.Compose , attachTree , composeTreeRand , composeAndLog + , toOnward' + , attachOnward -- , cmpToMT -- , compTree + , module Dodge.Tree.Compose.Data ) where import Dodge.Data import Dodge.Tree.Compose.Data @@ -179,15 +183,23 @@ composeAndLog dolog mt = case mt of MTree{} -> do dolog $ drawTree $ logMT mt rt <- composeAndLog dolog $ _mtTree mt - brs <- mapM (\mb -> (_mbAttach mb,) <$> (composeAndSubLog dolog) (_mbTree mb)) $ _mtBranches mt + brs <- mapM (\mb -> (_mbAttach mb,) <$> composeAndSubLog dolog (_mbTree mb)) $ _mtBranches mt return $ attachList rt $ map pure brs BTree{} -> do dolog $ drawTree $ logMT mt brs <- mapM (composeAndSubLog dolog) $ _btBranches mt return $ Node (_btValue mt) brs -cmpToMT :: Tree (a-> Maybe (b,a), Tree a) -> MetaTree a -cmpToMT (Node (_,t) ts) = MTree "A" (tToBT t) (map tToMB ts) - where - tToMB (Node (f,t') ts') = MBranch "C" (fmap snd . f) $ MTree "D" (tToBT t') (map tToMB ts') - tToBT (Node x xs) = BTree "B" x $ map tToBT xs +tToBTree :: Tree Room -> MetaTree Room +tToBTree (Node r ts) = BTree (_rmName r) r $ map tToBTree ts + +attachOnward :: MetaTree Room -> MetaTree Room -> MetaTree Room +attachOnward t1 t2 = case t1 of + MTree {} -> t1 & mtBranches .:~ MBranch "Onward" toOnward' t2 + BTree {} -> MTree "ConstructedOnward" t1 [MBranch "Onward" toOnward' t2] + +toOnward' :: Room -> Maybe Room +toOnward' rm + | OnwardCluster `elem` rm ^?! rmClusterStatus . csLinks + = Just (rm & rmClusterStatus . csLinks . at OnwardCluster .~ Nothing) + | otherwise = Nothing diff --git a/src/Dodge/UseAll.hs b/src/Dodge/UseAll.hs index 2467460c9..cebacc601 100644 --- a/src/Dodge/UseAll.hs +++ b/src/Dodge/UseAll.hs @@ -1,6 +1,14 @@ -{-# LANGUAGE TupleSections #-} -module Dodge.UseAll where +--{-# LANGUAGE TupleSections #-} +module Dodge.UseAll + ( toOnward' + , toLabel' + , cleatOnward + , cleatSide + , rToOnward + , cleatLabel + ) where import Dodge.Data +import Dodge.Tree.Compose import Dodge.Tree.Compose.Data import Data.Tree @@ -13,8 +21,6 @@ toOnward s rm = Just ([s],rm & rmClusterStatus . csLinks . at OnwardCluster .~ Nothing) | otherwise = Nothing -toOnward' :: Room -> Maybe Room -toOnward' = fmap snd . toOnward "" toLabel' :: Int -> Room -> Maybe Room toLabel' i rm @@ -24,8 +30,6 @@ toLabel' i rm rToOnward :: Monad m => String -> Tree Room -> m (MetaTree Room) rToOnward s t = return $ MTree s (tToBTree t) [] -tToBTree :: Tree Room -> MetaTree Room -tToBTree (Node r ts) = BTree (_rmName r) r $ map tToBTree ts toClusterLabel :: Int -> String -> Room -> Maybe ([String],Room) toClusterLabel i s rm