From 09e774d0093f40009b86a558c6345b3b7d51ef84 Mon Sep 17 00:00:00 2001 From: justin Date: Mon, 22 Nov 2021 12:46:32 +0000 Subject: [PATCH] Fold in new composing room datatype --- src/Dodge/Annotation.hs | 16 +++---- src/Dodge/Annotation/Data.hs | 5 ++- src/Dodge/Floor.hs | 20 ++++----- src/Dodge/Room/Branch.hs | 9 ++-- src/Dodge/Room/RoadBlock.hs | 10 ++--- src/Dodge/Room/Room.hs | 76 ++++++++++++++++----------------- src/Dodge/Room/RunPast.hs | 12 +++--- src/Dodge/Room/Start.hs | 82 ++++++++++++++++++------------------ src/Dodge/Tree/Compose.hs | 80 ++++++++++++++++++++++------------- 9 files changed, 166 insertions(+), 144 deletions(-) diff --git a/src/Dodge/Annotation.hs b/src/Dodge/Annotation.hs index 4af2c75c4..6e3ed9c34 100644 --- a/src/Dodge/Annotation.hs +++ b/src/Dodge/Annotation.hs @@ -35,12 +35,12 @@ randomPadCorridors (Node x xs) = do 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 (Either Room Room)) -roomThenCorridor theRoom = fmap (\r -> Node (Left theRoom) [(pure . Right) r]) +roomThenCorridor :: RandomGen g => Room -> State g (SubCompTree Room) +roomThenCorridor theRoom = fmap (\r -> Node (PassDown theRoom) [(pure . UseAll) r]) (randomiseOutLinks corridor) {- | Create a random room tree structure from a list of annotations. -} -anoToRoomTree :: RandomGen g => [Annotation g] -> State g (Tree (Either Room Room)) +anoToRoomTree :: RandomGen g => [Annotation g] -> State g (SubCompTree Room) anoToRoomTree anos = case anos of [AnoApplyInt i f] -> f i [SetLabel i randrm] -> do @@ -55,19 +55,19 @@ anoToRoomTree anos = case anos of [OrAno as] -> do a <- takeOne as anoToRoomTree a - [Corridor] -> pure . Right <$> randomiseOutLinks corridor + [Corridor] -> pure . UseAll <$> randomiseOutLinks corridor [AirlockAno] -> airlock >>= roomThenCorridor [FirstWeapon] -> do branchWP <- branchRectWith weaponRoom blockedC <- longBlockedCorridor join $ takeOne $ return (appendEitherTree branchWP [blockedC]) : replicate 5 weaponRoom - [EndRoom] -> fmap (pure . Right) (telRoomLev 1) + [EndRoom] -> fmap (pure . UseAll) (telRoomLev 1) (SpecificRoom rt:_) -> rt (BossAno cr : _) -> do br <- bossRoom cr - branchRectWith . pure . fmap Left $ treeFromPost [corridor,corridor] br - (TreasureAno crs loot : _) -> branchRectWith . fmap (pure . Left) $ lootRoom crs loot + branchRectWith . pure . fmap PassDown $ treeFromPost [corridor,corridor] br + (TreasureAno crs loot : _) -> branchRectWith . fmap (pure . PassDown) $ lootRoom crs loot _ -> do w <- state $ randomR (100,400) h <- state $ randomR (200,400) - fmap (pure . Right) . randomiseOutLinks $ roomRectAutoLinks w h + fmap (pure . UseAll) . randomiseOutLinks $ roomRectAutoLinks w h diff --git a/src/Dodge/Annotation/Data.hs b/src/Dodge/Annotation/Data.hs index b34339ab3..f40e87803 100644 --- a/src/Dodge/Annotation/Data.hs +++ b/src/Dodge/Annotation/Data.hs @@ -3,6 +3,7 @@ module Dodge.Annotation.Data where import Dodge.Data import Dodge.Room +import Dodge.Tree.Compose.Data import Data.Tree import Control.Monad.State @@ -15,10 +16,10 @@ data Annotation g | FirstWeapon | EndRoom | OrAno [[Annotation g]] - | SpecificRoom (State g (Tree (Either Room Room))) + | SpecificRoom (State g (SubCompTree Room)) | BossAno Creature | TreasureAno [Creature] [Item] - | AnoApplyInt Int (Int -> State g (Tree (Either Room Room))) + | AnoApplyInt Int (Int -> State g (SubCompTree Room)) | SetLabel Int (State g Room) | UseLabel Int (State g Room) | ChainAnos [[Annotation g]] diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 2dac13a31..bca65dba7 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -53,23 +53,23 @@ initialAnoTree = padSucWithCorridors $ treeFromTrunk -- ,[Corridor] ------ ,[SpecificRoom roomCCrits] ------ ,[Corridor] ------- ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 +------ ,[SpecificRoom . pure . pure . UseAll $ roomGlassOctogon 400 ------ & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit armourChaseCrit ------ ,sPS (V2 50 25) 0 $ PutCrit armourChaseCrit ------ ,sPS (V2 50 0) 0 $ PutCrit armourChaseCrit ------ ]++) ------ ] ------- --,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 +------ --,[SpecificRoom . pure . pure . UseAll $ roomGlassOctogon 400 ------ -- & rmPS %~ ([swarmPS 0 (x,y) 0 swarmCrit | x <- [-20,-19.5.. 20] , y <- [200,202] ]++) ------ -- ] ------- ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 +------ ,[SpecificRoom . pure . pure . UseAll $ roomGlassOctogon 400 ------ & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit pistolCrit ]++) ------ ] ------ ,[Corridor] ----- --,[SpecificRoom $ pure . Right <$> twinSlowDoorChasers] ------ ,[SpecificRoom $ pure $ (pure . Right) (twinSlowDoorRoom 80 200 40)] +---- --,[SpecificRoom $ pure . UseAll <$> twinSlowDoorChasers] +----- ,[SpecificRoom $ pure $ (pure . UseAll) (twinSlowDoorRoom 80 200 40)] ----- ,[DoorAno] ------ ,[SpecificRoom $ pure . Right <$> centerVaultExplosiveExit] +----- ,[SpecificRoom $ pure . UseAll <$> centerVaultExplosiveExit] ----- ,[SpecificRoom blockedCorridor] ----- ,[OrAno [[DoorAno] ----- ,[Corridor] @@ -77,18 +77,18 @@ initialAnoTree = padSucWithCorridors $ treeFromTrunk ----- ] ----- ,[FirstWeapon] ----- ,[CorridorDebug] ------ ,[SpecificRoom $ fmap (pure . Right) randomFourCornerRoom] +----- ,[SpecificRoom $ fmap (pure . UseAll) randomFourCornerRoom] -- ,[OrAno --- [[SpecificRoom $ branchRectWith $ fmap (fmap Left) armouredChasers] +-- [[SpecificRoom $ branchRectWith $ fmap (fmap PassDown) armouredChasers] -- ,[BossAno $ addArmour launcherCrit & crHP +~ 800 -- & crState . crDropsOnDeath .~ DropSpecific [0] ] -- ] -- ] ----- ,[SpecificRoom $ fmap (pure . Right) armouredCorridor] +---- ,[SpecificRoom $ fmap (pure . UseAll) armouredCorridor] -- ,[Corridor] -- ,[TreasureAno [addArmour autoCrit,addArmour autoCrit] [launcher]] ] - $ treeFromPost [[Corridor,SpecificRoom $ fmap (pure . Right) randomFourCornerRoom]] + $ treeFromPost [[Corridor,SpecificRoom $ fmap (pure . UseAll) randomFourCornerRoom]] [EndRoom] {- | A test level tree. -} diff --git a/src/Dodge/Room/Branch.hs b/src/Dodge/Room/Branch.hs index 1b62c7aad..c10d85e2f 100644 --- a/src/Dodge/Room/Branch.hs +++ b/src/Dodge/Room/Branch.hs @@ -15,14 +15,13 @@ import Control.Monad.State import System.Random import Data.Tree -branchRectWith :: RandomGen g => State g (Tree (Either Room Room)) -> State g (Tree (Either Room Room)) +branchRectWith :: RandomGen g => State g (SubCompTree Room) -> State g (SubCompTree Room) branchRectWith t = do x <- state $ randomR (100,200) y <- state $ randomR (100,200) b <- t root <- randomiseOutLinks $ roomRectAutoLinks x y - return $ Node (Left root) [Node (Right door) [], rToL <$> treeFromTrunk [Left door] b] + return $ Node (PassDown root) [Node (UseAll door) [], rToL <$> treeFromTrunk [PassDown door] b] where - rToL :: Either a a -> Either a a - rToL (Right r) = Left r - rToL (Left r) = Left r + rToL (UseAll r) = PassDown r + rToL (PassDown r) = PassDown r diff --git a/src/Dodge/Room/RoadBlock.hs b/src/Dodge/Room/RoadBlock.hs index d2310e3f0..f0cae05fb 100644 --- a/src/Dodge/Room/RoadBlock.hs +++ b/src/Dodge/Room/RoadBlock.hs @@ -53,25 +53,25 @@ litCorridor90 = do } -- | A random length corridor with a destructible block blocking it. -longBlockedCorridor :: RandomGen g => State g (Tree (Either Room Room)) +longBlockedCorridor :: RandomGen g => State g (SubCompTree Room) longBlockedCorridor = do r <- state $ randomR (0,pi) n <- state $ randomR (0,3) let plmnts = [sPS (V2 20 40) r $ dirtPoly $ square 10 ,sPS (V2 20 15) 0 putLamp ] - sequence $ treeFromPost (replicate n $ Left <$> randomiseOutLinks corridor) - $ return $ Right $ set rmPmnts plmnts corridor + sequence $ treeFromPost (replicate n $ PassDown <$> randomiseOutLinks corridor) + $ return $ UseAll $ set rmPmnts plmnts corridor -- | A single corridor with a destructible block blocking it. -blockedCorridor :: RandomGen g => State g (Tree (Either Room Room)) +blockedCorridor :: RandomGen g => State g (SubCompTree Room) blockedCorridor = do r <- state $ randomR (0,pi) let plmnts = [sPS (V2 20 40) r $ dirtPoly $ square 10 ,spanLightI (V2 0 15) (V2 40 15) ] - sequence $ treeFromPost [] $ return $ Right $ set rmPmnts plmnts corridor + sequence $ treeFromPost [] $ return $ UseAll $ set rmPmnts plmnts corridor dirtPoly :: [Point2] -> PSType dirtPoly = PutBlock DirtBlock [1] dirtWall . reverse diff --git a/src/Dodge/Room/Room.hs b/src/Dodge/Room/Room.hs index 17d00fffe..1a3a04318 100644 --- a/src/Dodge/Room/Room.hs +++ b/src/Dodge/Room/Room.hs @@ -63,21 +63,21 @@ roomPillars = over rmLinks init $ set rmPmnts plmnts $ roomRect 240 240 2 2 f a x b y = putBlockRect a x b y g a b c d = f a b a b ++ f a b c d ++ f c d a b ++ f c d c d -branchWith :: Room -> [Tree Room] -> Tree (Either Room Room) -branchWith r ts = Node (Left r) $ return (Right door) : fmap (fmap Left) ts +branchWith :: Room -> [Tree Room] -> SubCompTree Room +branchWith r ts = Node (PassDown r) $ return (UseAll door) : fmap (fmap PassDown) ts -manyDoors :: Int -> Tree (Either Room Room) -manyDoors i = treeFromPost (replicate i (Left door)) $ Right door +manyDoors :: Int -> SubCompTree Room +manyDoors i = treeFromPost (replicate i (PassDown door)) $ UseAll door -- TODO: partially combine a room tree into a room -glassLesson :: RandomGen g => State g (Tree (Either Room Room)) +glassLesson :: RandomGen g => State g (SubCompTree Room) glassLesson = do i <- takeOne [1,2,3] - corridors <- replicateM i $ Left <$> randomiseOutLinks corridor - return $ Node (Left botRoom) [deadRoom door,uppers, treeFromPost (Left door : corridors) $ Right door] + corridors <- replicateM i $ PassDown <$> randomiseOutLinks corridor + return $ Node (PassDown botRoom) [singleUseNone door,uppers, treeFromPost (PassDown door : corridors) $ UseAll door] where - uppers = Node (Left door) [deadRoom topRoom] + uppers = Node (PassDown door) [deadRoom topRoom] botRoom = set rmPmnts botplmnts $ roomRect 200 200 1 1 topRoom = set rmPmnts topplmnts $ roomRect 200 200 1 1 botplmnts = @@ -136,13 +136,13 @@ glassSwitchBackCrits = glassSwitchBack , spNoID (PSRoomRand 1) randC1 ] ++) -miniTree2 :: RandomGen g => State g (Tree (Either Room Room)) +miniTree2 :: RandomGen g => State g (SubCompTree Room) miniTree2 = glassSwitchBackCrits >>= randomiseOutLinks >>= changeLinkTo (\p -> (sndV2 . fst) p < 70) <&> flip branchWith (replicate 3 $ treeFromPost [door,corridor] critInDeadEnd) -miniRoom3 :: RandomGen g => State g (Tree (Either Room Room)) +miniRoom3 :: RandomGen g => State g (SubCompTree Room) miniRoom3 = do w <- state $ randomR (300,400) h <- state $ randomR (300,400) @@ -178,17 +178,17 @@ 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 (Tree (Either Room Room)) +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 (Right x) xs) = Node (Right (Right x)) $ map f xs - f (Node (Left x) xs) = Node (Left (Left x)) $ map f xs - g (Node (Right x) []) = Node (Right x) [] - g (Node (Right x) xs) = Node (Left x) $ map g xs + 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 roomCenterPillar :: RandomGen g => State g Room @@ -260,7 +260,7 @@ randFirstWeapon = do ++ [launcher] -weaponEmptyRoom :: RandomGen g => State g (Tree (Either Room Room)) +weaponEmptyRoom :: RandomGen g => State g (SubCompTree Room) weaponEmptyRoom = do w <- state $ randomR (220,300) h <- state $ randomR (220,300) @@ -271,12 +271,12 @@ weaponEmptyRoom = do --,sPS (V2 (w/2) (h/2)) 0 putLamp ,mntLightLnkCond unusedLnkToPS ] - treeFromTrunk [Left corridor] + treeFromTrunk [PassDown corridor] <$> ((fmap connectRoom . randomiseOutLinks) =<< changeLinkTo ((\p -> dist p (V2 (w/2) 0) < 10) . fst) (set rmPmnts plmnts $ roomRect w h 2 2) ) -weaponUnderCrits :: RandomGen g => State g (Tree (Either Room Room)) +weaponUnderCrits :: RandomGen g => State g (SubCompTree Room) weaponUnderCrits = do let plmnts = [sPS (V2 20 0) 0 $ RandPS randFirstWeapon @@ -284,18 +284,18 @@ weaponUnderCrits = do ,sPS (V2 20 20) (negate $ pi/2) randC1 ] let continuationRoom = treeFromTrunk - [Left corridorN,Left corridorN] + [PassDown corridorN,PassDown corridorN] (connectRoom (set rmPmnts plmnts corridorN)) rcp <- roomCenterPillar deadEndRoom' <- takeOne [roomPillars,rcp] - junctionRoom <- takeOne [Left tEast,Left tWest] - return $ treeFromTrunk [Left corridorN,Left corridorN] + junctionRoom <- takeOne [PassDown tEast,PassDown tWest] + return $ treeFromTrunk [PassDown corridorN,PassDown corridorN] $ Node junctionRoom [continuationRoom ,deadRoom deadEndRoom' ] -weaponBehindPillar :: RandomGen g => State g (Tree (Either Room Room)) +weaponBehindPillar :: RandomGen g => State g (SubCompTree Room) weaponBehindPillar = do wpa <- state $ randomR (0,pi) wpos <- takeOne [V2 120 160,V2 80 40,V2 160 40,V2 220 200,V2 40 200,V2 120 35] @@ -307,12 +307,12 @@ weaponBehindPillar = do ] rcp <- roomCenterPillar return $ treeFromTrunk - [Left corridor - ,Left $ over rmLinks tail $ over rmPmnts (++ plmnts1) rcp + [PassDown corridor + ,PassDown $ over rmLinks tail $ over rmPmnts (++ plmnts1) rcp ] (connectRoom $ set rmPmnts [sPS (V2 20 60) (negate $ pi/2) randC1] corridorN) -weaponBetweenPillars :: RandomGen g => State g (Tree (Either Room Room)) +weaponBetweenPillars :: RandomGen g => State g (SubCompTree Room) weaponBetweenPillars = do wpPos <- takeOne [V2 x y | x <- [20,120,220], y <- [20,120,220]] (ps,_) <- takeNMore 2 ([], [V2 x y | x <- [20,220], y <- [20,120,220]]) @@ -328,7 +328,7 @@ weaponBetweenPillars = do where f (_,a) = a == 0 -weaponLongCorridor :: RandomGen g => State g (Tree (Either Room Room)) +weaponLongCorridor :: RandomGen g => State g (SubCompTree Room) weaponLongCorridor = do root <- takeOne [tEast, tWest] connectingRoom <- takeOne @@ -336,9 +336,9 @@ weaponLongCorridor = do ] i1 <- state $ randomR (2,5) i2 <- state $ randomR (2,5) - let branch1 = treeFromTrunk (replicate i1 $ Left corridorN) (connectRoom $ putCrs connectingRoom) - let branch2 = treeFromTrunk (replicate i2 $ Left corridorN) (deadRoom $ putWp corridor) - return $ Node (Left root) [branch1,branch2] + let branch1 = treeFromTrunk (replicate i1 $ PassDown corridorN) (connectRoom $ putCrs connectingRoom) + let branch2 = treeFromTrunk (replicate i2 $ PassDown corridorN) (deadRoom $ 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 ]) putWp = set rmPmnts [sPS (V2 20 60) 0 $ RandPS randFirstWeapon ,spanLightI (V2 0 40) (V2 40 40)] @@ -358,7 +358,7 @@ deadEndRoom = defaultRoom where lnks = [(V2 0 30 ,0) ] {- A random Either tree with a weapon and melee monster challenge. -} -weaponRoom :: RandomGen g => State g (Tree (Either Room Room)) +weaponRoom :: RandomGen g => State g (SubCompTree Room) weaponRoom = join $ takeOne [ weaponEmptyRoom , weaponUnderCrits @@ -487,7 +487,7 @@ pistolerRoom = pillarGrid ] ++) -shootingRange :: RandomGen g => State g (Tree (Either Room Room)) +shootingRange :: RandomGen g => State g (SubCompTree Room) shootingRange = do rm1 <- shootersRoom1 >>= changeLinkTo (\(V2 _ y,_) -> y < 40) >>= changeLinkFrom (\(V2 _ y,r) -> y > 200 && r /= 0) @@ -496,20 +496,20 @@ shootingRange = do rm3 <- shootersRoom >>= changeLinkTo (\(V2 x y,_) -> y < 10 && x > 20 && x < 180) >>= changeLinkFrom (\(_,r) -> r == 0) return $ treeFromPost - [Left rm1 - ,Left $ roomPadCut (rectNSWE 40 (-40) (-80) 80) (V2 0 20) + [PassDown rm1 + ,PassDown $ roomPadCut (rectNSWE 40 (-40) (-80) 80) (V2 0 20) & rmPmnts %~ (spanLightI (V2 (-80) 10) (V2 80 10) :) - ,Left rm2 - ,Left $ roomPadCut (rectNSWE 40 (-40) (-80) 80) (V2 0 20) + ,PassDown rm2 + ,PassDown $ roomPadCut (rectNSWE 40 (-40) (-80) 80) (V2 0 20) & rmPmnts %~ (spanLightI (V2 (-80) 10) (V2 80 10) :) ] - (Right rm3) + (UseAll rm3) -spawnerRoom :: RandomGen g => State g (Tree (Either Room Room)) +spawnerRoom :: RandomGen g => State g (SubCompTree Room) spawnerRoom = do x <- state $ randomR (250,300) y <- state $ randomR (300,400) roomWithSpawner <- roomC x y <&> rmPmnts %~ (spNoID (PSRoomRand 0) (PutCrit spawnerCrit) :) aRoom <- airlock - return $ treeFromTrunk [Left aRoom,Left corridor] $ connectRoom roomWithSpawner + return $ treeFromTrunk [PassDown aRoom,PassDown corridor] $ connectRoom roomWithSpawner diff --git a/src/Dodge/Room/RunPast.hs b/src/Dodge/Room/RunPast.hs index c082b5878..aa611e3a3 100644 --- a/src/Dodge/Room/RunPast.hs +++ b/src/Dodge/Room/RunPast.hs @@ -49,7 +49,7 @@ critRoom = corridorWallN { _rmRandPSs = [psRandRanges (15,25) (30,45) (pi,2*pi)] } -runPastRoom :: RandomGen g => Int -> State g (Tree (Either Room Room)) +runPastRoom :: RandomGen g => Int -> State g (SubCompTree Room) runPastRoom i = do h <- state $ randomR (200,400::Float) theedgetest <- takeOne [horEdgeTest (<1), horEdgeTest (>39)] @@ -71,8 +71,8 @@ runPastRoom i = do } switchdoor = switchDoorRoom & rmTakeFrom ?~ i n = length $ filter theedgetest $ _rmLinks cenroom - controom = treeFromPost [Left switchdoor,Left linkcor] (Right door) - critrooms :: [Tree (Either Room Room)] - critrooms = treeFromPost [Left switchdoor] (Left critroom) : - replicate (n-2) (treeFromPost [Left switchdoor] (Left linkcor)) - return $ Node (Left cenroom) (controom : critrooms ++ [return $ Left aswitchroom]) + controom = treeFromPost [PassDown switchdoor,PassDown linkcor] (UseAll door) + critrooms :: [SubCompTree Room] + critrooms = treeFromPost [PassDown switchdoor] (PassDown critroom) : + replicate (n-2) (treeFromPost [PassDown switchdoor] (PassDown linkcor)) + return $ Node (PassDown cenroom) (controom : critrooms ++ [return $ PassDown aswitchroom]) diff --git a/src/Dodge/Room/Start.hs b/src/Dodge/Room/Start.hs index b1100c7da..97c8a6ce2 100644 --- a/src/Dodge/Room/Start.hs +++ b/src/Dodge/Room/Start.hs @@ -32,22 +32,22 @@ import Control.Lens import System.Random --import qualified Data.IntMap.Strict as IM -minigunfakeout :: RandomGen g => State g (Tree (Either Room Room)) +minigunfakeout :: RandomGen g => State g (SubCompTree Room) minigunfakeout = do rcol <- rezColor ncor <- state $ randomR (0,2) roomwithmini <- randomiseAllLinks $ roomRectAutoLinks 150 150 & rmPmnts %~ (plRRpt 0 (PutFlIt miniGun):) - randcors <- replicateM ncor $ (fmap Left . randomiseOutLinks) corridor - return $ ([Left $ rezBox rcol - ,Left door - ,Left roomwithmini - ,Left door + randcors <- replicateM ncor $ (fmap PassDown . randomiseOutLinks) corridor + return $ ([PassDown $ rezBox rcol + ,PassDown door + ,PassDown roomwithmini + ,PassDown door ] ++ randcors - ++ [Left $ corridor & rmPmnts %~ ( plRRpt 0 (PutFlIt shrinkGun) :) - ,Left keyholeCorridor,Left corridor]) - `treeFromPost` Right door + ++ [PassDown $ corridor & rmPmnts %~ ( plRRpt 0 (PutFlIt shrinkGun) :) + ,PassDown keyholeCorridor,PassDown corridor]) + `treeFromPost` UseAll door centralLasTurret :: Room centralLasTurret = roomNgon 8 200 & rmPmnts .~ @@ -68,21 +68,21 @@ centralLasTurret = roomNgon 8 200 & rmPmnts .~ upf trid mc w | _mcSensor mc > 900 = w & triggers . ix trid .~ const True | otherwise = w -lasSensorTurretTest :: RandomGen g => Int -> State g (Tree (Either Room Room)) +lasSensorTurretTest :: RandomGen g => Int -> State g (SubCompTree Room) lasSensorTurretTest n = do cenroom <- randomiseOutLinks $ centralLasTurret {_rmLabel = Just n} let doorroom = switchDoorRoom {_rmTakeFrom = Just n} - return $ treeFromPost [Left door,Left cenroom,Left doorroom] (Right door) + return $ treeFromPost [PassDown door,PassDown cenroom,PassDown doorroom] (UseAll door) -rezThenLasTurret :: RandomGen g => State g (Tree (Either Room Room)) +rezThenLasTurret :: RandomGen g => State g (SubCompTree Room) rezThenLasTurret = do rbox <- rezBoxStart cenroom <- randomiseOutLinks $ centralLasTurret {_rmLabel = Just 0} let doorroom = switchDoorRoom {_rmTakeFrom = Just 0} - contTree = treeFromPost [Left cenroom,Left doorroom] (Right door) + contTree = treeFromPost [PassDown cenroom,PassDown doorroom] (UseAll door) return $ rbox `appendEitherTree` [contTree] -startRoom :: RandomGen g => Int -> State g (Tree (Either Room Room)) +startRoom :: RandomGen g => Int -> State g (SubCompTree Room) startRoom i = join $ takeOne [ minigunfakeout , rezBoxesWp @@ -92,16 +92,16 @@ startRoom i = join $ takeOne , runPastStart i ] -runPastStart :: RandomGen g => Int -> State g (Tree (Either Room Room)) +runPastStart :: RandomGen g => Int -> State g (SubCompTree Room) runPastStart i = do s <- rezBoxStart rp <- runPastRoom i return $ s `appendEitherTree` [rp] -rezBoxStart :: RandomGen g => State g (Tree (Either Room Room)) +rezBoxStart :: RandomGen g => State g (SubCompTree Room) rezBoxStart = do ls <- rezColor - return $ treeFromPost [Left $ rezBox ls] (Right door) + return $ treeFromPost [PassDown $ rezBox ls] (UseAll door) rezBox :: LightSource -> Room rezBox ls = roomRect 40 60 1 1 @@ -131,28 +131,28 @@ wpAdd wp = rmPmnts %~ f g x = x & plIDCont .~ flickerMod -rezBoxesThenWeaponRoom :: RandomGen g => State g (Tree (Either Room Room)) +rezBoxesThenWeaponRoom :: RandomGen g => State g (SubCompTree Room) rezBoxesThenWeaponRoom = do rboxes <- rezBoxes wroom <- weaponRoom return $ rboxes `appendEitherTree` [wroom] -rezBoxThenWeaponRoom :: RandomGen g => State g (Tree (Either Room Room)) +rezBoxThenWeaponRoom :: RandomGen g => State g (SubCompTree Room) rezBoxThenWeaponRoom = do rcol <- rezColor - treeFromTrunk [Left $ rezBox rcol,Left door] <$> weaponRoom + treeFromTrunk [PassDown $ rezBox rcol,PassDown door] <$> weaponRoom -rezBoxesWpCrit :: RandomGen g => State g (Tree (Either Room Room)) +rezBoxesWpCrit :: RandomGen g => State g (SubCompTree Room) rezBoxesWpCrit = do w <- state $ randomR (200,400) h <- state $ randomR (40,40) thecol <- rezColor theweapon <- randBlockBreakWeapon let bottomEdgeTest (V2 _ y,_) = y < 1 - bottomLeftTest (V2 x y,_) = y < 1 && x < 21 + bottomPassDownTest (V2 x y,_) = y < 1 && x < 21 aroom = rezInvBox thecol centralRoom <- filterSortOutLinksOn bottomEdgeTest ((\(V2 a b) -> (b,a)) . fst) <$> - (randomiseOutLinks =<< changeLinkTo bottomLeftTest + (randomiseOutLinks =<< changeLinkTo bottomPassDownTest ((roomRectAutoLinks w h) {_rmPmnts = []})) let n = length $ filter bottomEdgeTest $ _rmLinks centralRoom i <- state $ randomR (0,n-3) @@ -162,15 +162,15 @@ rezBoxesWpCrit = do $ insertAt i (wpAdd theweapon aroom) $ insertAt j (crAdd aroom) $ replicate (n-3) aroom - return $ treeFromTrunk [Left $ rezBox thecol - , Left door + return $ treeFromTrunk [PassDown $ rezBox thecol + , PassDown door ] - (Node (Left centralRoom) (rezrooms ++ [onwardtree blcor])) + (Node (PassDown centralRoom) (rezrooms ++ [onwardtree blcor])) where - adddoor rm = treeFromPost [Left door] (Left rm) - onwardtree blcor = treeFromPost [Left door] (Right blcor) + adddoor rm = treeFromPost [PassDown door] (PassDown rm) + onwardtree blcor = treeFromPost [PassDown door] (UseAll blcor) -rezBoxesWp :: RandomGen g => State g (Tree (Either Room Room)) +rezBoxesWp :: RandomGen g => State g (SubCompTree Room) rezBoxesWp = do w <- state $ randomR (100,400) h <- state $ randomR (40,40) @@ -185,31 +185,31 @@ rezBoxesWp = do let rezrooms = map adddoor $ wpAdd theweapon aroom : replicate (n-2) aroom centralRoom' <- changeLinkFrom bottomEdgeTest centralRoom - return $ treeFromTrunk [Left $ rezBox thecol - , Left door + return $ treeFromTrunk [PassDown $ rezBox thecol + , PassDown door ] - (Node (Left centralRoom') (rezrooms ++ [onwardtree blcor])) + (Node (PassDown centralRoom') (rezrooms ++ [onwardtree blcor])) where - adddoor rm = treeFromPost [Left door] (Left rm) - onwardtree blcor = treeFromPost [Left door] (Right blcor) + adddoor rm = treeFromPost [PassDown door] (PassDown rm) + onwardtree blcor = treeFromPost [PassDown door] (UseAll blcor) -rezBoxes :: RandomGen g => State g (Tree (Either Room Room)) +rezBoxes :: RandomGen g => State g (SubCompTree Room) rezBoxes = do w <- state $ randomR (100,400) h <- state $ randomR (40,40) thecol <- rezColor let bottomEdgeTest (V2 _ y,_) = y < 1 - dbox = treeFromPost [Left door] (Left $ rezInvBox thecol) + dbox = treeFromPost [PassDown door] (PassDown $ rezInvBox thecol) centralRoom <- randomiseOutLinks =<< changeLinkTo bottomEdgeTest ((roomRectAutoLinks w h) {_rmPmnts = []}) let n = length $ filter bottomEdgeTest $ _rmLinks centralRoom centralRoom' <- changeLinkFrom bottomEdgeTest centralRoom - return $ treeFromTrunk [Left $ rezBox thecol - , Left door + return $ treeFromTrunk [PassDown $ rezBox thecol + , PassDown door ] - (Node (Left centralRoom') (replicate (n-1) dbox ++ [Node (Right door) []])) + (Node (PassDown centralRoom') (replicate (n-1) dbox ++ [Node (UseAll door) []])) -startRoom' :: RandomGen g => State g (Tree (Either Room Room)) +startRoom' :: RandomGen g => State g (SubCompTree Room) startRoom' = do w <- state $ randomR (100,400) h <- state $ randomR (200,400) @@ -224,7 +224,7 @@ startRoom' = do , sps0 $ PutForeground $ colorSH orange $ pipePP 2 (V3 50 50 25) (V3 50 120 25) ] thecol <- rezColor - treeFromPost [Left $ rezBox thecol, Left door] . Right + treeFromPost [PassDown $ rezBox thecol, PassDown door] . UseAll <$> randomiseOutLinks (shiftRoomBy (V2 (-20) (-20),0) ( roomRectAutoLinks w h & rmPmnts %~ (plmnts ++) diff --git a/src/Dodge/Tree/Compose.hs b/src/Dodge/Tree/Compose.hs index 7b7150b8b..fa4fa7f06 100644 --- a/src/Dodge/Tree/Compose.hs +++ b/src/Dodge/Tree/Compose.hs @@ -6,7 +6,6 @@ module Dodge.Tree.Compose , connectTrunk , deadRoom , linkEitherTrees - , expandTree , singleUseAll , singleUseNone @@ -26,51 +25,71 @@ expandTree (Node root extChildren) = case root of Node (SplitDown x) xs -> Node x $ map expandTree $ zipWith Node xs $ map (:[]) extChildren ++ repeat [] --- | '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 +expandTreeBy + :: (a -> SubCompTree b) -- ^ Node function -> Tree a -- ^ Base tree -> Tree b -expandTreeBy f (Node x []) = fmap removeEither (f x) +expandTreeBy f (Node x []) = fmap _unCompose (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) + 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 +-- :: 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 :: [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 +--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 :: a -> Tree (Either a a) +--connectRoom r = Node (Right r) [] + +connectRoom = singleUseAll singleUseAll :: a -> Tree (ComposingNode a) singleUseAll x = Node (UseAll x) [] @@ -78,10 +97,11 @@ 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 :: 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) @@ -90,8 +110,10 @@ useAllAtEnd tree = case tree of {- | Make a singleton dead end of an Either Tree. -} -deadRoom :: a -> Tree (Either a a) -deadRoom r = Node (Left r) [] +--deadRoom :: a -> Tree (Either a a) +--deadRoom r = Node (Left r) [] + +deadRoom = singleUseNone singleUseNone :: a -> SubCompTree a singleUseNone x = Node (UseNone x) []