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

Start creating explicit tutorial map

Browse Source
This commit is contained in:
justin
2025-08-21 16:31:04 +01:00
parent 21460ceaa8
commit befe24e038
15 changed files with 272 additions and 161 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Annotation.hs
+24 -24
View File
@@ -1,37 +1,37 @@
--{-# LANGUAGE TupleSections #-}
{- | Annotating tree structures with desired properties for rooms. -}
module Dodge.Annotation
( module Dodge.Annotation.Data
, module Dodge.Annotation
) where
import Dodge.Cleat
import RandomHelp
import Dodge.Tree
import Dodge.Data.GenWorld
import Dodge.Annotation.Data
import LensHelp
--import Control.Lens
-- | Annotating tree structures with desired properties for rooms.
module Dodge.Annotation (
module Dodge.Annotation.Data,
module Dodge.Annotation,
) where
import Data.Maybe
import Dodge.Annotation.Data
import Dodge.Cleat
--import Dodge.Data.GenWorld
import Dodge.Tree
import LensHelp
import RandomHelp
annoToRoomTree :: Annotation -> State (StdGen,Int) MTRS
annoToRoomTree :: Annotation -> State (StdGen, Int) MTRS
annoToRoomTree an = case an of
AnTree t -> zoom _1 t
AnRoom r -> MTree "SingleRoom" . NodeTree . pure . (rmClusterStatus . csLinks . at OnwardCluster ?~ ()) <$> zoom _1 r <*> return []
AnTree t -> zoom _1 t
-- AnRoom r -> MTree "SingleRoom" . NodeTree . pure . (rmClusterStatus . csLinks . at OnwardCluster ?~ ()) <$> zoom _1 r <*> return []
OnwardList ans -> do
mts <- mapM annoToRoomTree ans
return $ foldr1 attachOnward' mts
IntAnno f -> do
(g,i) <- get
put (g,i+1)
IntAnno f -> do
(g, i) <- get
put (g, i + 1)
annoToRoomTree (f i)
ModifyTree f a -> f <$> annoToRoomTree a
PassthroughLockKeyLists ls ks i -> zoom _1 $ do
(functionlockroom,randomitemidentity) <- takeOne ls
(functionlockroom, randomitemidentity) <- takeOne ls
lr <- functionlockroom i
ii <- randomitemidentity
keyroom <- fromJust $ lookup ii ks
return $ MTree ("PassthroughLockKeyLists-"++show ii)
(NodeMTree $ MTree "RassThroughLockKeyLists" (NodeMTree lr) [MBranch (toLabel i) keyroom])
[]
return $
MTree
("PassthroughLockKeyLists-" ++ show ii)
(NodeMTree $ MTree "RassThroughLockKeyLists" (NodeMTree lr) [MBranch (toLabel i) keyroom])
[]
src/Dodge/Annotation/Data.hs
+2 -3
View File
@@ -12,10 +12,9 @@ import System.Random
type MTRS = MetaTree Room String
data Annotation
= ModifyTree (MetaTree Room String -> MetaTree Room String) Annotation
| OnwardList [Annotation]
= OnwardList [Annotation]
| IntAnno (Int -> Annotation)
| AnRoom (State StdGen Room)
-- | AnRoom (State StdGen Room)
| AnTree (State StdGen (MetaTree Room String))
| PassthroughLockKeyLists
[(Int -> State StdGen (MetaTree Room String), State StdGen ItemType)]
src/Dodge/Base/NewID.hs
+1 -4
View File
@@ -4,10 +4,7 @@ import LensHelp
-- | generalised way of putting a new item into a lensed intmap, returning the
-- new index as well
plNewID :: ALens' b (IM.IntMap a)
-> a
-> b
-> (Int,b)
plNewID :: ALens' b (IM.IntMap a) -> a -> b -> (Int,b)
plNewID l x w = (i,w & l #%~ IM.insert i x)
where
i = IM.newKey $ w ^# l
src/Dodge/Floor.hs
+9 -1
View File
@@ -1,8 +1,10 @@
-- | The tree of rooms that make up a level.
module Dodge.Floor (
initialRoomTree,
tutRoomTree,
) where
import Dodge.Room.Tutorial
import Data.List (intersperse)
import Dodge.Annotation
import Dodge.Cleat
@@ -20,6 +22,9 @@ initialRoomTree :: State (StdGen, Int) (MetaTree Room String)
initialRoomTree = annoToRoomTree initialAnoTree
--initialRoomTree = annoToRoomTree startWorldTreeTest
tutRoomTree :: State (StdGen, Int) (MetaTree Room String)
tutRoomTree = annoToRoomTree tutAnoTree
--startWorldTreeTest :: Annotation
--startWorldTreeTest =
-- OnwardList $
@@ -43,7 +48,7 @@ initialAnoTree =
-- , AnRoom $ tanksRoom [] []
-- , AnRoom $ roomCCrits 0
-- , AnRoom $ return airlock0
AnRoom slowDoorRoom
anRoom slowDoorRoom
, -- , AnRoom $ roomCCrits 10
-- , AnTree firstBreather
-- , AnTree $ telRoomLev 1 >>= rToOnward "telRoomLev" . pure . cleatOnward
@@ -113,3 +118,6 @@ initialAnoTree =
-- ,[Corridor]
AnTree $ randomFourCornerRoom [] >>= rToOnward "randomFourCornerRoom" . pure . cleatOnward
]
anRoom :: StateT StdGen Identity Room -> Annotation
anRoom t = AnTree $ tToBTree "anRoom" . return . cleatOnward <$> t
src/Dodge/LevelGen.hs
+5 -4
View File
@@ -50,16 +50,17 @@ layoutLevelFromSeed i seed = do
putStrLnAppend "log/attemptedSeeds" $ "Generating level with seed " ++ show seed
appendFile "log/attemptedSeeds" "\n"
let g = mkStdGen seed
let treecluster = evalState initialRoomTree (g, 0)
let treecluster = evalState tutRoomTree (g, 0)
let labts = decomposeSelfTree $ numSelfTree $ combineTree _rmName treecluster
appendFile "log/treeCluster" ("Seed: " ++ show seed ++ "\n")
putStrLn "MetaTree clusters:"
mapM_ (putStrLnAppend "log/treeCluster" . smallDrawTree . fmap showIntsString) labts
let tc = composeTree treecluster
let rmtree = inorderNumberTree tc
putStrLn "Room layout (compact): "
putStrLn $ compactDrawTree $ fmap (show . snd) rmtree
appendFile "log/aGeneratedRoomLayout" ("Seed: " ++ show seed ++ "\n")
putStrLnAppend "log/aGeneratedRoomLayout" "Room layout (compact): "
putStrLnAppend "log/aGeneratedRoomLayout" $ compactDrawTree $ fmap (show . snd) rmtree
let nameshow (r, rid) = _rmName r ++ "-" ++ show rid
appendFile "log/aGeneratedRoomLayout" ("Seed: " ++ show seed)
putStrLnAppend "log/aGeneratedRoomLayout" "Layout with room names:"
putStrLnAppend "log/aGeneratedRoomLayout" $ smallDrawTree $ fmap nameshow rmtree
mrs <- positionRoomsFromTree rmtree
src/Dodge/Placement/Instance/Terminal.hs
+22 -3
View File
@@ -1,9 +1,11 @@
module Dodge.Placement.Instance.Terminal (
putMessageTerminal,
putImmediateMessageTerminal,
putTerminal,
terminalColor,
) where
import Dodge.WorldEffect
import Color
import Data.Maybe
import Dodge.Data.GenWorld
@@ -13,8 +15,14 @@ import Dodge.SoundLogic
import Geometry
import LensHelp
putTerminal :: Color -> Machine -> Terminal -> Placement
putTerminal col mc tm =
putTerminalImediateAccess :: Color -> Machine -> Terminal -> Placement
putTerminalImediateAccess = putTerminalFull f
where
f tmpl _ _ = Just $ sps0 $ PutWorldUpdate $ const $ accessTerminal (tmpl ^?! plMID . _Just)
putTerminalFull ::(Placement -> Placement -> Placement -> Maybe Placement) -> Color -> Machine -> Terminal ->
Placement
putTerminalFull f col mc tm =
ps0PushPS (PutTerminal (tm & tmExternalColor .~ col)) $
\tmpl -> Just $
ps0PushPS (PutButton defaultButton) $
@@ -27,7 +35,7 @@ putTerminal col mc tm =
)
defaultSensorWall
)
$ \mcpl -> Just $ sps0 $ PutWorldUpdate $ const (setids tmpl btpl mcpl)
$ \mcpl -> Just $ pt0 (PutWorldUpdate $ const (setids tmpl btpl mcpl)) (\_ -> f tmpl btpl mcpl)
where
setids tmpl btpl mcpl w =
w
@@ -40,6 +48,9 @@ putTerminal col mc tm =
btid = fromJust (_plMID btpl)
mcid = fromJust (_plMID mcpl)
putTerminal :: Color -> Machine -> Terminal -> Placement
putTerminal = putTerminalFull (\_ _ _ -> Nothing)
putMessageTerminal :: Color -> Terminal -> Placement
putMessageTerminal col =
putTerminal col $
@@ -48,5 +59,13 @@ putMessageTerminal col =
& mcType .~ McTerminal
& mcHP .~ 100
putImmediateMessageTerminal :: Color -> Terminal -> Placement
putImmediateMessageTerminal col =
putTerminalImediateAccess col $
defaultMachine
& mcColor .~ col
& mcType .~ McTerminal
& mcHP .~ 100
terminalColor :: Color
terminalColor = dark magenta
src/Dodge/Render/HUD.hs
+1 -1
View File
@@ -380,7 +380,7 @@ drawTerminalDisplay cfig tm =
TerminalTextInput s ->
(++ [(getPromptTM ++ s ++ [cFilledRect], white)])
TerminalPressTo s ->
(++ [(getPromptTM ++ "PRESS TO " ++ s, white)])
(++ [("<" ++ s ++ ">", white)])
-- | hasfoc = clockCycle 10 (V.fromList [[cFilledRect] , "."]) w
src/Dodge/Room/RezBox.hs
+41 -36
View File
@@ -1,11 +1,16 @@
module Dodge.Room.RezBox where
module Dodge.Room.RezBox (
rezBox,
rezBoxesWpCrit,
rezColor,
rezBoxes,
rezBox',
) where
import Dodge.Default.Terminal
import Dodge.Terminal
import Control.Monad
import qualified Data.Set as S
import Dodge.Cleat
import Dodge.Data.GenWorld
import Dodge.Default.Terminal
import Dodge.Item.Random
import Dodge.LevelGen.PlacementHelper
import Dodge.LightSource
@@ -16,6 +21,7 @@ import Dodge.Room.Link
import Dodge.Room.Procedural
import Dodge.Room.RoadBlock
import Dodge.RoomLink
import Dodge.Terminal
import Dodge.Tree
import Geometry
import LensHelp
@@ -25,18 +31,17 @@ import RandomHelp
rezBox :: LightSource -> Room
rezBox ls =
roomRect 40 60 1 1
& rmPmnts .~ [sPS (V2 20 1) 0 $ PutLS ls
, putMessageTerminal terminalColor (defaultTerminal & tmBootLines .~ makeTermPara s <> tlSetStatus (TerminalPressTo "QUIT") <> tlDoEffect TmWdWdDeactivateTerminal)
& plSpot .~ PS (V2 20 0) 0
]
& rmPmnts
.~ [ sPS (V2 20 1) 0 $ PutLS ls
, putMessageTerminal terminalColor (defaultTerminal & tmBootLines .~ makeTermPara s <> tlSetStatus (TerminalPressTo "QUIT") <> tlDoEffect TmWdWdDeactivateTerminal)
& plSpot .~ PS (V2 20 0) 0
]
& restrictInLinks (\(V2 _ h, _) -> h < 1)
& restrictOutLinks (\(V2 _ h, _) -> h > 59)
& rmName .~ "rezBox"
where
s = "RESPAWN POINT SET AT THIS LOCATION."
tutorialMessage1 :: String
tutorialMessage1 = "SYNTHESIS SUCCESSFUL. MOVEMENT TEST 1 INITIATED [WASD]. INTERACTION TEST 1 IN QUEUE [SPACE]."
rezBox' :: RandomGen g => State g (MetaTree Room String)
rezBox' = do
@@ -48,39 +53,39 @@ rezBox' = do
, cleatOnward door
]
rezBoxesWp :: RandomGen g => State g (Tree Room)
rezBoxesWp = do
w <- state $ randomR (100, 400)
h <- state $ randomR (40, 40)
theweapon <- randBlockBreakWeapon
thecol <- rezColor
let aroom = rezInvBox thecol -- & rmConnectsTo .~ S.singleton (OnEdge North)
let isnorth = S.member (OnEdge North) . _rlType
centralRoom <-
shuffleLinks $
(roomRectAutoLinks w h){_rmPmnts = []}
& rmLinks %~ setLinkType InLink isnorth
onwardpassage <- shootOutPassage
let n = length $ getLinksOfType (OnEdge North) $ _rmLinks centralRoom
let rezrooms =
map adddoor $
wpAdd theweapon aroom : replicate (n -2) aroom
return $
treeFromTrunk [rezBox thecol, door] $
Node centralRoom (rezrooms ++ [onwardpassage])
where
adddoor rm = treeFromPost [connectsToNorth door] rm
connectsToNorth = rmConnectsTo .~ S.member (OnEdge North)
--rezBoxesWp :: RandomGen g => State g (Tree Room)
--rezBoxesWp = do
-- w <- state $ randomR (100, 400)
-- h <- state $ randomR (40, 40)
-- theweapon <- randBlockBreakWeapon
-- thecol <- rezColor
-- let aroom = rezInvBox thecol -- & rmConnectsTo .~ S.singleton (OnEdge North)
-- let isnorth = S.member (OnEdge North) . _rlType
-- centralRoom <-
-- shuffleLinks $
-- (roomRectAutoLinks w h){_rmPmnts = []}
-- & rmLinks %~ setLinkType InLink isnorth
-- onwardpassage <- shootOutPassage
-- let n = length $ getLinksOfType (OnEdge North) $ _rmLinks centralRoom
-- let rezrooms =
-- map adddoor $
-- wpAdd theweapon aroom : replicate (n -2) aroom
-- return $
-- treeFromTrunk [rezBox thecol, door] $
-- Node centralRoom (rezrooms ++ [onwardpassage])
-- where
-- adddoor rm = treeFromPost [connectsToNorth door] rm
-- connectsToNorth = rmConnectsTo .~ S.member (OnEdge North)
maybeBlockedPassage :: RandomGen g => State g (Tree Room)
maybeBlockedPassage =
fmap (pure . cleatOnward) $
join $ takeOne [return corridor, blockedCorridorCloseBlocks]
shootOutPassage :: RandomGen g => State g (Tree Room)
shootOutPassage =
fmap (pure . cleatOnward) $
join $ takeOne [blockedCorridorCloseBlocks]
--shootOutPassage :: RandomGen g => State g (Tree Room)
--shootOutPassage =
-- fmap (pure . cleatOnward) $
-- join $ takeOne [blockedCorridorCloseBlocks]
rezBoxesWpCrit :: RandomGen g => State g (Tree Room)
rezBoxesWpCrit = do
src/Dodge/Room/Start.hs
+2 -1
View File
@@ -5,6 +5,7 @@ module Dodge.Room.Start (
randomChallenges,
) where
import Dodge.Room.RezBox
import Dodge.Item.Held.Cane
import Dodge.Item.Held.Launcher
import Dodge.Cleat
@@ -14,7 +15,7 @@ import Dodge.Room.Containing
import Dodge.Room.Corridor
import Dodge.Room.Door
import Dodge.Room.Link
import Dodge.Room.RezBox
--import Dodge.Room.RezBox
import Dodge.Room.Room
import Dodge.Room.RunPast
import Dodge.Tree
src/Dodge/Room/Tutorial.hs
+68
View File
@@ -0,0 +1,68 @@
module Dodge.Room.Tutorial (tutAnoTree) where
import Dodge.Room.Room
import Dodge.Annotation.Data
import Dodge.Room.Link
import Dodge.Room.Ngon
import Dodge.Room.Door
import TreeHelp
import Dodge.Tree.Compose
import Dodge.Room.RezBox
--import Control.Monad
--import qualified Data.Set as S
--import Dodge.Cleat
import Dodge.Data.GenWorld
import Dodge.Default.Terminal
--import Dodge.Item.Random
import Dodge.LevelGen.PlacementHelper
--import Dodge.LightSource
import Dodge.Placement.Instance
--import Dodge.Room.Corridor
--import Dodge.Room.Door
--import Dodge.Room.Link
import Dodge.Room.Procedural
--import Dodge.Room.RoadBlock
import Dodge.RoomLink
import Dodge.Terminal
--import Dodge.Tree
import Geometry
import LensHelp
--import Padding
import RandomHelp
import Data.List (intersperse)
tutAnoTree :: Annotation
tutAnoTree = OnwardList $
intersperse
(AnTree corDoor)
[AnTree tutRooms]
tutRooms :: State StdGen (MetaTree Room String)
tutRooms = do
x <- tutRezBox
ys <- toggleDoorTest
return $ tToBTree "TutStartRez" $ treePost $ [x,door] <> ys
tutRezBox :: State StdGen Room
tutRezBox = do
ls <- rezColor
return $
roomRect 40 60 1 1
& rmPmnts
.~ [ sPS (V2 20 1) 0 $ PutLS ls
, putImmediateMessageTerminal terminalColor (defaultTerminal & tmBootLines .~ makeTermPara s <> tlSetStatus (TerminalPressTo "QUIT") <> tlDoEffect TmWdWdDeactivateTerminal)
& plSpot .~ PS (V2 20 0) 0
]
& restrictInLinks (\(V2 _ h, _) -> h < 1)
& restrictOutLinks (\(V2 _ h, _) -> h > 59)
& rmName .~ "tutRezBox"
where
s = tutorialMessage1
tutorialMessage1 :: String
tutorialMessage1 = "SYNTHESIS SUCCESSFUL. MOVEMENT TEST 1 INITIATED [WASD]. INTERACTION TEST 1 IN QUEUE [SPACE]."
toggleDoorTest :: State StdGen [Room]
toggleDoorTest = do
x <- shuffleLinks $ roomNgon 6 100
return [x,door]
src/Dodge/Terminal.hs
+2 -12
View File
@@ -9,7 +9,6 @@ module Dodge.Terminal (
sensorCommand,
makeColorTermLine,
makeTermPara,
-- toggleCommand,
terminalReturnEffect,
getCommands,
tabComplete,
@@ -59,7 +58,6 @@ getCommand :: World
-> Terminal -> TCom -> PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
getCommand w tm = \case
TCInfo x z -> PTE.singleton x (PTE.singleton "" (makeTermPara z))
--TCBase -> helpCommand <> quitCommand <> toggleCommands tm
TCBase -> quitCommand <> toggleCommands tm
TCDamageCommand -> damageCodeCommand w
TCSensorInfo -> sensorCommand w tm
@@ -95,7 +93,7 @@ sensorCommand w tm = PTE.singleton "SENSOR" $ fromMaybe mempty $ do
toggleCommands :: Terminal -> PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
toggleCommands tm
| null ts = mempty
| otherwise = PTE.singleton "TOGGLE" $ PTE.fromList $ fmap f $ M.toList ts
| otherwise = PTE.singleton "TOGGLE" $ PTE.fromList $ f <$> M.toList ts
where
ts = tm ^. tmToggles
f (s,x) = (s,
@@ -105,15 +103,6 @@ toggleCommands tm
(TmWdWdfromWdWd (WdWdNegateTrig $ x ^. ttTriggerID))
])
--helpCommand :: PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
--helpCommand = PTE.singleton "" (fmap makeTermPara helpStrings)
--
--helpStrings :: PTE.TrieMap Char String
--helpStrings =
-- PTE.fromList
-- [ ("", "THIS TERMINAL PROCESSES KEYBOARD INPUT. USE [RETURN] OR [LMB] TO REGISTER YOUR INPUT. AVAILABLE COMMANDS CAN BE SCROLLED THROUGH, HOLD [RMB] TO SCROLL THROUGH ARGUMENTS. USE [TAB] FOR AUTOCOMPLETE.")
-- ]
helpPara :: [TerminalLine]
helpPara = makeTermPara "THIS TERMINAL PROCESSES KEYBOARD INPUT. USE [RETURN] OR [LMB] TO REGISTER YOUR INPUT. AVAILABLE COMMANDS CAN BE SCROLLED THROUGH, HOLD [RMB] TO SCROLL THROUGH ARGUMENTS. USE [TAB] FOR AUTOCOMPLETE."
@@ -191,6 +180,7 @@ tabComplete' s' w tm = case PTE.lookup s $ getCommands w tm of
simpleTermMessage :: [String] -> Terminal
simpleTermMessage strs = defaultTerminal & tmBootLines .~ map makeTermLine strs
-- list available arguments on function input?
terminalReturnEffect :: Int -> World -> World
terminalReturnEffect tmid w = fromMaybe w $ do
tm' <- w ^? cWorld . lWorld . terminals . ix tmid
src/Dodge/WorldEffect.hs
+1 -1
View File
@@ -1,4 +1,4 @@
{-# LANGUAGE LambdaCase #-}
--{-# LANGUAGE LambdaCase #-}
module Dodge.WorldEffect (
doWdWd,