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

Add laser tunnel lock-key combination

Browse Source
This commit is contained in:
justin
2022-03-09 15:27:35 +00:00
parent a4ec4e4889
commit 3bfebc266b
11 changed files with 104 additions and 75 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Room/Procedural.hs
+31 -43
View File
@@ -32,10 +32,11 @@ import Dodge.Creature
import Geometry
import Picture
import Data.Tile
import LensHelp
import qualified Data.Set as S
import qualified Data.IntMap.Strict as IM
import Control.Lens
--import Control.Lens
import Control.Monad
import Control.Monad.State
import System.Random
@@ -104,6 +105,7 @@ combineRooms r r' = defaultRoom
--, _rmPmnts = map (shiftPlacement $ _rmShift r) (_rmPmnts r)
-- ++ map (shiftPlacement $ _rmShift r') (_rmPmnts r')
, _rmBound = _rmBound r ++ _rmBound r'
, _rmPos = _rmPos r ++ _rmPos r'
, _rmFloor = combineFloors (_rmFloor r) (_rmFloor r')
, _rmShift = (V2 0 0 , 0)
}
@@ -120,20 +122,14 @@ combineFloors f _ = f
Add a light and a 'PutNothing' placement. -}
quarterRoomTri :: RandomGen g => Float -> State g Room
quarterRoomTri w = do
let commonPlacements =
[ mntLS iShape (V2 (w-20) w) (V3 (w-20) (w-20) 70)
, sPS (V2 (w-20) (w-20)) pi PutNothing
, sPS (V2 (w-15) (w-25)) pi PutNothing
]
b <- takeOne
[ [ mntLS vShape (V2 0 w) (V3 0 (w-20) 70)
, blockLine (V2 (w/2) (w/2)) (V2 (w/2) w)
] ++ commonPlacements
, blockLine (V2 (w/2) (w/2)) (V2 (negate $ w/2) (w/2))
: commonPlacements
]
, [blockLine (V2 (w/2) (w/2)) (V2 (negate $ w/2) (w/2))]
, [ blockLine (V2 (w/2) (w/2)) (V2 0 (w/2))
, blockLine (V2 (-29) w) (V2 0 (w/2))
] ++ commonPlacements
]
]
pure $ defaultRoom
{ _rmPolys = [ [V2 0 0,V2 w w,V2 (-w) w] ]
@@ -146,26 +142,28 @@ quarterRoomTri w = do
,(V2 0 (w-20),V2 0 0)
,(V2 (55-w) (w-20),V2 0 0)
]
, _rmPmnts = b
, _rmPmnts = b ++ [ mntLS iShape (V2 (w-20) w) (V3 (w-20) (w-20) 70)
, sPS (V2 (w-20) (w-20)) pi PutNothing
, sPS (V2 (w-15) (w-25)) pi PutNothing
]
, _rmPos =
[ UnusedSpot (V2 (w-20) (w-20)) pi S.empty
, UnusedSpot (V2 (w-15) (w-25)) pi S.empty
]
, _rmBound = [[V2 0 0,V2 w w,V2 (-w) w]]
}
quarterRoomSquare :: RandomGen g => Float -> State g Room
quarterRoomSquare w = do
let commonPlacements =
[ blockLine (V2 (w/2) (w/2)) (V2 0 w)
, sPS (V2 20 (2*w-40)) pi PutNothing
, sPS (V2 25 (2*w-45)) pi PutNothing
]
b <- takeOne
[ [ mntLS vShape (V2 0 (2*w-20)) (V3 0 (2*w-40) 70)
, blockLine (V2 (negate $ w/2) (w/2)) (V2 0 w)
] ++ commonPlacements
]
, [ mntLS vShape (V2 0 (2*w-20)) (V3 0 (2*w-40) 70)
, blockLine (V2 (negate w) w ) (V2 0 w)
] ++ commonPlacements
]
, [ mntLS iShape (V2 (0.7*w) (1.3*w)) (V3 (0.7*w-20) (1.3*w-20) 70)
, blockLine (V2 0 w) (V2 0 (w*2))
] ++ commonPlacements
]
]
pure $ defaultRoom
{ _rmPolys = [ map toV2 [(0,0),(w,w),(0,2*w),(-w,w)] ]
@@ -185,21 +183,16 @@ quarterRoomSquare w = do
,(V2 0 0,V2 0 (w-40))
-- ,(V2 (20-w) (w-20),V2 (40-w) (w))
]
, _rmPmnts = b
, _rmBound = [map toV2 [(w,w),(0,2*w),(-w,w)]]
, _rmPmnts = b ++
[ blockLine (V2 (w/2) (w/2)) (V2 0 w)
, sPS (V2 20 (2*w-40)) pi PutNothing
, sPS (V2 25 (2*w-45)) pi PutNothing
]
, _rmPos = [UnusedSpot (V2 20 (2*w-40)) pi S.empty
, UnusedSpot (V2 25 (2*w-45)) pi S.empty
]
, _rmBound = [map toV2 [(w,w),(0,2*w),(-w,w)]]
}
{- | Replace the first 'PutNothing' with a given 'PSType'. -}
fillNothingPlacement :: PSType -> Room -> Room
fillNothingPlacement pst r =
r & rmPmnts %~ replaceNothingWith pst
where
replaceNothingWith x (Placement (PS p rot) PutNothing _ _: pss) = sPS p rot x : pss
replaceNothingWith x (ps:pss) = ps : replaceNothingWith x pss
replaceNothingWith _ [] = []
{- | Successively fill 'PutNothing' placements with a list of given 'PSType's.
-}
fillNothingPlacements :: [PSType] -> Room -> Room
fillNothingPlacements pst r = foldr fillNothingPlacement r pst
{- | Randomise the ordering of placements in a room.
Useful for randomising the position of generic placements such as 'PutNothing'. -}
shufflePlacements :: RandomGen g => Room -> State g Room
@@ -211,24 +204,19 @@ shufflePlacements = rmPmnts shuffle
Tight corridors, random placements. -}
randomFourCornerRoom :: RandomGen g => [Item] -> State g Room
randomFourCornerRoom its = do
corners <- replicateM 4 . join $ takeOne [quarterRoomTri 100, quarterRoomSquare 100]
itms <- shuffle its
nCrits <- state $ randomR (1,3)
crits <- takeN nCrits <=< shuffle $ fmap PutCrit $ [spreadGunCrit,pistolCrit,autoCrit,armourChaseCrit]
crits <- takeN nCrits <=< shuffle $ [spreadGunCrit,pistolCrit,autoCrit,armourChaseCrit]
++ replicate 20 chaseCrit
randomiseAllLinks . fillNothingPlacements (crits ++ map PutFlIt itms) =<<
( shufflePlacements
. over rmPmnts ( sps0 putLamp :)
. foldr1 combineRooms
$ zipWith (\r a -> moveRoomBy (V2 0 0,a) r) corners [0,pi/2,pi,3*pi/2]
)
randomFourCornerRoomCrsIts crits its
{- | A randomly generate room based on four randomly generated corners.
Tight corridors. -}
randomFourCornerRoomCrsIts :: RandomGen g => [Creature] -> [Item] -> State g Room
randomFourCornerRoomCrsIts crits its = do
corners <- replicateM 4 . join $ takeOne [quarterRoomTri 100, quarterRoomSquare 100]
itms <- shuffle its
randomiseAllLinks . fillNothingPlacements (map PutCrit crits ++ map PutFlIt itms) =<<
let putitms = map (\it -> sps0 (PutFlIt it) & plSpot .~ anyUnusedSpot) itms
putcrits = map (\cr -> sps0 (PutCrit cr) & plSpot .~ unusedSpotAwayFromLink 50) crits
randomiseAllLinks . (rmPmnts .++~ (putitms ++ putcrits)) =<<
( shufflePlacements
. over rmPmnts ( sps0 putLamp :)
. foldr1 combineRooms