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

Work on placements/room generation

Browse Source
This commit is contained in:
justin
2025-08-22 13:42:51 +01:00
parent e7b52f4487
commit f641805845
14 changed files with 294 additions and 596 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data/GenWorld.hs
+5 -1
View File
@@ -29,7 +29,11 @@ data GenWorld = GenWorld
---- ROOM DATATYPES
data PSType
= PutCrit {_unPutCrit :: Creature}
| PutMachine {_putMachinePoly :: [Point2], _putMachineMachine :: Machine, _putMachineWall :: Wall}
| PutMachine
{ _putMachinePoly :: [Point2]
, _putMachineMachine :: Machine
, _putMachineWall :: Wall
}
| PutLS LightSource
| PutButton {_putButton :: Button}
| PutProp Prop
src/Dodge/Data/RoomCluster.hs
+1 -2
View File
@@ -7,8 +7,7 @@ import Control.Lens
import qualified Data.Set as S
data ClusterStatus = ClusterStatus
{ _csName :: String
, _csLinks :: S.Set ClusterLink
{ _csLinks :: S.Set ClusterLink
}
data ClusterLink = OnwardCluster | SideCluster | LabelCluster Int
src/Dodge/Default/Room.hs
+1 -1
View File
@@ -36,4 +36,4 @@ defaultRoom =
}
defaultClusterStatus :: ClusterStatus
defaultClusterStatus = ClusterStatus "defRoomClust" S.empty
defaultClusterStatus = ClusterStatus S.empty
src/Dodge/LevelGen.hs
+1 -1
View File
@@ -51,7 +51,7 @@ 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 (LayVars g 0)
let treecluster = evalState tutRoomTree (LayVars g 0)
let labts = decomposeSelfTree $ numSelfTree $ combineTree _rmName treecluster
appendFile "log/treeCluster" ("Seed: " ++ show seed ++ "\n")
putStrLn "MetaTree clusters:"
src/Dodge/PlacementSpot.hs
+6 -1
View File
@@ -1,6 +1,7 @@
--{-# LANGUAGE LambdaCase #-}
module Dodge.PlacementSpot
( atFstLnkOut
, atNthLnkOutShiftBy
, rpIsOnPath
, rpIsOffPath
, rpOffPathFromEdge
@@ -34,6 +35,7 @@ module Dodge.PlacementSpot
, shiftByV2
, usedRoomLinkPoss
, usedRoomInLinkPoss
, atNthLinkOut
) where
import Dodge.Data.GenWorld
@@ -209,7 +211,10 @@ usedRoomLinkPoss r = mapMaybe f $ _rmPos r
_ -> Nothing
atFstLnkOut :: PlacementSpot
atFstLnkOut = rprBool $ \rp _ -> rp ^? rpLinkStatus . rplsChildNum == Just 0
atFstLnkOut = atNthLinkOut 0
atNthLinkOut :: Int -> PlacementSpot
atNthLinkOut n = rprBool $ \rp _ -> rp ^? rpLinkStatus . rplsChildNum == Just n
atNthLnkOutShiftBy :: Int -> ((Point2,Float) -> (Point2,Float)) -> PlacementSpot
atNthLnkOutShiftBy n = rprBoolShift
src/Dodge/Room/LasTurret.hs
+18 -15
View File
@@ -22,14 +22,15 @@ import LensHelp
import RandomHelp
cenLasTur :: Room
cenLasTur = roomNgon 8 200 & rmPmnts .~
[ putLasTurret 0.02
, heightWallPS
(resetPLUse $ rprBoolShift (const . isInLnk) (shiftInBy 100))
30
covershape
, mntLightLnkCond $ rprBool $ const . isInLnk
]
cenLasTur =
roomNgon 8 200 & rmPmnts
.~ [ putLasTurret 0.02
, heightWallPS
(resetPLUse $ rprBoolShift (const . isInLnk) (shiftInBy 100))
30
covershape
, mntLightLnkCond $ rprBool $ const . isInLnk
]
where
covershape = rectNSWE 10 (-10) (-20) 20
@@ -74,24 +75,26 @@ keyCardAnalyserByDoor keyid = analyserByDoor (RequireEquipment (HELD (KEYCARD ke
healthAnalyserByDoor :: Int -> Room -> Room
healthAnalyserByDoor = analyserByDoor (RequireHealth 1100)
analyserByDoor :: ProximityRequirement -> Int -> Room -> Room
analyserByDoor proxreq outplid rm =
analyserByNthLink :: Int -> ProximityRequirement -> Int -> Room -> Room
analyserByNthLink n proxreq outplid rm =
rm
& rmPmnts
.++~ [ psPt atFstLnkOut $ PutForeground $ verticalWire (V2 20 0) 0 80
.++~ [ psPt (atNthLinkOut n) $ PutForeground $ verticalWire (V2 20 0) 0 80
]
& rmOutPmnt
.~ [ OutPlacement
.:~ OutPlacement
( analyser
proxreq
(atFstLnkOutShiftBy (\(p, a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))
(atFstLnkOutShiftBy sensorshift)
(atNthLnkOutShiftBy n (\(p, a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))
(atNthLnkOutShiftBy n sensorshift)
)
outplid
]
where
sensorshift (p, a) = (p +.+ rotateV a (V2 30 (-10)), a)
analyserByDoor :: ProximityRequirement -> Int -> Room -> Room
analyserByDoor = analyserByNthLink 0
healthTest :: RandomGen g => Int -> State g (Tree Room)
healthTest n = do
cenroom <- shuffleLinks $ healthAnalyserByDoor n $ roomNgon 8 200
src/Dodge/Room/Room.hs
+1 -1
View File
@@ -373,7 +373,7 @@ spawnerRoom = do
aRoom <- airlock
return $ treeFromTrunk [aRoom, corridor] $ pure $ cleatOnward roomWithSpawner
corDoor :: State StdGen (MetaTree Room String)
corDoor :: RandomGen g => State g (MetaTree Room String)
corDoor = do
cor <- shuffleLinks (cleatOnward corridor) <&> rmPmnts .~ []
return $ tToBTree "corDoor" $ treePost [door, cor]
src/Dodge/Room/Tutorial.hs
+48 -24
View File
@@ -1,14 +1,9 @@
module Dodge.Room.Tutorial (tutAnoTree) where
import Dodge.Cleat
import Dodge.Room.Room
import Dodge.Item.Held.Cane
import Dodge.Item.Ammo
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 Dodge.Cleat
--import Control.Monad
--import qualified Data.Set as S
--import Dodge.Cleat
@@ -18,34 +13,68 @@ import Dodge.Default.Terminal
import Dodge.LevelGen.PlacementHelper
--import Dodge.LightSource
import Dodge.Placement.Instance
import Dodge.Room.Door
import Dodge.Room.LasTurret
import Dodge.Room.Link
import Dodge.Room.Ngon
--import Dodge.Room.Corridor
--import Dodge.Room.Door
--import Dodge.Room.Link
import Dodge.Room.Procedural
import Dodge.Room.RezBox
import Dodge.Room.Room
import Dodge.Room.Warning
--import Dodge.Room.RoadBlock
import Dodge.RoomLink
import Dodge.Terminal
import Dodge.Tree.Compose
--import Dodge.Tree
import Geometry
import LensHelp
--import Padding
import RandomHelp
import Data.List (intersperse)
import TreeHelp
--import Data.List (intersperse)
tutAnoTree :: Annotation
tutAnoTree = OnwardList $
intersperse
(AnTree $ zoom lyGen corDoor)
[AnTree . zoom lyGen $ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
,AnTree $ zoom lyGen tutRooms
]
tutAnoTree =
OnwardList $
[ AnTree $ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
, AnTree corDoor
, AnTree $ tutRooms
, AnTree $ pickupTut
, AnTree $ weaponTut
]
tutRooms :: State StdGen (MetaTree Room String)
weaponTut :: State LayoutVars (MetaTree Room String)
weaponTut = do
x <- shuffleLinks $ roomNgon 6 100
& rmPmnts .:~ sps (PS 0 0) (PutFlIt $ burstRifle)
return $ tToBTree "WeaponTestTest" $ treePost $ [x]
pickupTut :: State LayoutVars (MetaTree Room String)
pickupTut = do
i <- nextLayoutInt
x <- shuffleLinks $ analyserByDoor (RequireEquipment (AMMOMAG DRUMMAG)) i $ roomNgon 6 100
& rmPmnts .:~ sps (PS 0 0) (PutFlIt $ drumMag & itConsumables ?~ 100)
return $ tToBTree "PickupTest" $ treePost $ [x, cleatOnward $ triggerDoorRoom i]
tutRooms :: State LayoutVars (MetaTree Room String)
tutRooms = do
ys <- toggleDoorTest
return $ tToBTree "DoorTest" $ treePost $ [] <> ys
i <- nextLayoutInt
j <- nextLayoutInt
x <- shuffleLinks $ analyserByDoor (RequireEquipment (AMMOMAG DRUMMAG)) i
$ addDoorAtNthLinkToggleTerminal 1 (makeTermPara s) j
$ roomNgon 6 100
return $ tToBTree "DoorTest" $ Node x
[Node (cleatOnward $ triggerDoorRoom i) []
,Node ( triggerDoorRoom j) []
]
where
s = "INTERACTION TEST 1: USE KEYBOARD OR SCROLL TO ENTER COMMANDS."
tutRezBox :: State StdGen Room
tutRezBox :: RandomGen g => State g Room
tutRezBox = do
ls <- rezColor
return $
@@ -63,8 +92,3 @@ tutRezBox = do
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/Room/Warning.hs
+34 -10
View File
@@ -1,6 +1,8 @@
--{-# LANGUAGE TupleSections #-}
module Dodge.Room.Warning (warningRooms) where
module Dodge.Room.Warning (warningRooms,addDoorToggleTerminal
, addDoorAtNthLinkToggleTerminal) where
import Control.Monad
import Dodge.Default.Terminal
import Dodge.Data.BlBl
import Color
@@ -29,28 +31,36 @@ warningRooms str n = do
cenroom <- shuffleLinks $ addWarningTerminal str n rm
rToOnward "warningRooms" $ treePost [door, cenroom, triggerDoorRoom n, cleatOnward door]
addWarningTerminal :: String -> Int -> Room -> Room
addWarningTerminal str outplid = (rmName .++~ "warningTerm-")
. (rmOutPmnt .~ [OutPlacement outplace outplid])
addDoorToggleTerminal :: [TerminalLine] -> Int -> Room -> Room
addDoorToggleTerminal = addDoorAtNthLinkToggleTerminal 0
addDoorAtNthLinkToggleTerminal :: Int -> [TerminalLine] -> Int -> Room -> Room
addDoorAtNthLinkToggleTerminal j xs i = (rmName .++~ "doorToggle-")
. (rmOutPmnt .:~ OutPlacement outplace i)
where
outplace =
extTrigLitPos
(atFstLnkOutShiftBy (\(p, a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))
( Just . set plSpot (rprShift moveToSideFirstOutLink)
(atNthLnkOutShiftBy j (\(p, a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))
( Just . set plSpot (rprShift (moveToSideNthOutLink j))
. putMessageTerminal terminalColor
. termMessages
)
termMessages trpl =
lineOutputTerminal (makeColorTermLine red "WARNING" : makeTermPara str)
lineOutputTerminal xs --(makeColorTermLine red "WARNING" : makeTermPara str)
& tmToggles .~ M.fromList
[("DOOR", TerminalToggle (fromJust $ _plMID trpl) (BlConst True))]
addWarningTerminal :: String -> Int -> Room -> Room
addWarningTerminal str = addDoorToggleTerminal (makeColorTermLine red "WARNING" : makeTermPara str)
lineOutputTerminal :: [TerminalLine] -> Terminal
lineOutputTerminal tls = defaultTerminal & tmBootLines .~ connectionBlurbLines tls
moveToSideFirstOutLink :: RoomPos -> Room -> Maybe (Point2, Float)
moveToSideFirstOutLink rp rm = do
0 <- rp ^? rpLinkStatus . rplsChildNum
moveToSideNthOutLink :: Int -> RoomPos -> Room -> Maybe (Point2, Float)
moveToSideNthOutLink i rp rm = do
j <- rp ^? rpLinkStatus . rplsChildNum
guard $ i == j
let rppos = _rpPos rp
rpdir = _rpDir rp
inpos = rppos +.+ rotateV rpdir (V2 0 (-12.5))
@@ -61,6 +71,20 @@ moveToSideFirstOutLink rp rm = do
-- complicated, it should really use created walls...
(rtpos, rpdir)
else (ltpos, rpdir)
--moveToSideFirstOutLink :: RoomPos -> Room -> Maybe (Point2, Float)
--moveToSideFirstOutLink rp rm = do
-- 0 <- rp ^? rpLinkStatus . rplsChildNum
-- let rppos = _rpPos rp
-- rpdir = _rpDir rp
-- inpos = rppos +.+ rotateV rpdir (V2 0 (-12.5))
-- rtpos = inpos +.+ rotateV rpdir (V2 30 0)
-- ltpos = inpos +.+ rotateV rpdir (V2 (-30) 0)
-- return $ if any (isJust . intersectSegPolyFirst inpos ltpos) (_rmPolys rm)
-- then -- the above test may not work properly if the room polys are
-- -- complicated, it should really use created walls...
-- (rtpos, rpdir)
-- else (ltpos, rpdir)
--moveToSideFirstOutLink rp rm = case rp ^? rpLinkStatus . rplsChildNum of
-- Just 0 ->
-- let rppos = _rpPos rp