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

Work on room generation/laser run past

Browse Source
This commit is contained in:
justin
2026-03-17 21:50:28 +00:00
parent 13b12f01a8
commit 3b4cf68a15
18 changed files with 656 additions and 528 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Block/Debris.hs
+36 -26
View File
@@ -1,20 +1,20 @@
module Dodge.Block.Debris ( module Dodge.Block.Debris (
cubeShape, cubeShape,
-- dirtColor, -- dirtColor,
makeDoorDebris, makeDoorDebris,
makeBlockDebris, makeBlockDebris,
makeDebris, makeDebris,
makeDebrisDirected, makeDebrisDirected,
) where ) where
import Dodge.Material.Color
import qualified Data.IntMap.Strict as IM
import Dodge.ShiftPoint
import Data.Foldable import Data.Foldable
import qualified Data.IntMap.Strict as IM
import qualified Data.IntSet as IS import qualified Data.IntSet as IS
import Data.Maybe import Data.Maybe
import Dodge.Data.World import Dodge.Data.World
import Dodge.Material.Color
import Dodge.Material.Sound import Dodge.Material.Sound
import Dodge.ShiftPoint
import Dodge.WorldEvent.Sound import Dodge.WorldEvent.Sound
import Geometry import Geometry
import Grid import Grid
@@ -30,7 +30,7 @@ makeDoorDebris dr w = w & makeDebris mt p
p = centroid . fmap fst $ (dr ^. drFootPrint) & each . each %~ shiftPointBy p2a p = centroid . fmap fst $ (dr ^. drFootPrint) & each . each %~ shiftPointBy p2a
mt = fromMaybe Stone $ do mt = fromMaybe Stone $ do
wlids <- w ^? cWorld . lWorld . doors . ix (_drID dr) . drFootPrint wlids <- w ^? cWorld . lWorld . doors . ix (_drID dr) . drFootPrint
((wlid,_),_) <- IM.minViewWithKey wlids ((wlid, _), _) <- IM.minViewWithKey wlids
w ^? cWorld . lWorld . walls . ix wlid . wlMaterial w ^? cWorld . lWorld . walls . ix wlid . wlMaterial
makeBlockDebris :: Block -> World -> World makeBlockDebris :: Block -> World -> World
@@ -44,33 +44,39 @@ makeBlockDebris bl w = foldl' (flip $ makeDebris mt) w ps
wl <- w ^? cWorld . lWorld . walls . ix wlid wl <- w ^? cWorld . lWorld . walls . ix wlid
return $ _wlMaterial wl return $ _wlMaterial wl
--makeDebris :: Material -> Color -> Point2 -> World -> World -- makeDebris :: Material -> Color -> Point2 -> World -> World
makeDebris :: Material -> Point2 -> World -> World makeDebris :: Material -> Point2 -> World -> World
makeDebris = makeDebrisDirected (2 * pi) 0 makeDebris = makeDebrisDirected (2 * pi) 0
makeDebrisDirected :: Float -> Float -> Material -> Point2 -> World -> World makeDebrisDirected :: Float -> Float -> Material -> Point2 -> World -> World
--makeDebrisDirected :: Float -> Float -> Material -> Color -> Point2 -> World -> World -- makeDebrisDirected :: Float -> Float -> Material -> Color -> Point2 -> World -> World
--makeDebrisDirected arcrad dir bm col p w = -- makeDebrisDirected arcrad dir bm col p w =
makeDebrisDirected arcrad dir bm p w = makeDebrisDirected arcrad dir bm p w =
w w
-- & flip (foldl' (flip $ plNew (cWorld . lWorld . props) prID)) thedebris -- & flip (foldl' (flip $ plNew (cWorld . lWorld . props) prID)) thedebris
& cWorld . lWorld . debris <>~ thedebris & cWorld
& randGen .~ newg . lWorld
. debris
<>~ thedebris
& randGen
.~ newg
& soundOriginsIDsAt [MaterialSound bm i | i <- [0, 1, 2]] (destroyMatS bm) p & soundOriginsIDsAt [MaterialSound bm i | i <- [0, 1, 2]] (destroyMatS bm) p
where where
(thedebris, newg) = mapM f [35, 55, 75, 95] & runState $ _randGen w (thedebris, newg) = mapM f [35, 55, 75, 95] & runState $ _randGen w
f h = do f h = do
v <- rotateV (dir - arcrad / 2) <$> randInArcStrip 1 2 arcrad v <- rotateV (dir - arcrad / 2) <$> randInArcStrip 1 2 arcrad
spinspeed <- randomR (-0.2, -0.1) & state spinspeed <- randomR (-0.2, -0.1) & state
-- basedebris <- baseDebris bm -- basedebris <- baseDebris bm
return $ DebrisChunk return $
{ _dbPos = p `v2z` h DebrisChunk
-- , _dbType = BlockDebris col { _dbPos = p `v2z` h
, _dbType = BlockDebris (materialColor bm) , -- , _dbType = BlockDebris col
, _dbVel = v `v2z` 0 _dbType = BlockDebris (materialColor bm)
, _dbRot = Q.qID , _dbVel = v `v2z` 0
, _dbSpin = Q.axisAngle (vNormal v `v2z` 0) spinspeed , _dbRot = Q.qID
} , _dbSpin = Q.axisAngle (vNormal v `v2z` 0) spinspeed
}
-- basedebris -- basedebris
-- & prColor .~ col -- & prColor .~ col
-- & prPos .~ p -- & prPos .~ p
@@ -91,9 +97,13 @@ debrisSize mt = case mt of
Electronics -> 10 Electronics -> 10
Flesh -> 10 Flesh -> 10
ForceField -> 10 ForceField -> 10
Photovoltaic -> 10
LightningRod -> 10
Pyroelectric -> 10
Piezoelectric -> 10
--shardShape :: Float -> Shape -- shardShape :: Float -> Shape
--shardShape size = -- shardShape size =
-- translateSHz (- size) $ -- translateSHz (- size) $
-- upperPrismPolySU -- upperPrismPolySU
-- size -- size
@@ -102,10 +112,10 @@ debrisSize mt = case mt of
-- , V2 (- size) (-1) -- , V2 (- size) (-1)
-- ] -- ]
-- --
--jaggedShape :: State StdGen Shape -- jaggedShape :: State StdGen Shape
--jaggedShape = do -- jaggedShape = do
-- s <- randomR (4, 10) & state -- s <- randomR (4, 10) & state
-- return $ shardShape s -- return $ shardShape s
cubeShape :: Float -> Shape cubeShape :: Float -> Shape
cubeShape size = translateSHz (- size) $ upperPrismPolySU (2 * size) $ square size cubeShape size = translateSHz (-size) $ upperPrismPolySU (2 * size) $ square size
src/Dodge/Data/GenWorld.hs
+3 -2
View File
@@ -24,7 +24,7 @@ import System.Random
data GenWorld = GenWorld data GenWorld = GenWorld
{ _gwWorld :: World { _gwWorld :: World
, _genRooms :: IM.IntMap Room , _genRooms :: IM.IntMap Room
, _genPmnt :: IM.IntMap Placement , _genPmnt :: IM.IntMap Placement -- stored generated placements
, _genInts :: IM.IntMap Int , _genInts :: IM.IntMap Int
} }
@@ -138,7 +138,8 @@ data Room = Room
, _rmPos :: [RoomPos] , _rmPos :: [RoomPos]
, _rmPath :: S.Set (Point2, Point2) , _rmPath :: S.Set (Point2, Point2)
, _rmPmnts :: [Placement] , _rmPmnts :: [Placement]
, _rmInPmnt :: [(Int,GenWorld -> Placement)] , _rmInPmnt :: [(Int,GenWorld -> Placement)] -- so far as I can tell,
-- the first Int only determines the order in which these are applied
, _rmBound :: [[Point2]] , _rmBound :: [[Point2]]
, _rmFloor :: Floor , _rmFloor :: Floor
, _rmName :: String , _rmName :: String
src/Dodge/Data/Material.hs
+4
View File
@@ -17,6 +17,10 @@ data Material
| Flesh | Flesh
| Electronics | Electronics
| ForceField | ForceField
| Photovoltaic
| LightningRod
| Pyroelectric
| Piezoelectric
deriving (Eq, Ord, Show, Bounded, Enum, Read) --Generic, Flat) deriving (Eq, Ord, Show, Bounded, Enum, Read) --Generic, Flat)
deriveJSON defaultOptions ''Material deriveJSON defaultOptions ''Material
src/Dodge/Floor.hs
+2 -2
View File
@@ -31,7 +31,7 @@ initialRoomTree =
[-- CRAFT (ENERGYBALLCRAFT TeslaBall) , [-- CRAFT (ENERGYBALLCRAFT TeslaBall) ,
HELD SPARKGUN])] HELD SPARKGUN])]
itemRooms itemRooms
, intAnno lasSensorTurretTest , lasSensorTurretTest
, -- , AnRoom $ tanksRoom [] [] <&> rmPmnts .~ [] , -- , AnRoom $ tanksRoom [] [] <&> rmPmnts .~ []
-- , AnRoom $ tanksRoom [] [] -- , AnRoom $ tanksRoom [] []
-- , AnRoom $ roomCCrits 0 -- , AnRoom $ roomCCrits 0
@@ -63,7 +63,7 @@ initialRoomTree =
$ tanksRoom [] [] >>= rToOnward "empty tanksRoom" . pure . cleatOnward $ tanksRoom [] [] >>= rToOnward "empty tanksRoom" . pure . cleatOnward
, passthroughLockKeyLists lockRoomKeyItems itemRooms , passthroughLockKeyLists lockRoomKeyItems itemRooms
, randomChallenges , randomChallenges
, intAnno lasSensorTurretTest , lasSensorTurretTest
, -- ,[AnTree $ fmap pure roomCCrits] , -- ,[AnTree $ fmap pure roomCCrits]
-- ,[AirlockAno] -- ,[AirlockAno]
-- ,[Corridor] -- ,[Corridor]
src/Dodge/LevelGen.hs
+1
View File
@@ -31,6 +31,7 @@ generateWorldFromSeed rdata i = do
postGenerationProcessing :: RenderData -> GenWorld -> IO World postGenerationProcessing :: RenderData -> GenWorld -> IO World
postGenerationProcessing _ gw = do postGenerationProcessing _ gw = do
let w = _gwWorld gw & cWorld . cwTiles .~ (tilesFromRooms . IM.elems $ _genRooms gw) let w = _gwWorld gw & cWorld . cwTiles .~ (tilesFromRooms . IM.elems $ _genRooms gw)
putStrLn $ show $ gw ^. genInts
return $ foldl' assignPushDoors w (w ^. cWorld . lWorld . doors) return $ foldl' assignPushDoors w (w ^. cWorld . lWorld . doors)
assignPushDoors :: World -> Door -> World assignPushDoors :: World -> Door -> World
src/Dodge/LockAndKey.hs
+8 -7
View File
@@ -24,13 +24,14 @@ lockRoomMultiItems =
lockRoomKeyItems :: [(Int -> State LayoutVars (MetaTree Room String), State LayoutVars ItemType)] lockRoomKeyItems :: [(Int -> State LayoutVars (MetaTree Room String), State LayoutVars ItemType)]
lockRoomKeyItems = lockRoomKeyItems =
[ (lasCenSensEdge, takeOne [HELD RLAUNCHER, LASER, HELD SPARKGUN, HELD FLATSHIELD]) [ (lasCenSensEdge, takeOne [ HELD FLATSHIELD])
, (sensorRoomRunPast LaserSensor, return LASER) -- [ (lasCenSensEdge, takeOne [HELD RLAUNCHER, LASER, HELD SPARKGUN, HELD FLATSHIELD])
, (const slowDoorRoomRunPast, return $ HELD (MINIGUNX 3)) -- , (sensorRoomRunPast LaserSensor, return LASER)
, (const longRoomRunPast, takeOne [HELD SNIPERRIFLE, HELD FLATSHIELD]) -- , (const slowDoorRoomRunPast, return $ HELD (MINIGUNX 3))
, (const glassLessonRunPast, takeOne [LASER]) -- , (const longRoomRunPast, takeOne [HELD SNIPERRIFLE, HELD FLATSHIELD])
, (const $ lasTunnelRunPast 400, takeOne [HELD FLATSHIELD]) -- , (const glassLessonRunPast, takeOne [LASER])
, (keyCardRoomRunPast 0, return (HELD $ KEYCARD 0)) -- , (const $ lasTunnelRunPast 400, takeOne [HELD FLATSHIELD])
-- , (keyCardRoomRunPast 0, return (HELD $ KEYCARD 0))
] ]
keyCardRunPastRand :: RandomGen g => [(Int -> State g (MetaTree Room String), State g ItemType)] keyCardRunPastRand :: RandomGen g => [(Int -> State g (MetaTree Room String), State g ItemType)]
src/Dodge/Material/Color.hs
+4
View File
@@ -16,3 +16,7 @@ materialColor = \case
Flesh -> red Flesh -> red
Electronics -> greyN 0.2 Electronics -> greyN 0.2
ForceField -> magenta ForceField -> magenta
Photovoltaic -> yellow
LightningRod -> yellow
Pyroelectric -> yellow
Piezoelectric -> yellow
src/Dodge/Material/Damage.hs
+54
View File
@@ -25,6 +25,10 @@ damMatSideEffect dm = \case
Dirt -> damageDirt dm Dirt -> damageDirt dm
Glass -> damageGlass dm Glass -> damageGlass dm
Crystal -> damageCrystal dm Crystal -> damageCrystal dm
Photovoltaic -> damagePhotovoltaic dm
LightningRod -> damageLightningRod dm
Pyroelectric -> damagePyroelectric dm
Piezoelectric -> damagePiezoelectric dm
_ -> defDamageMaterial dm _ -> defDamageMaterial dm
defDamageMaterial :: Damage -> ECW -> World -> (Int,World) defDamageMaterial :: Damage -> ECW -> World -> (Int,World)
@@ -66,6 +70,56 @@ damageStone dm ecw w = case dm of
so = DamageHitSound (w ^. cWorld . lWorld . lClock) so = DamageHitSound (w ^. cWorld . lWorld . lClock)
outTo x t = x -.- squashNormalizeV t outTo x t = x -.- squashNormalizeV t
damageLightningRod :: Damage -> ECW -> World -> (Int,World)
damageLightningRod dm ecw w = case dm of
Electrical{} -> (dm ^. dmAmount, w)
_ -> damageStone dm ecw w
damagePyroelectric :: Damage -> ECW -> World -> (Int,World)
damagePyroelectric dm ecw w = case dm of
Flaming{} -> (dm ^. dmAmount, w)
Explosive{} -> (dm ^. dmAmount, w)
Sparking{} -> (dm ^. dmAmount, w)
_ -> damageStone dm ecw w
-- this should be correct
-- to be honest, we shouldn't just pass an int forward here...
damagePiezoelectric :: Damage -> ECW -> World -> (Int,World)
damagePiezoelectric = damageStone
damagePhotovoltaic :: Damage -> ECW -> World -> (Int,World)
damagePhotovoltaic dm ecw w = case dm of
Lasering _ p t -> f dmam $ laserSpark (outTo p t) (rdir p t)
Piercing _ p t ->
f dmam $ makeSpark NormalSpark (outTo p t) (rdir p t)
. makeDustAt Stone 200 (addZ 20 (outTo p t))
-- . randsound p [slapS, slap1S,slap2S,slap3S,slap4S,slap5S,slap6S,slap7S]
. randsound p [slapS, slap1S, slap2S]
Blunt _ p t -> f dmam $ makeDustAt Stone 200 (addZ 20 (outTo p t))
Shattering _ p t -> f dmam $ makeDustAt Stone 200 (addZ 20 (outTo p t))
Crushing{} -> f dmam id
Explosive{} -> f dmam id
Sparking{} -> f 0 id
Flaming{} -> f 0 id
Electrical{} -> f 0 id
Poison{} -> f 0 id
Enterrement{} -> f 0 id
Flashing{} -> f 0 id
where
f x g = (x, g w)
dmam = dm ^. dmAmount
rdir p t = argV $ reflectIn v t
where
v = case ecw of
Right wl -> uncurry (-) $ _wlLine wl
Left cr -> vNormal (p - cr ^. crPos . _xy)
randsound p xs =
let (x, g) = runState (takeOne xs) $ _randGen w
in soundStart so p x Nothing . set randGen g
so = DamageHitSound (w ^. cWorld . lWorld . lClock)
outTo x t = x -.- squashNormalizeV t
damageMetal :: Damage -> ECW -> World -> (Int,World) damageMetal :: Damage -> ECW -> World -> (Int,World)
damageMetal dm ecw w = case dm of damageMetal dm ecw w = case dm of
Lasering _ p t -> f 0 $ laserSpark (outTo p t) (rdir p t) Lasering _ p t -> f 0 $ laserSpark (outTo p t) (rdir p t)
src/Dodge/Material/Sound.hs
+4
View File
@@ -15,6 +15,10 @@ destroyMatS mat = case mat of
Electronics -> [metal1S, metal2S, metal3S, metal4S, metal5S, metal6S,metal7S] Electronics -> [metal1S, metal2S, metal3S, metal4S, metal5S, metal6S,metal7S]
Flesh -> [gut1S, gut2S, gut3S, gut4S, gut5S, gut6S] Flesh -> [gut1S, gut2S, gut3S, gut4S, gut5S, gut6S]
ForceField -> [] ForceField -> []
Photovoltaic -> [glassShat1S, glassShat2S, glassShat3S, glassShat4S]
LightningRod -> [glassShat1S, glassShat2S, glassShat3S, glassShat4S]
Pyroelectric -> [glassShat1S, glassShat2S, glassShat3S, glassShat4S]
Piezoelectric -> [glassShat1S, glassShat2S, glassShat3S, glassShat4S]
--weakenMatS :: Material -> [SoundID] --weakenMatS :: Material -> [SoundID]
--weakenMatS mat = case mat of --weakenMatS mat = case mat of
src/Dodge/Placement/Instance/LightSource.hs
+3
View File
@@ -1,8 +1,11 @@
module Dodge.Placement.Instance.LightSource ( module Dodge.Placement.Instance.LightSource (
mntLSOn, mntLSOn,
mntLSCond,
aShape, aShape,
aBar, aBar,
lShape, lShape,
jShape,
liShape,
mntLightLnkCond, mntLightLnkCond,
mntLS, mntLS,
vShape, vShape,
src/Dodge/Placement/Instance/Sensor.hs
+7
View File
@@ -17,11 +17,18 @@ damageSensor dt wdth mtrid ps = pContID ps (PutLS $ lsPosCol (V3 0 0 30) 0.1) $
PutMachine PutMachine
(reverse $ square wdth) (reverse $ square wdth)
( defaultMachine ( defaultMachine
& mcMaterial .~ mattype
& mcMounts . at OTTrigger .~ mtrid & mcMounts . at OTTrigger .~ mtrid
& mcMounts . at OTLightSource ?~ lsid & mcMounts . at OTLightSource ?~ lsid
& mcType .~ McDamSensor (DamSensor 0 dt) & mcType .~ McDamSensor (DamSensor 0 dt)
) )
Nothing Nothing
where
mattype = case dt of
LaserSensor -> Photovoltaic
ElectricSensor -> LightningRod
ThermalSensor -> Pyroelectric
PhysicalSensor -> Piezoelectric
lightSensor :: Float -> Maybe Int -> PlacementSpot -> Placement lightSensor :: Float -> Maybe Int -> PlacementSpot -> Placement
lightSensor = damageSensor LaserSensor lightSensor = damageSensor LaserSensor
src/Dodge/Placement/PlaceSpot.hs
+4 -5
View File
@@ -27,8 +27,6 @@ import LensHelp
import Linear import Linear
import NewInt import NewInt
--import System.Random
-- when placing a placement, we update the world and the room and assign an id -- when placing a placement, we update the world and the room and assign an id
-- to the placement. This id should be associated with the type of placement and -- to the placement. This id should be associated with the type of placement and
-- match up with the created id for the object (creature id, flitid id, etc) -- match up with the created id for the object (creature id, flitid id, etc)
@@ -199,7 +197,7 @@ plMachine ::
plMachine wallpoly mc mitm p rot gw = plMachine wallpoly mc mitm p rot gw =
( mcid ( mcid
, gw & tolw . machines . at mcid ?~ themc , gw & tolw . machines . at mcid ?~ themc
& gwWorld %~ placeMachineWalls wallpoly mcid wlid & gwWorld %~ placeMachineWalls (_mcMaterial mc) wallpoly mcid wlid
& tolw %~ maybe id placeturretitm mitm & tolw %~ maybe id placeturretitm mitm
) )
where where
@@ -215,10 +213,11 @@ plMachine wallpoly mc mitm p rot gw =
itid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . items itid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . items
itm' = itm & itID .~ NInt itid & itLocation .~ OnTurret mcid itm' = itm & itID .~ NInt itid & itLocation .~ OnTurret mcid
placeMachineWalls :: [Point2] -> Int -> Int -> World -> World placeMachineWalls :: Material -> [Point2] -> Int -> Int -> World -> World
placeMachineWalls poly mcid = insertStructureWalls MachinePart baseWall poly mcid placeMachineWalls mat poly mcid = insertStructureWalls MachinePart baseWall poly mcid
where where
baseWall = defaultMachineWall & wlStructure . wsMachine .~ mcid baseWall = defaultMachineWall & wlStructure . wsMachine .~ mcid
& wlMaterial .~ mat
mvLS :: Point3 -> Float -> LightSource -> LightSource mvLS :: Point3 -> Float -> LightSource -> LightSource
mvLS (V3 x y z) rot ls = ls & lsParam . lsPos .~ V3 x y z + startPos mvLS (V3 x y z) rot ls = ls & lsParam . lsPos .~ V3 x y z + startPos
src/Dodge/Room/LasTurret.hs
+56 -10
View File
@@ -14,11 +14,17 @@ module Dodge.Room.LasTurret (
lasCenRunClose1, lasCenRunClose1,
lasCenRunCloseLongCor, lasCenRunCloseLongCor,
lasRunRand, lasRunRand,
setRoomInt,
) where ) where
import Control.Monad import Data.Foldable
import Data.Foldable (fold) import Data.Maybe
import Color
import Shape
import Dodge.Placement.Instance.LightSource
import Dodge.Room.Path import Dodge.Room.Path
import Control.Monad
--import Data.Foldable (fold)
import Dodge.Room.Procedural import Dodge.Room.Procedural
import qualified Data.Set as S import qualified Data.Set as S
import Dodge.Cleat import Dodge.Cleat
@@ -40,9 +46,13 @@ import Geometry
import LensHelp import LensHelp
import RandomHelp import RandomHelp
-- no lights!
cenLasTur :: (RandomGen g) => State g Room cenLasTur :: (RandomGen g) => State g Room
cenLasTur = do cenLasTur = do
thelight <- mntLightLnkCond $ rprBool $ const . isInLnk -- lshape <- takeOne [vShape, lShape, jShape, liShape]
-- let lightn i = mntLSCond (fmap (fmap $ colorSH black) lshape)
-- $ rprBool $ const . (\rp -> PolyEdge i `S.member` (fold (rp ^? rpType . rplsType)))
-- thelight <- mntLightLnkCond $ rprBool $ const . isInLnk
roomNgon 8 200 roomNgon 8 200
<&> rmPmnts <&> rmPmnts
.~ [ putLasTurret 0.02 .~ [ putLasTurret 0.02
@@ -50,8 +60,11 @@ cenLasTur = do
(resetPLUse $ rprBoolShift (const . isInLnk) (shiftInBy 100 <&> (,S.singleton UsedPosLow))) (resetPLUse $ rprBoolShift (const . isInLnk) (shiftInBy 100 <&> (,S.singleton UsedPosLow)))
30 30
covershape covershape
, thelight -- , lightn 0
-- , lightn 3
-- , lightn 6
] ]
<&> rmPath %~ addNodesCrossingCirc 0 30
where where
covershape = rectNSWE 10 (-10) (-20) 20 covershape = rectNSWE 10 (-10) (-20) 20
@@ -131,24 +144,57 @@ healthTest n = do
, cleatOnward door , cleatOnward door
] ]
lasSensorTurretTest :: (RandomGen g) => Int -> State g (MetaTree Room String) lasSensorTurretTest :: State LayoutVars (MetaTree Room String)
lasSensorTurretTest n = do lasSensorTurretTest = do
cenroom <- shuffleLinks . lightSensInsideDoor n =<< cenLasTur n <- nextLayoutInt
cenroom' <- shuffleLinks . lightSensInsideDoor n =<< cenLasTur
(i,cenroom'') <- setRoomInt cenroom'
lshape <- takeOne [vShape, lShape, jShape, liShape]
let alight a rp = mntLSCond (fmap (fmap $ colorSH black) lshape) (PS (rotateV a $ _rpPos rp) (a +_rpDir rp))
let cenroom = cenroom''
& rmInPmnt <>~
[(0, alight pi . f i)
,(0, alight (0.5*pi) . f i)
,(0, alight (1.5*pi) . f i)]
rToOnward "lasSensorTurretTest" $ rToOnward "lasSensorTurretTest" $
treePost treePost
[door, cenroom, triggerDoorRoom n, cleatOnward door] [door, cenroom, triggerDoorRoom n, cleatOnward door]
where
f i gw = fromJust $ find (isused ._rpType) (gw ^?! genRooms . ix (gw ^?! genInts . ix i) . rmPos)
isused UsedOutLink{_rplsChildNum = 0} = True
isused _ = False
lasCenSensEdge :: (RandomGen g) => Int -> State g (MetaTree Room String) -- note the double usage of the int, shouldn't cause a problem
lasCenSensEdge :: Int -> State LayoutVars (MetaTree Room String)
lasCenSensEdge n = do lasCenSensEdge n = do
cenroom <- shuffleLinks . lightSensByDoor n =<< cenLasTur cenroom' <- (shuffleLinks . lightSensByDoor n =<< cenLasTur)
(i,cenroom'') <- setRoomInt cenroom'
lshape <- takeOne [vShape, lShape, jShape, liShape]
let alight a rp = mntLSCond (fmap (fmap $ colorSH black) lshape) (PS (rotateV a $ _rpPos rp) (a +_rpDir rp))
let cenroom = cenroom''
& rmInPmnt <>~
[(0, alight pi . f i)
,(0, alight (0.5*pi) . f i)
,(0, alight (1.5*pi) . f i)]
let doorroom = triggerDoorRoom n let doorroom = triggerDoorRoom n
rToOnward "lasCenSensEdge" $ rToOnward "lasCenSensEdge" $
treeFromTrunk [door] $ treeFromTrunk [door] $
Node Node
cenroom cenroom
[ treePost [doorroom, cleatOnward door] [ treePost [doorroom, cleatOnward door]
, treePost [door, cleatLabel 0 corridor] , treePost [door, cleatLabel n corridor]
] ]
where
f i gw = fromJust $ find (isused ._rpType) (gw ^?! genRooms . ix (gw ^?! genInts . ix i) . rmPos)
isused UsedOutLink{_rplsChildNum = 0} = True
isused _ = False
setRoomInt :: Room -> State LayoutVars (Int, Room)
setRoomInt x = do
i <- nextLayoutInt
return (i, x & rmPmnts .:~ sps0 (PutWorldUpdate (f i)))
where
f i rid _ gw = gw & genInts . at i ?~ (gw ^?! genRooms . ix rid . rmMID . _Just)
lasRunYinYang :: (RandomGen g) => State g (MetaTree Room String) lasRunYinYang :: (RandomGen g) => State g (MetaTree Room String)
lasRunYinYang = do lasRunYinYang = do
src/Dodge/Room/Tutorial.hs
+201 -164
View File
@@ -1,42 +1,42 @@
{-# OPTIONS_GHC -Wno-unused-imports #-} {-# OPTIONS_GHC -Wno-unused-imports #-}
module Dodge.Room.Tutorial where module Dodge.Room.Tutorial where
import Data.Maybe
import Dodge.LockAndKey
import Dodge.Room.SensorDoor
import Dodge.Room.Room
import Dodge.Data.AmmoType
import Dodge.Room.Path
import Dodge.Room.Pillar
import Dodge.Room.Boss
import Dodge.Room.Tanks
import Dodge.Room.LongDoor
import Dodge.Layout
import Dodge.Item.Held.Utility
import Control.Monad import Control.Monad
import qualified Data.IntMap.Strict as IM import qualified Data.IntMap.Strict as IM
import qualified Data.IntSet as IS import qualified Data.IntSet as IS
import Data.Maybe
import Data.Maybe (mapMaybe) import Data.Maybe (mapMaybe)
import qualified Data.Set as S import qualified Data.Set as S
import Dodge.Cleat import Dodge.Cleat
import Dodge.Data.AmmoType
import Dodge.Data.GenWorld import Dodge.Data.GenWorld
import Dodge.Data.MTRS import Dodge.Data.MTRS
import Dodge.Default.Terminal import Dodge.Default.Terminal
import Dodge.Item.Ammo import Dodge.Item.Ammo
import Dodge.Item.Held.Cane import Dodge.Item.Held.Cane
import Dodge.Item.Held.Utility
import Dodge.Layout
import Dodge.LevelGen.PlacementHelper import Dodge.LevelGen.PlacementHelper
import Dodge.LockAndKey
import Dodge.Placement.Instance import Dodge.Placement.Instance
import Dodge.PlacementSpot import Dodge.PlacementSpot
import Dodge.Room.Airlock import Dodge.Room.Airlock
import Dodge.Room.Boss
import Dodge.Room.Corridor import Dodge.Room.Corridor
import Dodge.Room.Door import Dodge.Room.Door
import Dodge.Room.LasTurret import Dodge.Room.LasTurret
import Dodge.Room.Link import Dodge.Room.Link
import Dodge.Room.LongDoor
import Dodge.Room.Ngon import Dodge.Room.Ngon
import Dodge.Room.Path
import Dodge.Room.Pillar
import Dodge.Room.Procedural import Dodge.Room.Procedural
import Dodge.Room.RezBox import Dodge.Room.RezBox
import Dodge.Room.RoadBlock import Dodge.Room.RoadBlock
import Dodge.Room.Room import Dodge.Room.Room
import Dodge.Room.SensorDoor
import Dodge.Room.Tanks
import Dodge.Room.Warning import Dodge.Room.Warning
import Dodge.RoomLink import Dodge.RoomLink
import Dodge.Terminal import Dodge.Terminal
@@ -52,45 +52,50 @@ tutAnoTree :: State LayoutVars MTRS
tutAnoTree = do tutAnoTree = do
foldMTRS foldMTRS
[ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox [ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
-- , return . tToBTree "door" $ treePost [corridor, cleatOnward door]
, corDoor , corDoor
-- , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor) , lasSensorTurretTest
, lasRunRand --ccc , passthroughLockKeyLists lockRoomKeyItems itemRooms
-- , passthroughLockKeyLists lockRoomKeyItems itemRooms --bbb , -- , return . tToBTree "door" $ treePost [corridor, cleatOnward door]
, tToBTree "door" . return <$> return (cleatOnward door) --bbb corDoor
, tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor) --bbb , -- , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
-- , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor) --bbb lasRunRand
-- , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor) --bbb , corDoor
-- , passthroughLockKeyLists --bbb , passthroughLockKeyLists lockRoomKeyItems itemRooms
-- [(sensorRoomRunPast ElectricSensor, takeOne --bbb , -- , passthroughLockKeyLists lockRoomKeyItems itemRooms
-- [-- CRAFT (ENERGYBALLCRAFT TeslaBall) , --bbb tToBTree "door" . return <$> return (cleatOnward door)
-- HELD SPARKGUN])] --bbb , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
-- itemRooms --bbb , -- , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
-- , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor) --bbb -- , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
-- , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor) --bbb -- , passthroughLockKeyLists
, tToBTree "sdr" . return . cleatOnward <$> --bbb -- [(sensorRoomRunPast ElectricSensor, takeOne
(shuffleLinks =<< distributerRoom BulletAmmo 100000) --bbb -- [-- CRAFT (ENERGYBALLCRAFT TeslaBall) ,
--aaa-- , return $ tToBTree "cor" $ return $ cleatOnward corridor --bbb -- HELD SPARKGUN])]
--aaa-- --, tToBTree "sdr" . return . cleatOnward <$> slowDoorRoom --bbb -- itemRooms
--aaa---- , tToBTree "sr" . return . cleatOnward <$> tanksRoom [] [] --bbb -- , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
--aaa-- , return $ tToBTree "door" $ return $ cleatOnward door --bbb -- , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
--aaa-- , return $ tToBTree "cor" $ return $ cleatOnward corridor --bbb tToBTree "sdr" . return . cleatOnward
--aaa-- , tToBTree "sdr" . return . cleatOnward <$> --bbb <$> (shuffleLinks =<< distributerRoom BulletAmmo 100000)
--aaa-- (shuffleLinks =<< tanksPipesRoom) --bbb -- aaa-- , return $ tToBTree "cor" $ return $ cleatOnward corridor
--aaa-- , return $ tToBTree "cor" $ return $ cleatOnward corridor --bbb -- aaa-- --, tToBTree "sdr" . return . cleatOnward <$> slowDoorRoom
--aaa-- , return $ tToBTree "cor" $ return $ cleatOnward corridor --bbb -- aaa---- , tToBTree "sr" . return . cleatOnward <$> tanksRoom [] []
--aaa-- , return $ tToBTree "cor" $ return $ cleatOnward corridor --bbb -- aaa-- , return $ tToBTree "door" $ return $ cleatOnward door
--aaa , return $ tToBTree "cor" $ return $ cleatOnward corridor --bbb -- aaa-- , return $ tToBTree "cor" $ return $ cleatOnward corridor
--aaa , return $ tToBTree "cor" $ return $ cleatOnward corridor --bbb -- aaa-- , tToBTree "sdr" . return . cleatOnward <$>
--aaa , return $ tToBTree "cor" $ return $ cleatOnward corridor --bbb -- aaa-- (shuffleLinks =<< tanksPipesRoom)
--aaa , return $ tToBTree "door" $ return $ cleatOnward door --bbb -- aaa-- , return $ tToBTree "cor" $ return $ cleatOnward corridor
--aaa , tutHub --bbb -- aaa-- , return $ tToBTree "cor" $ return $ cleatOnward corridor
--aaa , chasmSpitTerminal --bbb -- aaa-- , return $ tToBTree "cor" $ return $ cleatOnward corridor
--aaa , tutLight --bbb -- aaa , return $ tToBTree "cor" $ return $ cleatOnward corridor
--aaa , tutDrop --bbb -- aaa , return $ tToBTree "cor" $ return $ cleatOnward corridor
--aaa , return $ tToBTree "cor" $ return $ cleatOnward corridor --bbb -- aaa , return $ tToBTree "cor" $ return $ cleatOnward corridor
--aaa ---- , AnTree $ pickupTut --bbb -- aaa , return $ tToBTree "door" $ return $ cleatOnward door
--aaa ---- , AnTree $ weaponTut --bbb -- aaa , tutHub
--bbb -- aaa , chasmSpitTerminal
--bbb -- aaa , tutLight
--bbb -- aaa , tutDrop
--bbb -- aaa , return $ tToBTree "cor" $ return $ cleatOnward corridor
--bbb -- aaa ---- , AnTree $ pickupTut
--bbb -- aaa ---- , AnTree $ weaponTut
] ]
foldMTRS :: foldMTRS ::
@@ -100,13 +105,6 @@ foldMTRS xs = do
ys <- sequence xs ys <- sequence xs
return $ foldr1 attachOnward' ys return $ foldr1 attachOnward' ys
setRoomInt :: Room -> State LayoutVars (Int, Room)
setRoomInt x = do
i <- nextLayoutInt
return (i, x & rmPmnts .:~ sps0 (PutWorldUpdate (f i)))
where
f i rid _ gw = gw & genInts . at i ?~ (gw ^?! genRooms . ix rid . rmMID . _Just)
setTreeInts :: Tree Room -> State LayoutVars ([Int], Tree Room) setTreeInts :: Tree Room -> State LayoutVars ([Int], Tree Room)
setTreeInts x = do setTreeInts x = do
y <- traverse setRoomInt x y <- traverse setRoomInt x
@@ -116,7 +114,7 @@ tutDrop :: State LayoutVars (MetaTree Room String)
tutDrop = do tutDrop = do
x <- shuffleLinks =<< roomNgon 6 100 x <- shuffleLinks =<< roomNgon 6 100
i <- nextLayoutInt i <- nextLayoutInt
--let y = decontamRoom i -- let y = decontamRoom i
(j, y) <- setRoomInt (decontamRoom i) (j, y) <- setRoomInt (decontamRoom i)
rm <- roomRectAutoLights 40 100 rm <- roomRectAutoLights 40 100
return $ return $
@@ -129,9 +127,9 @@ tutDrop = do
in putMessageTerminal in putMessageTerminal
(defaultTerminal & tmBootLines .~ ss <> tlSetStatus (TerminalPressTo $ show x <> "QUIT") <> tlDoEffect TmWdWdPowerDownTerminal) (defaultTerminal & tmBootLines .~ ss <> tlSetStatus (TerminalPressTo $ show x <> "QUIT") <> tlDoEffect TmWdWdPowerDownTerminal)
& plSpot & plSpot
.~ rprBoolShift .~ rprBoolShift
isUnusedLnk isUnusedLnk
(\(p, a) -> ((p + 10 *.* unitVectorAtAngle (a - pi / 2), a), S.singleton UsedPosLow)) (\(p, a) -> ((p + 10 *.* unitVectorAtAngle (a - pi / 2), a), S.singleton UsedPosLow))
ss = ss =
[ makeTermLine "--------------------------------------------" [ makeTermLine "--------------------------------------------"
, makeTermLine "YOU CAN ONLY CARRY A LIMITED AMOUNT OF ITEMS" , makeTermLine "YOU CAN ONLY CARRY A LIMITED AMOUNT OF ITEMS"
@@ -152,18 +150,24 @@ cChasm = do
x <- state $ randomR (150, 300) x <- state $ randomR (150, 300)
y <- state $ randomR (150, 300) y <- state $ randomR (150, 300)
roomRectAutoLights x y roomRectAutoLights x y
<&> rmLinks %~ setOutLinks (isCornerLink NorthWest) <&> rmLinks
<&> rmLinks %~ setInLinks (isCornerLink SouthWest) %~ setOutLinks (isCornerLink NorthWest)
<&> rmPmnts <>~ [sps0 $ putConvexChasm (rectNSWE (y -50) 50 0 (x -50))] <&> rmLinks
%~ setInLinks (isCornerLink SouthWest)
<&> rmPmnts
<>~ [sps0 $ putConvexChasm (rectNSWE (y - 50) 50 0 (x - 50))]
lChasm :: State LayoutVars Room lChasm :: State LayoutVars Room
lChasm = do lChasm = do
x <- state $ randomR (150, 300) x <- state $ randomR (150, 300)
y <- state $ randomR (150, 300) y <- state $ randomR (150, 300)
roomRectAutoLights x y roomRectAutoLights x y
<&> rmLinks %~ setOutLinks (isCornerLink NorthWest) <&> rmLinks
<&> rmLinks %~ setInLinks (isCornerLink SouthEast) %~ setOutLinks (isCornerLink NorthWest)
<&> rmPmnts <>~ [sps0 $ putConvexChasm (rectNSWE (y -50) 0 0 (x -50))] <&> rmLinks
%~ setInLinks (isCornerLink SouthEast)
<&> rmPmnts
<>~ [sps0 $ putConvexChasm (rectNSWE (y - 50) 0 0 (x - 50))]
-- the Float is the width of the bridge -- the Float is the width of the bridge
zChasm :: Float -> State LayoutVars Room zChasm :: Float -> State LayoutVars Room
@@ -171,13 +175,16 @@ zChasm z = do
x <- state $ randomR (150, 300) x <- state $ randomR (150, 300)
y <- state $ randomR (150, 300) y <- state $ randomR (150, 300)
roomRectAutoLights x y roomRectAutoLights x y
<&> rmLinks %~ setOutLinks (isCornerLink NorthWest) <&> rmLinks
<&> rmLinks %~ setInLinks (isCornerLink SouthEast) %~ setOutLinks (isCornerLink NorthWest)
<&> rmPath %~ addNodesCrossing (V2 0 (y/2),V2 x (y/2)) <&> rmLinks
%~ setInLinks (isCornerLink SouthEast)
<&> rmPath
%~ addNodesCrossing (V2 0 (y / 2), V2 x (y / 2))
<&> rmPmnts <&> rmPmnts
<>~ [ sps0 $ putConvexChasm (rectNSWE (y / 2 - z) 0 0 (x -50)) <>~ [ sps0 $ putConvexChasm (rectNSWE (y / 2 - z) 0 0 (x - 50))
, sps0 $ putConvexChasm (rectNSWE y (y / 2 + z) 50 x) , sps0 $ putConvexChasm (rectNSWE y (y / 2 + z) 50 x)
] ]
midChasm :: State LayoutVars Room midChasm :: State LayoutVars Room
midChasm = do midChasm = do
@@ -187,9 +194,12 @@ midChasm = do
cs <- join $ takeOne [cenoct x y, censquare x y] cs <- join $ takeOne [cenoct x y, censquare x y]
shuffleLinks $ shuffleLinks $
r r
& rmLinks %~ setOutLinks (isMidEdgeLink r North) & rmLinks
& rmLinks %~ setInLinks (isMidEdgeLink r South) %~ setOutLinks (isMidEdgeLink r North)
& rmPmnts <>~ cs & rmLinks
%~ setInLinks (isMidEdgeLink r South)
& rmPmnts
<>~ cs
where where
censquare x y = do censquare x y = do
z <- state $ randomR (40, 60) z <- state $ randomR (40, 60)
@@ -206,26 +216,31 @@ midChasmPlatform = do
cs <- join $ takeOne [censquare x y] cs <- join $ takeOne [censquare x y]
shuffleLinks $ shuffleLinks $
r r
& rmLinks %~ setOutLinks (isMidEdgeLink r North) & rmLinks
& rmLinks %~ setInLinks (isMidEdgeLink r South) %~ setOutLinks (isMidEdgeLink r North)
& rmPmnts <>~ cs & rmLinks
%~ setInLinks (isMidEdgeLink r South)
& rmPmnts
<>~ cs
where where
censquare x y = do censquare x y = do
z <- state $ randomR (40, 60) z <- state $ randomR (40, 60)
let (chsms,clfs) = sqPlatformChasm 20 (min x y/2 - z) let (chsms, clfs) = sqPlatformChasm 20 (min x y / 2 - z)
--return [sps0 $ putConvexChasm (rectNSWE (y - z) z z (x - z))] -- return [sps0 $ putConvexChasm (rectNSWE (y - z) z z (x - z))]
return [sps0 $ PutChasm return
(fmap (fmap (+ V2 (x/2) (y/2))) chsms) [ sps0 $
(fmap (fmap (+ V2 (x/2) (y/2))) clfs) PutChasm
]-- (rectNSWE (y - z) z z (x - z))] (fmap (fmap (+ V2 (x / 2) (y / 2))) chsms)
-- cenoct x y = (fmap (fmap (+ V2 (x / 2) (y / 2))) clfs)
-- return ] -- (rectNSWE (y - z) z z (x - z))]
-- [sps0 $ putConvexChasm $ (V2 (x / 2) (y / 2) +) <$> polyOrthDist 8 (min x y / 2 - 25)] -- cenoct x y =
-- return
-- [sps0 $ putConvexChasm $ (V2 (x / 2) (y / 2) +) <$> polyOrthDist 8 (min x y / 2 - 25)]
sqPlatformChasm :: Float -> Float -> ([[Point2]],[[Point2]]) sqPlatformChasm :: Float -> Float -> ([[Point2]], [[Point2]])
sqPlatformChasm b a = sqPlatformChasm b a =
( [[ibr,obr,otr,itr],[itr,otr,otl,itl],[itl,otl,obl,ibl],[ibl,obl,obr,ibr]] ( [[ibr, obr, otr, itr], [itr, otr, otl, itl], [itl, otl, obl, ibl], [ibl, obl, obr, ibr]]
, [[obr,otr,otl,obl], [ibr,ibl, itl, itr]] , [[obr, otr, otl, obl], [ibr, ibl, itl, itr]]
) )
where where
obr = V2 a (-a) obr = V2 a (-a)
@@ -237,10 +252,10 @@ sqPlatformChasm b a =
itl = V2 (-b) b itl = V2 (-b) b
itr = V2 b b itr = V2 b b
sqSpitChasm :: Float -> Float -> ([[Point2]],[[Point2]]) sqSpitChasm :: Float -> Float -> ([[Point2]], [[Point2]])
sqSpitChasm b a = sqSpitChasm b a =
( [[ibr,obr,otr,itr],[itr,otr,otl,itl],[itl,otl,obl,ibl]] ( [[ibr, obr, otr, itr], [itr, otr, otl, itl], [itl, otl, obl, ibl]]
, [[ibr,obr,otr,otl,obl,ibl,itl,itr]] , [[ibr, obr, otr, otl, obl, ibl, itl, itr]]
) )
where where
obr = V2 a (-a) obr = V2 a (-a)
@@ -260,24 +275,30 @@ midChasmSpit = do
cs <- join $ takeOne [censquare x y] cs <- join $ takeOne [censquare x y]
shuffleLinks $ shuffleLinks $
r r
& rmLinks %~ setOutLinks & rmLinks
(\rl -> isMidEdgeLink r North rl %~ setOutLinks
|| isMidEdgeLink r East rl ( \rl ->
|| isMidEdgeLink r West rl isMidEdgeLink r North rl
|| isMidEdgeLink r East rl
|| isMidEdgeLink r West rl
) )
& rmLinks %~ setInLinks (isMidEdgeLink r South) & rmLinks
& rmPmnts .~ cs %~ setInLinks (isMidEdgeLink r South)
& rmPmnts
.~ cs
where where
censquare x y = do censquare x y = do
z <- state $ randomR (40, 60) z <- state $ randomR (40, 60)
let (chsms,clfs) = sqSpitChasm 20 (min x y/2 - z) let (chsms, clfs) = sqSpitChasm 20 (min x y / 2 - z)
return [sps0 $ PutChasm return
(fmap (fmap (+ V2 (x/2) (y/2))) chsms) [ sps0 $
(fmap (fmap (+ V2 (x/2) (y/2))) clfs) PutChasm
]-- (rectNSWE (y - z) z z (x - z))] (fmap (fmap (+ V2 (x / 2) (y / 2))) chsms)
-- cenoct x y = (fmap (fmap (+ V2 (x / 2) (y / 2))) clfs)
-- return ] -- (rectNSWE (y - z) z z (x - z))]
-- [sps0 $ putConvexChasm $ (V2 (x / 2) (y / 2) +) <$> polyOrthDist 8 (min x y / 2 - 25)] -- cenoct x y =
-- return
-- [sps0 $ putConvexChasm $ (V2 (x / 2) (y / 2) +) <$> polyOrthDist 8 (min x y / 2 - 25)]
chasmSpitTerminal :: State LayoutVars MTRS chasmSpitTerminal :: State LayoutVars MTRS
chasmSpitTerminal = do chasmSpitTerminal = do
@@ -285,28 +306,37 @@ chasmSpitTerminal = do
y <- midChasmSpit y <- midChasmSpit
l3 <- mntLightLnkCond $ resetPLUse $ rprBool $ \rp _ -> isOutLnkNum 0 rp l3 <- mntLightLnkCond $ resetPLUse $ rprBool $ \rp _ -> isOutLnkNum 0 rp
l4 <- mntLightLnkCond $ resetPLUse $ rprBool $ \rp _ -> isOutLnkNum 1 rp l4 <- mntLightLnkCond $ resetPLUse $ rprBool $ \rp _ -> isOutLnkNum 1 rp
let y' = y & rmPmnts <>~ [l3,l4] let y' = y & rmPmnts <>~ [l3, l4]
return $ tToBTree "chasmTerm" $ Node (addDoorToggleTerminal' i1 (PS 150 0) y') return $
[treePost [triggerDoorRoom i1, critDeadEnd] tToBTree "chasmTerm" $
,treePost [triggerDoorRoom i1, critDeadEnd] Node
,return $ cleatOnward $ triggerDoorRoom i1 (addDoorToggleTerminal' i1 (PS 150 0) y')
] [ treePost [triggerDoorRoom i1, critDeadEnd]
, treePost [triggerDoorRoom i1, critDeadEnd]
, return $ cleatOnward $ triggerDoorRoom i1
]
polyChasm :: Int -> Float -> State LayoutVars Room polyChasm :: Int -> Float -> State LayoutVars Room
polyChasm n x = polyChasm n x =
shuffleLinks shuffleLinks
=<< ( roomNgon n x =<< ( roomNgon n x
<&> rmPmnts <>~ [sps0 $ putConvexChasm $ polyOrthDist n (x -30)] <&> rmPmnts
<&> rmLinks %~ setOutLinks (\rl -> rl ^. rlPos . _y > 0) <>~ [sps0 $ putConvexChasm $ polyOrthDist n (x - 30)]
<&> rmLinks %~ setInLinks (\rl -> rl ^. rlPos . _y < (5 - x)) <&> rmLinks
%~ setOutLinks (\rl -> rl ^. rlPos . _y > 0)
<&> rmLinks
%~ setInLinks (\rl -> rl ^. rlPos . _y < (5 - x))
) )
polyChasmC :: Int -> Float -> State LayoutVars Room polyChasmC :: Int -> Float -> State LayoutVars Room
polyChasmC n x = polyChasmC n x =
roomNgon n x roomNgon n x
<&> rmPmnts <>~ [sps0 $ putConvexChasm $ rectNSWE x (60 - x) (-40) 40] <&> rmPmnts
<&> rmLinks %~ setInLinks (\rl -> PolyEdge 1 `S.member` (rl ^. rlType)) <>~ [sps0 $ putConvexChasm $ rectNSWE x (60 - x) (-40) 40]
<&> rmLinks %~ setOutLinks (\rl -> PolyEdge (n -1) `S.member` (rl ^. rlType)) <&> rmLinks
%~ setInLinks (\rl -> PolyEdge 1 `S.member` (rl ^. rlType))
<&> rmLinks
%~ setOutLinks (\rl -> PolyEdge (n - 1) `S.member` (rl ^. rlType))
chasmSimpleMaze :: State LayoutVars Room chasmSimpleMaze :: State LayoutVars Room
chasmSimpleMaze = chasmSimpleMaze =
@@ -338,10 +368,11 @@ tutLight = do
return $ return $
tToBTree "TutLight" $ tToBTree "TutLight" $
treePost treePost
[ x & rmPmnts <>~ [ x
[sps g (PutFlIt led) & rmPmnts
,sps g (PutFlIt battery) <>~ [ sps g (PutFlIt led)
] , sps g (PutFlIt battery)
]
, corridor & rmPmnts .~ mempty , corridor & rmPmnts .~ mempty
, removeLights y , removeLights y
, corridor & rmPmnts .~ mempty , corridor & rmPmnts .~ mempty
@@ -353,9 +384,12 @@ tutLight = do
g = PSPos (\x _ -> f x) (const id) Nothing g = PSPos (\x _ -> f x) (const id) Nothing
where where
f x = case _rpType x of f x = case _rpType x of
NotLink{} | null (x ^. rpPlacementUse . at UsedPosFloor) NotLink{}
-> Just (PS (_rpPos x) (_rpDir x) | null (x ^. rpPlacementUse . at UsedPosFloor) ->
, x & rpPlacementUse . at UsedPosFloor ?~ ()) Just
( PS (_rpPos x) (_rpDir x)
, x & rpPlacementUse . at UsedPosFloor ?~ ()
)
_ -> Nothing _ -> Nothing
removeLights :: Room -> Room removeLights :: Room -> Room
@@ -382,13 +416,13 @@ tutHub = do
. analyserByDoor (RequireEquipment (AMMOMAG DRUMMAG)) i . analyserByDoor (RequireEquipment (AMMOMAG DRUMMAG)) i
. (rmInPmnt .:~ (0, a)) . (rmInPmnt .:~ (0, a))
. addDoorAtNthLinkToggleTerminal 1 ss j . addDoorAtNthLinkToggleTerminal 1 ss j
-- . addDoorAtNthLinkToggleInterrupt 2 ds j -- . addDoorAtNthLinkToggleInterrupt 2 ds j
. addDoorAtNthLinkToggleInterrupt 2 ds j1 . addDoorAtNthLinkToggleInterrupt 2 ds j1
=<< roomNgon 6 100 =<< roomNgon 6 100
-- bcor <- treeAttachDeep (return door) <$> blockedCorridor -- bcor <- treeAttachDeep (return door) <$> blockedCorridor
r1 <- r burstRifle <&> rmPmnts .:~ itemshiftterminal r1 <- r burstRifle <&> rmPmnts .:~ itemshiftterminal
r2 <- ammoroom (drumMag & itConsumables ?~ 90) -- <&> rmPmnts .:~ tutorialterminal r2 <- ammoroom (drumMag & itConsumables ?~ 90) -- <&> rmPmnts .:~ tutorialterminal
--r2 <- r (tinMag & itConsumables ?~ 500) -- r2 <- r (tinMag & itConsumables ?~ 500)
return $ return $
tToBTree "DoorTest" $ tToBTree "DoorTest" $
Node Node
@@ -396,9 +430,9 @@ tutHub = do
[ treeFromPost [triggerDoorRoom i] r1 [ treeFromPost [triggerDoorRoom i] r1
, treeFromPost [triggerDoorRoom j] r2 , treeFromPost [triggerDoorRoom j] r2
, treeFromTrunk [triggerDoorRoom j1] wbp , treeFromTrunk [triggerDoorRoom j1] wbp
-- , (rmClusterStatus . csLinks . at OnwardCluster .~ Nothing) , -- , (rmClusterStatus . csLinks . at OnwardCluster .~ Nothing)
-- <$> treeAttachDeep wbp (return corridor) -- <$> treeAttachDeep wbp (return corridor)
, treeFromPost [] (cleatOnward $ triggerDoorRoom k & rmInPmnt . ix 0 . _1 .~ 1) treeFromPost [] (cleatOnward $ triggerDoorRoom k & rmInPmnt . ix 0 . _1 .~ 1)
] ]
where where
ds = ["DESTROY THIS TO OPEN THE DOOR"] ds = ["DESTROY THIS TO OPEN THE DOOR"]
@@ -420,9 +454,9 @@ tutHub = do
putMessageTerminal putMessageTerminal
(defaultTerminal & tmBootLines .~ ss' <> tlSetStatus (TerminalPressTo "QUIT") <> tlDoEffect TmWdWdPowerDownTerminal) (defaultTerminal & tmBootLines .~ ss' <> tlSetStatus (TerminalPressTo "QUIT") <> tlDoEffect TmWdWdPowerDownTerminal)
& plSpot & plSpot
.~ rprBoolShift .~ rprBoolShift
isUnusedLnk isUnusedLnk
(\(p, a) -> ((p + 10 *.* unitVectorAtAngle (a - pi / 2), a), S.singleton UsedPosLow)) (\(p, a) -> ((p + 10 *.* unitVectorAtAngle (a - pi / 2), a), S.singleton UsedPosLow))
ss' = ss' =
[ makeTermLine "---------------------------------------------" [ makeTermLine "---------------------------------------------"
, makeTermLine "HOLD [CAPS] AND SCROLL" , makeTermLine "HOLD [CAPS] AND SCROLL"
@@ -455,8 +489,8 @@ getCrsFromRooms' is gw = fmap h $ show $ foldMap f (IM.restrictKeys (gw ^. genRo
js = getRoomsFromInts is gw js = getRoomsFromInts is gw
f rm = shortShow <$> rm ^.. rmPmnts . each . plType f rm = shortShow <$> rm ^.. rmPmnts . each . plType
--f rm = foldMap g $ rm ^. rmPmnts -- f rm = foldMap g $ rm ^. rmPmnts
--g x = case x ^. plType of -- g x = case x ^. plType of
-- PutCrit _ -> [x ^?! plMID . _Just] -- PutCrit _ -> [x ^?! plMID . _Just]
-- _ -> [] -- _ -> []
@@ -480,26 +514,28 @@ sensorTut =
-- <> tlSetStatus (TerminalPressTo "CONTINUE") -- <> tlSetStatus (TerminalPressTo "CONTINUE")
tutRezBox :: RandomGen g => State g Room tutRezBox :: (RandomGen g) => State g Room
tutRezBox = do tutRezBox = do
ls <- rezColor ls <- rezColor
return $ return $
roomRect 40 60 1 1 roomRect 40 60 1 1
& rmPmnts & rmPmnts
.~ [ sPS (V2 20 1) 0 $ PutLS ls .~ [ sPS (V2 20 1) 0 $ PutLS ls
, Placement (PS 0 0) PutNothing Nothing Nothing $ \w _ -> , Placement (PS 0 0) PutNothing Nothing Nothing $ \w _ ->
Just $ Just $
putImmediateMessageTerminal putImmediateMessageTerminal
( defaultTerminal & tmBootLines .~ s w ( defaultTerminal & tmBootLines .~ s w
<> tlSetStatus (TerminalPressTo "QUIT") <> tlSetStatus (TerminalPressTo "QUIT")
<> tlDoEffect TmWdWdPowerDownTerminal <> tlDoEffect TmWdWdPowerDownTerminal
-- <> tlDoEffect (TmWdWdLeaveTerminal "QUIT") -- <> tlDoEffect (TmWdWdLeaveTerminal "QUIT")
) )
& plSpot .~ PS (V2 20 0) 0 & plSpot
] .~ PS (V2 20 0) 0
]
& restrictInLinks (\(V2 _ h, _) -> h < 1) & restrictInLinks (\(V2 _ h, _) -> h < 1)
& restrictOutLinks (\(V2 _ h, _) -> h > 59) & restrictOutLinks (\(V2 _ h, _) -> h > 59)
& rmName .~ "tutRezBox" & rmName
.~ "tutRezBox"
where where
s w = tutorialMessage1 (w ^. gwWorld . cWorld . cwGen . cwgSeed) s w = tutorialMessage1 (w ^. gwWorld . cWorld . cwGen . cwgSeed)
@@ -517,23 +553,24 @@ tutorialMessage1 i =
, makeTermLine " [D] TO MOVE" , makeTermLine " [D] TO MOVE"
, makeTermLine "--------------------------------------------" , makeTermLine "--------------------------------------------"
] ]
-- <> tlSetStatus (TerminalPressTo "CONTINUE") -- <> tlSetStatus (TerminalPressTo "CONTINUE")
-- <> [ makeTermLine "AFTER EXITING THIS TERMINAL YOUR INVENTORY" -- <> [ makeTermLine "AFTER EXITING THIS TERMINAL YOUR INVENTORY"
-- , makeTermLine " AND NEARBY OBJECTS WILL BE DISPLAYED" -- , makeTermLine " AND NEARBY OBJECTS WILL BE DISPLAYED"
-- , makeTermLine "--------------------------------------------" -- , makeTermLine "--------------------------------------------"
-- ] -- ]
passthroughLockKeyLists :: passthroughLockKeyLists ::
[(Int -> State LayoutVars (MetaTree Room String), State LayoutVars ItemType)] [(Int -> State LayoutVars (MetaTree Room String), State LayoutVars ItemType)] ->
-> [(ItemType, State LayoutVars (MetaTree Room String))] [(ItemType, State LayoutVars (MetaTree Room String))] ->
-> State LayoutVars (MetaTree Room String) State LayoutVars (MetaTree Room String)
passthroughLockKeyLists ls ks = do passthroughLockKeyLists ls ks = do
i <- nextLayoutInt i <- nextLayoutInt
(functionlockroom, randomitemidentity) <- takeOne ls (functionlockroom, randomitemidentity) <- takeOne ls
lr <- functionlockroom i lr <- functionlockroom i
ii <- randomitemidentity ii <- randomitemidentity
keyroom <- fromJust $ lookup ii ks keyroom <- fromJust $ lookup ii ks
return $ return $
MTree MTree
("PassthroughLockKeyLists-" ++ show ii) ("PassthroughLockKeyLists-" ++ show ii)
(NodeMTree $ MTree "RassThroughLockKeyLists" (NodeMTree lr) [MBranch (toLabel i) keyroom]) (NodeMTree $ MTree "RassThroughLockKeyLists" (NodeMTree lr) [MBranch (toLabel i) keyroom])
[] []
src/Dodge/TestString.hs
+3 -1
View File
@@ -32,7 +32,9 @@ import Data.Foldable
import Data.Monoid import Data.Monoid
testStringInit :: Universe -> [String] testStringInit :: Universe -> [String]
testStringInit u = fmap show $ u ^.. uvWorld . cWorld . lWorld . machines . each . mcHP testStringInit u =
(fmap show $ u ^.. uvWorld . cWorld . lWorld . machines . each . mcType . _McDamSensor . sensAmount)
<> (fmap show $ u ^.. uvWorld . cWorld . lWorld . machines . each . mcMaterial)
--testStringInit u = map show (u ^.. uvWorld . cWorld . lWorld . machines . traverse . mcDir) --testStringInit u = map show (u ^.. uvWorld . cWorld . lWorld . machines . traverse . mcDir)
--testStringInit u = map show --testStringInit u = map show
-- (u ^.. uvWorld . cWorld . lWorld . machines . traverse .mcType . _McDistributer) -- (u ^.. uvWorld . cWorld . lWorld . machines . traverse .mcType . _McDistributer)
src/Dodge/Tree/Compose.hs
+1 -1
View File
@@ -3,7 +3,6 @@
-- | Combining and composing trees of trees. -- | Combining and composing trees of trees.
module Dodge.Tree.Compose ( module Dodge.Tree.Compose (
tToBTree, tToBTree,
overwriteLabel,
composeTree, composeTree,
decomposeTree, decomposeTree,
numMetaTree, numMetaTree,
@@ -16,6 +15,7 @@ module Dodge.Tree.Compose (
attachOnward, attachOnward,
attachOnward', attachOnward',
showIntsString, showIntsString,
overwriteLabel,
module Dodge.Data.MetaTree module Dodge.Data.MetaTree
) where ) where
src/Dodge/Wall/Damage.hs
+1
View File
@@ -43,6 +43,7 @@ damageWall wlid dt w = fromMaybe (mempty,w) $ do
& maybeDestroyDoor drid & maybeDestroyDoor drid
_ -> (mempty, w') _ -> (mempty, w')
-- the way that sensor damage is registered is not yet ideal
damageMachine :: Damage -> Int -> Int -> World -> (S.Set Int2, World) damageMachine :: Damage -> Int -> Int -> World -> (S.Set Int2, World)
damageMachine dam x mcid w = case w ^? cWorld . lWorld . machines . ix mcid of damageMachine dam x mcid w = case w ^? cWorld . lWorld . machines . ix mcid of
Just mc | Just se <- mc ^? mcType . _McDamSensor Just mc | Just se <- mc ^? mcType . _McDamSensor
tags
+261 -307
View File
File diff suppressed because it is too large Load Diff