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

Cleanup

Browse Source
This commit is contained in:
justin
2022-06-14 16:13:06 +01:00
parent a20602abdb
commit d0e3500cad
11 changed files with 106 additions and 38 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Annotation.hs
+1 -1
View File
@@ -20,7 +20,7 @@ annoToRoomTree an = case an of
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
return $ foldr1 attachOnward' mts
IntAnno f -> do
(g,i) <- get
put (g,i+1)
src/Dodge/PlacementSpot.hs
+5
View File
@@ -9,6 +9,7 @@ module Dodge.PlacementSpot
, unusedSpotAwayFromLink
, isUnusedLnk
, isInLnk
, isOutLnk
, unusedSpotNearInLink
, randDirPS
, unusedSpotAwayFromInLink
@@ -135,6 +136,10 @@ isInLnk :: RoomPos -> Bool
isInLnk rp = case _rpLinkStatus rp of
UsedInLink {} -> _rpPlacementUse rp == 0
_ -> False
isOutLnk :: RoomPos -> Bool
isOutLnk rp = case _rpLinkStatus rp of
UsedOutLink {} -> _rpPlacementUse rp == 0
_ -> False
useUnusedLnk :: PlacementSpot
useUnusedLnk = rprBool isUnusedLnk
src/Dodge/Room/Modify/Girder.hs
+24
View File
@@ -2,6 +2,7 @@ module Dodge.Room.Modify.Girder
( addGirderLights
, addGirderFrom
, addHighGirder
, addHighGirder'
, addGirderEW
, addGirderNS
, addGirderNS'
@@ -88,6 +89,22 @@ addGirder shapef col room = do
$ \ps1 ps2 -> sps0 $ PutShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2)
| i <- [1 .. numlnks - 2] ]
addGirder' :: RandomGen g => (Point2 -> Point2 -> Shape) -> Color -> Room -> State g Room
addGirder' shapef col room = do
let nslnks = length $ filter ((OnEdge North `S.member`) . _rlType) $ _rmLinks room
ewlnks = length $ filter ((OnEdge East `S.member`) . _rlType) $ _rmLinks room
nsgirds = girdson (FromEdge East) nslnks
ewgirds = girdson (FromEdge North) ewlnks
girders <- shuffle $ nsgirds ++ ewgirds
return $ room & rmPmnts .:~ foldr1 setFallback
(sps0 PutNothing : girders)
where
girdson f numlnks = [ twoRoomPoss
(isUnusedLnkType (f i))
(isUnusedLnkType (f i))
$ \ps1 ps2 -> sps0 $ PutShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2)
| i <- [0 .. numlnks - 1] ]
addHighGirder :: RandomGen g => Room -> State g Room
addHighGirder r = do
gsize <- takeOne [(20,10),(30,10),(40,10),(30,15)]
@@ -95,6 +112,13 @@ addHighGirder r = do
[girder, girderZ, girderV]
addGirder hgshape black r
addHighGirder' :: RandomGen g => Room -> State g Room
addHighGirder' r = do
gsize <- takeOne [(20,10),(30,10),(40,10),(30,15)]
hgshape <- takeOne $ map (\f -> uncurry (f 96) gsize)
[girder, girderZ, girderV]
addGirder' hgshape black r
randomLightPositions :: RandomGen g => Room -> State g [(Int,Int)]
randomLightPositions rm = do
let rmtype = _rmType rm
src/Dodge/Room/Pillar.hs
+2
View File
@@ -1,5 +1,6 @@
module Dodge.Room.Pillar where
import Dodge.Data
import Dodge.UseAll
import Dodge.PlacementSpot
import Dodge.Room.Modify.Girder
import Dodge.LevelGen.Data
@@ -45,6 +46,7 @@ roomPillars pillarsize w h wn hn = do
&& _rpLinkStatus rp == NotLink )
)
addGirderLights $ rm
& cleatSide
& rmPmnts .~ plmnts
& rmName .~ "rectPillars"
where
src/Dodge/Room/RezBox.hs
+19 -3
View File
@@ -40,6 +40,18 @@ rezBox ls = roomRect 40 60 1 1
& restrictOutLinks (\(V2 _ h,_)-> h > 59)
& rmName .~ "rezBox"
rezBox' :: RandomGen g => State g (MetaTree Room String)
rezBox' = do
col <- rezColor
return $ tToBTree "rezBox'" $ treePost
[roomRect 40 60 1 1
& rmPmnts .~ [ sPS (V2 20 1) 0 $ PutLS col]
& restrictInLinks (\(V2 _ h,_)-> h < 1)
& restrictOutLinks (\(V2 _ h,_)-> h > 59)
& rmName .~ "rezBox"
, cleatOnward door
]
rezBoxesWp :: RandomGen g => State g (Tree Room)
rezBoxesWp = do
w <- state $ randomR (100,400)
@@ -50,7 +62,7 @@ rezBoxesWp = do
let isnorth = S.member (OnEdge North) . _rlType
centralRoom <- shuffleLinks $(roomRectAutoLinks w h) {_rmPmnts = []}
& rmLinks %~ setLinkType InLink isnorth
onwardpassage <- maybeBlockedPassage
onwardpassage <- shootOutPassage
let n = length $ getLinksOfType (OnEdge North) $ _rmLinks centralRoom
let rezrooms = map adddoor
$ wpAdd theweapon aroom : replicate (n-2) aroom
@@ -62,6 +74,10 @@ rezBoxesWp = do
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]
rezBoxesWpCrit :: RandomGen g => State g (Tree Room)
rezBoxesWpCrit = do
w <- state $ randomR (200,400)
@@ -88,7 +104,7 @@ rezBoxesWpCrit = do
crAdd :: Room -> Room
crAdd = rmPmnts .:~ sPS (V2 20 10) (0.5*pi) randC1
rezBoxes :: RandomGen g => State g (Tree Room)
rezBoxes :: RandomGen g => State g (MetaTree Room String)
rezBoxes = do
w <- state $ randomR (100,400)
h <- state $ randomR (40,40)
@@ -99,7 +115,7 @@ rezBoxes = do
centralRoom <- shuffleLinks $ (roomRectAutoLinks w h) {_rmPmnts = []}
& rmLinks %~ setInLinks bottomEdgeTest
let n = length $ filter bottomEdgeTest $_rmLinks centralRoom
return $ treeFromTrunk [rezBox thecol, door]
return $ tToBTree "rezBoxes" $ treeFromTrunk [rezBox thecol, door]
$ Node centralRoom (replicate (n-1) dbox ++ [Node (cleatOnward door) []])
rezColor :: RandomGen g => State g LightSource
src/Dodge/Room/RoadBlock.hs
+4 -3
View File
@@ -72,16 +72,17 @@ dirtPoly = PutBlock DirtBlock 1 [] dirtWall . reverse
blockedCorridorCloseBlocks :: RandomGen g => State g Room
blockedCorridorCloseBlocks = do
r <- state $ randomR (0,pi)
r' <- state $ randomR (0,pi)
theblocks <- takeOne
[ -- [sPS (V2 20 40) r $ dirtPoly $ square 10]
[ [sPS (V2 20 40) r $ dirtPoly $ square 8]
--, [ sPS (V2 5 40) r $ dirtPoly $ square 10
-- , sPS (V2 35 40) (r+0.5) $ dirtPoly $ square 10
-- ]
--,
--[ sPS (V2 5 50) r $ dirtPoly $ square 10
--, sPS (V2 35 35) (r+0.5) $ dirtPoly $ square 10
[ sPS (V2 6 25) r $ dirtPoly $ square 10
, sPS (V2 35 20) (r+0.5) $ dirtPoly $ square 10
, [ sPS (V2 6 25) r $ dirtPoly $ square 8
, sPS (V2 35 20) r' $ dirtPoly $ square 8
]
]
return $ corridor & rmPmnts .~ theblocks
src/Dodge/Room/Room.hs
+20 -14
View File
@@ -13,7 +13,7 @@ import Dodge.Data
import Dodge.PlacementSpot
import Dodge.RoomLink
import Dodge.Default.Room
import Dodge.Item.Weapon.BulletGuns
import Dodge.Item.Weapon
import Dodge.Creature
import Dodge.Room.Pillar
import Dodge.Room.Girder
@@ -118,17 +118,20 @@ roomMiniIntro = do
rToOnward "roomMiniIntro" midroom
roomCenterPillar :: RandomGen g => State g Room
roomCenterPillar = shuffleLinks . restrictInLinks ((\p -> dist p (V2 120 0) < 10) . fst)
$ set rmPmnts plmnts
$ set rmName "roomCenterPillar"
$ roomRect 240 240 2 2
roomCenterPillar = do
addHighGirder' =<< (shuffleLinks . restrictInLinks ((\p -> dist p (V2 120 0) < 10) . fst)
$ cleatSide
$ set rmPmnts plmnts
$ set rmName "roomCenterPillar"
$ roomRect 240 240 2 2
)
where
plmnts =
[ blockLine (V2 115 115) (V2 115 125)
, blockLine (V2 125 115) (V2 125 125)
, mntLightLnkCond useUnusedLnk
, mntLightLnkCond useUnusedLnk
-- , mntLightLnkCond useUnusedLnk
, mntLightLnkCond (resetPLUse $ rprBool $ \rp _ -> isInLnk rp)
, mntLightLnkCond (resetPLUse $ rprBool $ \rp _ -> isOutLnk rp)
]
{- Probabilites of the type of the first floor weapon. -}
@@ -137,6 +140,8 @@ randFirstWeapon = takeOne $ map PutFlIt $
replicate 10 pistol
++ replicate 5 (bangStick 4)
++ replicate 5 (bangCaneX 3)
++ replicate 5 bangCone
++ [lasGun]
weaponEmptyRoom :: RandomGen g => State g (Tree Room)
weaponEmptyRoom = do
@@ -151,7 +156,7 @@ weaponEmptyRoom = do
f (V2 x y,a) = (a == pi && x > 25 && x < w - 25) || (a /= 0 && y > w - 30)
rm <- addHighGirder >=> shuffleLinks
$ restrictRMInLinksPD f (roomRect w h 2 2 & rmPmnts .~ plmnts)
return $ treeFromTrunk [ corridor] (pure $ cleatOnward rm )
return $ treePost [ corridor, cleatSide $ cleatOnward rm ]
weaponUnderCrits :: RandomGen g => Int -> State g (MetaTree Room String)
weaponUnderCrits i = do
@@ -166,7 +171,7 @@ weaponUnderCrits i = do
]
rcp <- roomCenterPillar
rmpils <- roomPillars 30 240 240 2 2
deadEndRoom' <- takeOne [ addwpat (V2 120 20) rmpils , addwpat (V2 120 20) rcp]
deadEndRoom' <- takeOne [ addwpat (V2 120 20) rmpils , addwpat (V2 120 20) $ cleatSide rcp]
junctionRoom <- takeOne [ tEast, tWest]
rToOnward "weaponUnderCrits" $ treeFromTrunk [ corridorN , corridorN]
$ Node junctionRoom [continuationRoom ,pure deadEndRoom' ]
@@ -177,14 +182,14 @@ weaponBehindPillar = do
wpos <- takeOne [V2 120 160,V2 80 40,V2 160 40,V2 220 200,V2 40 200,V2 120 35]
cpos <- takeOne $ [V2 x y | x <- [20,220], y <- [20,40]] ++ [V2 120 160,V2 120 200]
rcp <- roomCenterPillar
return $ treeFromTrunk
return $ treePost
[ corridor
, rcp & rmPmnts ++.~
[sPS wpos wpa $ RandPS randFirstWeapon
,sPS cpos (argV $ V2 120 80 -.- cpos) randC1
]
, cleatOnward $ set rmPmnts [sPS (V2 20 60) (negate $ pi/2) randC1] corridorN
]
(pure . cleatOnward $ set rmPmnts [sPS (V2 20 60) (negate $ pi/2) randC1] corridorN)
weaponBetweenPillars :: RandomGen g => State g (Tree Room)
weaponBetweenPillars = do
@@ -211,12 +216,13 @@ weaponLongCorridor = do
connectingRoom <- takeOne [tEast & rmPmnts .~ [spanLightI (V2 (-30) 40) (V2 (-30) 80)] ]
i1 <- state $ randomR (2,5)
i2 <- state $ randomR (2,5)
let branch1 = treeFromTrunk (replicate i1 corridorN) (pure . cleatOnward $ putCrs connectingRoom)
let branch1 = treeFromTrunk (replicate i1 corridorN)
(pure . cleatSide . cleatOnward $ putCrs connectingRoom)
let branch2 = treeFromTrunk (replicate i2 corridorN) (pure . cleatSide $ putWp corridor)
return $ Node rt [branch1,branch2]
where
putCrs = over rmPmnts (++ [sPS (V2 10 40) (-pi/2) randC1 ,sPS (V2 (-10) 40) (-pi/2) randC1 ])
putWp = set rmPmnts [sPS (V2 20 60) 0 $ RandPS randFirstWeapon ,spanLightI (V2 0 40) (V2 40 40)]
putCrs = rmPmnts .++~ [sPS (V2 10 40) (-pi/2) randC1 ,sPS (V2 (-10) 40) (-pi/2) randC1 ]
putWp = rmPmnts .~ [sPS (V2 20 60) 0 $ RandPS randFirstWeapon ,spanLightI (V2 0 40) (V2 40 40)]
critInDeadEnd :: Room
critInDeadEnd = deadEndRoom & rmPmnts .~ [sPS (V2 0 0) 0 randC1]
src/Dodge/Room/Start.hs
+20 -13
View File
@@ -1,5 +1,8 @@
{-# LANGUAGE TupleSections #-}
module Dodge.Room.Start where
module Dodge.Room.Start
( startRoom
, randomChallenges
) where
import Dodge.UseAll
import Dodge.Data
import Dodge.LevelGen.Data
@@ -53,12 +56,13 @@ startRoom i = join (takeOne
[-- (,) (0.5::Float) ((chainUses <$> sequence [powerFakeout,fmap fst $weaponRoom i])
-- <&> (,TreeSubLabelling "chainUses <$> sequence [powerFakeout,weaponRoom i]" Nothing))
-- wat
-- rezBoxesWp >>= rToOnward "rezBoxesWp"
-- , rezBoxThenWeaponRoom i
-- , rezBoxesWpCrit >>= rToOnward "rezBoxesWpCrit"
runPastStart i >>= rToOnward ("runPastStart " ++ show i)
-- , startCrafts >>= roomsContaining' [] >>= rezBoxThenRooms
-- >>= rToOnward "startCrafts >>= roomsContaining [] >>= rezBoxThenRooms"
-- rezBoxesWp >>= rToOnward "rezBoxesWp"
attachOnward "rezBoxThenWeaponRoom" <$> preCritStart <*> weaponRoom i
-- startThenWeaponRoom i
-- rezBoxesWpCrit >>= rToOnward "rezBoxesWpCrit"
-- runPastStart i >>= rToOnward ("runPastStart " ++ show i)
-- startCrafts >>= roomsContaining' [] >>= preCritStart
-- >>= rToOnward "startCrafts >>= roomsContaining [] >>= preCritStart"
])
randomChallenges :: RandomGen g => State g (MetaTree Room String)
randomChallenges = shootingRange
@@ -84,18 +88,21 @@ rezBoxesThenWeaponRoom :: RandomGen g => Int -> State g (MetaTree Room String)
rezBoxesThenWeaponRoom i = do
rboxes <- rezBoxes
wroom <- weaponRoom i
return $ tToBTree "rboxes" rboxes `attachOnward` wroom
return $ attachOnward "rezBoxesThenWeaponRoom" rboxes wroom
rezBoxThenWeaponRoom :: RandomGen g => Int -> State g (MetaTree Room String)
rezBoxThenWeaponRoom i = do
rcol <- rezColor
preCritStart :: RandomGen g => State g (MetaTree Room String)
preCritStart = join $ takeOne [rezBoxes,rezBox']
startThenWeaponRoom :: RandomGen g => Int -> State g (MetaTree Room String)
startThenWeaponRoom i = do
startrm <- preCritStart
wroom <- weaponRoom i
return $ tToBTree "rezbox" (treePost [rezBox rcol, cleatOnward door]) `attachOnward` wroom
return $ attachOnward "rezBoxThenWeaponRoom" startrm wroom
rezBoxThenRoom :: RandomGen g => Room -> State g (Tree Room)
rezBoxThenRoom r = do
rcol <- rezColor
return $ treeFromTrunk [ rezBox rcol, door] $ pure r
return $ treeFromTrunk [ rezBox rcol, cleatOnward door] $ pure r
rezBoxThenRooms :: RandomGen g => Tree Room -> State g (Tree Room)
rezBoxThenRooms r = do
src/Dodge/Room/Warning.hs
+4 -1
View File
@@ -11,6 +11,7 @@ import Dodge.Tree
import Dodge.Room.Door
import Dodge.Room.Ngon
import Dodge.Room.Procedural
import Dodge.Room.Tanks
--import Dodge.Room.Corridor
import Dodge.Room.Link
--import Dodge.Room.Procedural
@@ -39,7 +40,9 @@ import qualified Data.Map.Strict as M
warningRooms :: RandomGen g => Int -> State g (MetaTree Room String)
warningRooms n = do
rm <- takeOne [roomNgon 8 200, roomRectAutoLinks 200 200]
rm <- do
tr <- tanksRoom [] []
takeOne [roomNgon 8 200, roomRectAutoLinks 200 200,tr]
cenroom <- shuffleLinks $ addWarningTerminal n rm
rToOnward "warningRooms" $ treePost [ door, cenroom, triggerDoorRoom n, cleatOnward door]
src/Dodge/Tree/Compose.hs
+6 -2
View File
@@ -13,6 +13,7 @@ module Dodge.Tree.Compose
, attachTree
, toOnward
, attachOnward
, attachOnward'
, showIntsString
, module Dodge.Tree.Compose.Data
) where
@@ -90,8 +91,11 @@ attachBranch mb = safeUpdateSingleNode (isJust . upf . snd)
tToBTree :: String -> Tree Room -> MetaTree Room String
tToBTree str t = MTree str (NodeTree t) []
attachOnward :: MetaTree Room b -> MetaTree Room b -> MetaTree Room b
attachOnward t1 t2 = t1 & mtBranches .:~ MBranch toOnward t2
attachOnward :: b -> MetaTree Room b -> MetaTree Room b -> MetaTree Room b
attachOnward s t1 t2 = MTree s (NodeMTree t1) [MBranch toOnward t2]
attachOnward' :: MetaTree Room b -> MetaTree Room b -> MetaTree Room b
attachOnward' t1 t2 = MTree (_mtLabel t1) (NodeMTree t1) [MBranch toOnward t2]
toOnward :: Room -> Maybe Room
toOnward rm
src/Dodge/UseAll.hs
+1 -1
View File
@@ -25,7 +25,7 @@ cleatOnward :: Room -> Room
cleatOnward = rmClusterStatus . csLinks .~ S.singleton OnwardCluster
cleatSide :: Room -> Room
cleatSide = rmClusterStatus . csLinks .~ S.singleton SideCluster
cleatSide = rmClusterStatus . csLinks . at SideCluster ?~ ()
cleatLabel :: Int -> Room -> Room
cleatLabel i = rmClusterStatus . csLinks .~ S.singleton (LabelCluster i)