justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Start to migrate all old level generation to MetaTrees

Browse Source
This commit is contained in:
justin
2022-06-12 19:31:57 +01:00
parent 617765d5d4
commit dbba78ef05
9 changed files with 57 additions and 93 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Annotation.hs
+7 -37
View File
@@ -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]
src/Dodge/Annotation/Data.hs
+2 -7
View File
@@ -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))]
src/Dodge/Floor.hs
+3 -3
View File
@@ -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
src/Dodge/Room/GlassLesson.hs
+2 -2
View File
@@ -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
src/Dodge/Room/Room.hs
+7 -21
View File
@@ -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
src/Dodge/Room/RunPast.hs
+2 -2
View File
@@ -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
src/Dodge/Room/Start.hs
+6 -9
View File
@@ -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
src/Dodge/Tree/Compose.hs
+18 -6
View File
@@ -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
src/Dodge/UseAll.hs
+10 -6
View File
@@ -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