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

Remove Annotation datatype

Browse Source
This commit is contained in:
justin
2025-09-24 10:39:34 +01:00
parent 96b95907f2
commit eb068f5335
12 changed files with 256 additions and 314 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Annotation.hs
-39
View File
@@ -1,39 +0,0 @@
--{-# LANGUAGE TupleSections #-}
-- | 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 LayoutVars MTRS
annoToRoomTree an = case an of
AnTree t -> 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
-- LayVars g i <- get
-- put $ LayVars g (i + 1)
-- annoToRoomTree (f i)
--PassthroughLockKeyLists ls ks i -> zoom lyGen $ do
PassthroughLockKeyLists ls ks -> do
i <- nextLayoutInt
(functionlockroom, randomitemidentity) <- takeOne ls
lr <- zoom lyGen $ functionlockroom i
ii <- zoom lyGen randomitemidentity
keyroom <- zoom lyGen . fromJust $ lookup ii ks
return $
MTree
("PassthroughLockKeyLists-" ++ show ii)
(NodeMTree $ MTree "RassThroughLockKeyLists" (NodeMTree lr) [MBranch (toLabel i) keyroom])
[]
src/Dodge/Annotation/Data.hs
-43
View File
@@ -1,43 +0,0 @@
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
module Dodge.Annotation.Data where
import Control.Lens
import Control.Monad.State
import Dodge.Data.GenWorld
import Dodge.Data.MetaTree
import System.Random
type MTRS = MetaTree Room String
data LayoutVars = LayVars
{ _lyGen :: StdGen
, _lyCounter :: Int
}
data Annotation
= OnwardList [Annotation]
-- | IntAnno (Int -> Annotation)
-- | AnRoom (State StdGen Room)
| AnTree (State LayoutVars (MetaTree Room String))
| PassthroughLockKeyLists
[(Int -> State StdGen (MetaTree Room String), State StdGen ItemType)]
[(ItemType, State StdGen (MetaTree Room String))]
-- Int
makeLenses ''Annotation
makeLenses ''LayoutVars
instance RandomGen LayoutVars where
genWord32 x = let (y,g) = genWord32 (x ^. lyGen)
in (y,x & lyGen .~ g)
genWord64 x = let (y,g) = genWord64 (x ^. lyGen)
in (y,x & lyGen .~ g)
split x = let (g,h) = split (x ^. lyGen) in (x & lyGen .~ g, x & lyGen .~ h)
nextLayoutInt :: State LayoutVars Int
nextLayoutInt = do
LayVars g i <- get
put $ LayVars g (i + 1)
return i
src/Dodge/Data/MetaTree.hs
+22
View File
@@ -5,6 +5,8 @@ module Dodge.Data.MetaTree where
import Control.Lens
import Data.Tree
import System.Random
import Control.Monad.State
data MetaTree a b = MTree
{_mtLabel :: b, _mtTree :: MetaNode a b, _mtBranches :: [MetaBranch a b]}
@@ -23,3 +25,23 @@ makeLenses ''MetaNode
instance Functor (MetaTree a) where
fmap f (MTree b mn bs) = MTree (f b) (mn & nodeMetaTree %~ fmap f) (map (mbTree %~ fmap f) bs)
data LayoutVars = LayVars
{ _lyGen :: StdGen
, _lyCounter :: Int
}
makeLenses ''LayoutVars
instance RandomGen LayoutVars where
genWord32 x = let (y,g) = genWord32 (x ^. lyGen)
in (y,x & lyGen .~ g)
genWord64 x = let (y,g) = genWord64 (x ^. lyGen)
in (y,x & lyGen .~ g)
split x = let (g,h) = split (x ^. lyGen) in (x & lyGen .~ g, x & lyGen .~ h)
nextLayoutInt :: State LayoutVars Int
nextLayoutInt = do
LayVars g i <- get
put $ LayVars g (i + 1)
return i
src/Dodge/Floor.hs
+34 -27
View File
@@ -4,10 +4,10 @@ module Dodge.Floor (
tutRoomTree,
) where
import Dodge.Data.MTRS
import Data.Maybe
import Dodge.Room.Tutorial
import Dodge.Annotation.Data
import Data.List (intersperse)
import Dodge.Annotation
import Dodge.Cleat
import Dodge.Creature
import Dodge.Data.GenWorld
@@ -21,26 +21,18 @@ import RandomHelp
tutRoomTree :: State LayoutVars (MetaTree Room String)
tutRoomTree = tutAnoTree
--startWorldTreeTest :: Annotation
--startWorldTreeTest =
-- OnwardList $
-- [ IntAnno $ AnTree . startRoom
-- ]
initialRoomTree :: State LayoutVars MTRS
initialRoomTree =
annoToRoomTree $
OnwardList $
foldMTRS $
intersperse
(AnTree $ zoom lyGen corDoor)
[ AnTree $ intAnno startRoom
, --IntAnno $
PassthroughLockKeyLists
(zoom lyGen corDoor)
[ intAnno startRoom
, passthroughLockKeyLists
[(sensorRoomRunPast ElectricSensor, takeOne
[-- CRAFT (ENERGYBALLCRAFT TeslaBall) ,
HELD SPARKGUN])]
itemRooms
, AnTree $ intAnno lasSensorTurretTest
, intAnno lasSensorTurretTest
, -- , AnRoom $ tanksRoom [] [] <&> rmPmnts .~ []
-- , AnRoom $ tanksRoom [] []
-- , AnRoom $ roomCCrits 0
@@ -59,21 +51,20 @@ initialRoomTree =
-- , AnTree $ tToBTree "spawners" <$> spawnerRoom
-- , AnRoom pistolerRoom
-- , AnRoom doubleCorridorBarrels
PassthroughLockKeyLists keyCardRunPastRand itemRooms
, AnTree . intAnno $ warningRooms "INVISIBLE CREATURE AHEAD"
, AnTree $
rToOnward "chaseCrit+armourChaseCrit rectRoom" .
passthroughLockKeyLists keyCardRunPastRand itemRooms
, intAnno $ warningRooms "INVISIBLE CREATURE AHEAD"
, rToOnward "chaseCrit+armourChaseCrit rectRoom" .
return . cleatOnward =<<
(roomRectAutoLinks 400 400 <&> rmPmnts
.++~ [ psPtPl anyUnusedSpot (PutCrit invisibleChaseCrit)
, psPtPl anyUnusedSpot (PutCrit armourChaseCrit)
])
, AnTree . intAnno $ fmap (tToBTree "healthTest") . healthTest
, AnTree . zoom lyGen $
, intAnno $ fmap (tToBTree "healthTest") . healthTest
, zoom lyGen $
(tanksRoom [] [] >>= rToOnward "empty tanksRoom" . pure . cleatOnward)
, PassthroughLockKeyLists lockRoomKeyItems itemRooms
, AnTree randomChallenges
, AnTree $ intAnno lasSensorTurretTest
, passthroughLockKeyLists lockRoomKeyItems itemRooms
, randomChallenges
, intAnno lasSensorTurretTest
, -- ,[AnTree $ fmap pure roomCCrits]
-- ,[AirlockAno]
-- ,[Corridor]
@@ -114,7 +105,7 @@ initialRoomTree =
-- ,[Corridor]
-- ,[TreasureAno [addArmour autoCrit,addArmour autoCrit] [launcher]]
-- ,[Corridor]
AnTree $ randomFourCornerRoom [] >>= rToOnward "randomFourCornerRoom" . pure . cleatOnward
randomFourCornerRoom [] >>= rToOnward "randomFourCornerRoom" . pure . cleatOnward
]
intAnno :: (Int -> State StdGen MTRS) -> State LayoutVars MTRS
@@ -123,5 +114,21 @@ intAnno f = do
put $ LayVars g (i+1)
zoom lyGen (f i)
anRoom :: State StdGen Room -> Annotation
anRoom t = AnTree $ zoom lyGen (tToBTree "anRoom" . return . cleatOnward <$> t)
anRoom :: State StdGen Room -> State LayoutVars MTRS
anRoom t = zoom lyGen (tToBTree "anRoom" . return . cleatOnward <$> t)
passthroughLockKeyLists ::
[(Int -> State LayoutVars (MetaTree Room String), State LayoutVars ItemType)]
-> [(ItemType, State LayoutVars (MetaTree Room String))]
-> State LayoutVars (MetaTree Room String)
passthroughLockKeyLists ls ks = do
i <- nextLayoutInt
(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])
[]
src/Dodge/LevelGen.hs
+2 -3
View File
@@ -1,6 +1,5 @@
module Dodge.LevelGen (generateWorldFromSeed) where
import Dodge.Annotation.Data
import Dodge.Layout
import Data.Preload.Render
import Control.Lens
@@ -53,8 +52,8 @@ layoutLevelFromSeed i seed = do
putStrLnAppend "log/attemptedSeeds" $ "Generating level with seed " ++ show seed
appendFile "log/attemptedSeeds" "\n"
let g = mkStdGen seed
let treecluster = evalState tutRoomTree (LayVars g 0)
--let treecluster = evalState initialRoomTree (LayVars g 0)
--let treecluster = evalState tutRoomTree (LayVars g 0)
let treecluster = evalState initialRoomTree (LayVars g 0)
let labts = decomposeSelfTree $ numSelfTree $ combineTree _rmName treecluster
appendFile "log/treeCluster" ("Seed: " ++ show seed ++ "\n")
putStrLn "MetaTree clusters:"
src/Dodge/LockAndKey.hs
+1 -1
View File
@@ -22,7 +22,7 @@ lockRoomMultiItems =
)
]
lockRoomKeyItems :: [(Int -> State StdGen (MetaTree Room String), State StdGen ItemType)]
lockRoomKeyItems :: [(Int -> State LayoutVars (MetaTree Room String), State LayoutVars ItemType)]
lockRoomKeyItems =
[ (lasCenSensEdge, takeOne [HELD RLAUNCHER, LASER, HELD SPARKGUN, HELD FLATSHIELD])
, (sensorRoomRunPast LaserSensor, return LASER)
src/Dodge/Room/Airlock.hs
-1
View File
@@ -6,7 +6,6 @@ module Dodge.Room.Airlock where
import Data.Maybe
import Control.Lens
import Control.Monad
--import Dodge.Annotation.Data
import Dodge.Data.GenWorld
import Dodge.Default.Door
import Dodge.Default.Room
src/Dodge/Room/GlassLesson.hs
+1 -1
View File
@@ -1,8 +1,8 @@
--{-# LANGUAGE TupleSections #-}
module Dodge.Room.GlassLesson where
import Dodge.Data.MTRS
import qualified Data.Set as S
import Dodge.Annotation.Data
import Dodge.Cleat
import Dodge.Creature
import Dodge.Data.GenWorld
src/Dodge/Room/LongDoor.hs
+2 -2
View File
@@ -151,7 +151,7 @@ addButtonSlowDoor x h rm = do
Nothing
col = dim $ light red
slowDoorRoom :: State StdGen Room
slowDoorRoom :: RandomGen g => State g Room
slowDoorRoom = do
x <- state $ randomR (400, 800)
y <- state $ randomR (400, 800)
@@ -168,7 +168,7 @@ slowDoorRoom = do
proom <- southPillarsRoom x y h
addButtonSlowDoor x h (proom & rmPmnts %~ (++ (crits ++ barrels)))
slowDoorRoomRunPast :: State StdGen (MetaTree Room String)
slowDoorRoomRunPast :: RandomGen g => State g (MetaTree Room String)
slowDoorRoomRunPast = do
r <- slowDoorRoom
rToOnward "slowDoorRoomRunPast" $
src/Dodge/Room/SensorDoor.hs
+1 -1
View File
@@ -1,8 +1,8 @@
--{-# LANGUAGE TupleSections #-}
module Dodge.Room.SensorDoor (sensAboveDoor,sensorRoomRunPast) where
import Dodge.Data.MTRS
import qualified Data.Set as S
import Dodge.Annotation.Data
import Dodge.Cleat
import Dodge.Data.GenWorld
import Dodge.LevelGen.PlacementHelper
src/Dodge/Room/Tutorial.hs
+10 -11
View File
@@ -1,6 +1,6 @@
module Dodge.Room.Tutorial where
import Dodge.Annotation
import Dodge.Data.MTRS
import Dodge.Room.Room
import Dodge.Cleat
import Dodge.Data.GenWorld
@@ -38,16 +38,15 @@ import TreeHelp
tutAnoTree :: State LayoutVars MTRS
tutAnoTree =
annoToRoomTree $
OnwardList
[ AnTree $ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
, AnTree corDoor
, AnTree tutRooms
, AnTree corDoor
, AnTree $ tToBTree "critroom" <$> weaponBehindPillar
, AnTree corDoor
, AnTree tutDrop
, AnTree $ return $ tToBTree "cor" $ return $ cleatOnward corridor
foldMTRS
[ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
, corDoor
, tutRooms
, corDoor
, tToBTree "critroom" <$> weaponBehindPillar
, corDoor
, tutDrop
, return $ tToBTree "cor" $ return $ cleatOnward corridor
---- , AnTree $ pickupTut
---- , AnTree $ weaponTut
]