Fold in new composing room datatype
This commit is contained in:
@@ -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
|
||||
|
||||
@@ -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]]
|
||||
|
||||
+10
-10
@@ -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. -}
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
+38
-38
@@ -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
|
||||
|
||||
@@ -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])
|
||||
|
||||
+41
-41
@@ -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 ++)
|
||||
|
||||
+51
-29
@@ -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) []
|
||||
|
||||
Reference in New Issue
Block a user