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

Allow for more complex placement positioning

Browse Source
This commit is contained in:
justin
2021-11-24 20:51:50 +00:00
parent c4614866e6
commit e44c5e7120
16 changed files with 178 additions and 173 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Default/Room.hs
+2
View File
@@ -3,6 +3,7 @@ module Dodge.Default.Room
import Geometry.Data
import Dodge.LevelGen.Data
import qualified Data.IntMap.Strict as IM
import qualified Data.Set as S
defaultRoom :: Room
defaultRoom = Room
@@ -24,4 +25,5 @@ defaultRoom = Room
, _rmTakeFrom = Nothing
, _rmStartWires = IM.empty
, _rmEndWires = IM.empty
, _rmConnectsTo = S.singleton OutLink
}
src/Dodge/LevelGen/Data.hs
+22 -7
View File
@@ -38,11 +38,14 @@ data PSType = PutCrit {_unPutCrit :: Creature}
data PlacementSpot
= PS { _psPos :: Point2 , _psRot :: Float }
| PSPos
{ _psLnkShift :: RoomPos -> Maybe (PlacementSpot, RoomPos)
, _psLnkRoomEff :: RoomPos -> Room -> Room
, _psLnkFallback :: Maybe Placement
{ _psSelect :: RoomPos -> Room -> Maybe (PlacementSpot, RoomPos)
, _psRoomEff :: RoomPos -> Room -> Room
, _psFallback :: Maybe Placement
}
| PSRoomRand
{ _psRoomRandPointNum :: Int
, _psRandShift :: (Point2,Float) -> PlacementSpot
}
| PSRoomRand { _psRoomRandPointNum :: Int }
data Placement = Placement
{ _plSpot :: PlacementSpot
, _plType :: PSType
@@ -82,6 +85,7 @@ data Room = Room
, _rmTakeFrom :: Maybe Int
, _rmStartWires :: IM.IntMap RoomWire
, _rmEndWires :: IM.IntMap RoomWire
, _rmConnectsTo :: S.Set RoomLinkType
}
data RoomLink = RoomLink
{ _rlType :: S.Set RoomLinkType
@@ -92,6 +96,13 @@ data RoomLinkType
= OutLink
| InLink
| LabLink Int
| OnEdge CardinalPoint
deriving (Eq,Ord)
data CardinalPoint
= North
| East
| South
| West
deriving (Eq,Ord)
data RoomWire
= --RoomWire Point2 Float
@@ -112,9 +123,13 @@ data RoomPos
{_rpPos :: Point2
,_rpDir ::Float
}
| PosPl
| UsedSpot
{_rpPos :: Point2
,_rpDir ::Float
,_rpDir :: Float
}
| UnusedSpot
{_rpPos :: Point2
,_rpDir :: Float
}
deriving (Eq,Ord,Show)
@@ -144,7 +159,7 @@ sps :: PlacementSpot -> PSType -> Placement
sps ps pt = Placement ps pt Nothing (const Nothing)
plRRpt :: Int -> PSType -> Placement
plRRpt i pt = Placement (PSRoomRand i) pt Nothing (const Nothing)
plRRpt i pt = Placement (PSRoomRand i (uncurry PS)) pt Nothing (const Nothing)
jsps :: Point2 -> Float -> PSType -> Maybe Placement
jsps p a pst = Just $ Placement (PS p a) pst Nothing $ const Nothing
src/Dodge/LockAndKey.hs
+3 -3
View File
@@ -15,14 +15,14 @@ import Control.Monad.State
lockRoomKeyItems :: RandomGen g => [ (Int -> State g (SubCompTree Room) , State g ItemIdentity ) ]
lockRoomKeyItems =
[ (lasCenSensEdge, takeOne [Launcher] )
-- , (const $ fmap singleUseAll slowDoorRoom, return MiniGun)
[(lasCenSensEdge, takeOne [Launcher] )
,(const slowDoorRoomRunPast, return MiniGun)
]
itemRooms :: RandomGen g => [(ItemIdentity, State g (SubCompTree Room))]
itemRooms =
[ (Launcher , corridorBoss launcherCrit )
-- , (MiniGun , join $ takeOne [roomMiniIntro, minigunFakeout] )
, (MiniGun , join $ takeOne [roomMiniIntro, minigunFakeout] )
]
corridorBoss :: RandomGen g => Creature -> State g (SubCompTree Room)
src/Dodge/Placement/Instance/Button.hs
+2 -2
View File
@@ -58,7 +58,7 @@ putLitButtonID col p a subpl = mntLSOn aShape (Just col) ls p'' (addZ 40 p')
ls = defaultLS { _lsRad = 75 , _lsIntensity = V3 0.5 0 0 }
putLitButOnPos :: Color
-> (RoomPos -> Maybe (PlacementSpot,RoomPos))
-> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos))
-> (Int -> Maybe Placement) -> Placement
putLitButOnPos col f subpl
= plSpot .~ thePS $ mntLSOn aShape (Just col) ls 0 (V3 0 (-40) 40)
@@ -89,7 +89,7 @@ extTrigLitPos ps f = psPtCont ps (PutTrigger (const False))
thels = defaultLS {_lsIntensity = V3 0.5 0 0, _lsPos = V3 0 0 78, _lsRad = 75}
putLitButOnPosExtTrig :: Color
-> (RoomPos -> Maybe (PlacementSpot,RoomPos))
-> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos))
-> Placement
putLitButOnPosExtTrig col f
= psPtCont thePS (PutTrigger (const False))
src/Dodge/Placement/Instance/LightSource.hs
+5 -5
View File
@@ -81,7 +81,7 @@ mntLS :: (Point2 -> Point3 -> Shape) -> Point2 -> Point3 -> Placement
mntLS shp wallp lampp = mntLSOn shp Nothing defaultLS wallp lampp (const Nothing)
mntLSCond :: (Point2 -> Point3 -> Shape)
-> (RoomPos -> Maybe (PlacementSpot,RoomPos))
-> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos))
-> Placement
mntLSCond shp shift = -- updatePSToLevel 1 (const $ PSLnk shift (const id) Nothing) $
mntLS shp 0 (V3 0 (-40) 90)
@@ -93,15 +93,15 @@ mntLight a b = RandomPlacement $ do
shp <- takeOne [vShape,iShape,lShape,jShape,liShape]
return $ mntLS shp a (addZ 90 b)
mntLightLnkCond :: (RoomPos -> Maybe (PlacementSpot,RoomPos))
mntLightLnkCond :: (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos))
-> Placement
mntLightLnkCond f = RandomPlacement $ do
shp <- takeOne [vShape,iShape,lShape,jShape,liShape]
return $ mntLSCond shp f
unusedLnkToPS :: RoomPos -> Maybe (PlacementSpot,RoomPos)
unusedLnkToPS rp = case rp of
UnusedLink p a -> Just (PS p a,PosPl p a)
unusedLnkToPS :: RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)
unusedLnkToPS rp _ = case rp of
UnusedLink p a -> Just (PS p a,UsedSpot p a)
_ -> Nothing
spanLSLightI :: LightSource -> Float -> Point2 -> Point2 -> Placement
src/Dodge/Placement/PlaceSpot.hs
+7 -6
View File
@@ -33,7 +33,7 @@ import Data.Bifunctor
-- to the placement
placeSpot :: (World,Room) -> Placement -> ( (World,Room), [Placement] )
placeSpot (w,rm) plmnt = case plmnt of
Placement{_plSpot = PSRoomRand i} -> placeSpotRoomRand rm i plmnt w
Placement{_plSpot = PSRoomRand i f} -> placeSpotRoomRand rm i f plmnt w
Placement{_plSpot = PSPos extract eff fallback} -> placeSpotUsingLink w rm plmnt extract eff fallback
Placement{} ->
let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w
@@ -52,7 +52,7 @@ placeSpot (w,rm) plmnt = case plmnt of
-- this should be tidied up
placeSpotUsingLink :: World -> Room -> Placement
-> (RoomPos -> Maybe (PlacementSpot,RoomPos))
-> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos))
-> (RoomPos -> Room -> Room)
-> Maybe Placement
-> ((World, Room), [Placement])
@@ -63,14 +63,15 @@ placeSpotUsingLink w rm plmnt extract eff fallback = case searchedPoss (_rmPos r
Just plmnt' -> placeSpot (w,rm) plmnt'
where
searchedPoss [] = Nothing
searchedPoss (pos:poss) = case extract pos of
searchedPoss (pos:poss) = case extract pos rm of
Nothing -> second (pos:) <$> searchedPoss poss
Just (ps,rmpos) -> Just ( ps,rmpos:poss)
placeSpotRoomRand :: Room -> Int -> Placement -> World -> ((World,Room),[Placement])
placeSpotRoomRand rm i plmnt w =
placeSpotRoomRand :: Room -> Int -> ((Point2,Float) -> PlacementSpot)
-> Placement -> World -> ((World,Room),[Placement])
placeSpotRoomRand rm i f plmnt w =
let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w
in placeSpot (w & randGen .~ g,rm) (plmnt & plSpot .~ uncurry PS ps)
in placeSpot (w & randGen .~ g,rm) (plmnt & plSpot .~ f ps)
shiftPlacement :: (Point2,Float) -> Placement -> Placement
shiftPlacement shift plmnt = case plmnt of
src/Dodge/PlacementSpot.hs
+33 -13
View File
@@ -2,29 +2,49 @@ module Dodge.PlacementSpot where
import Dodge.LevelGen.Data
import Geometry
import Data.Bifunctor
import Control.Monad.State
import System.Random
setDirPS :: Float -> PlacementSpot -> PlacementSpot
setDirPS a ps = case ps of
PS p _ -> PS p a
PSPos f re fb -> undefined
_ -> error "TODO write this in"
randDirPS :: RandomGen g => PlacementSpot -> State g PlacementSpot
randDirPS (PSPos f ef fb) = do
a <- state $ randomR (0,pi*2)
return $ PSPos (g a) ef fb
where
g a rp r = fmap (first (setDirPS a)) $ f rp r
--unusedSpotAwayFromInLinkRD :: RandomGen g => Float -> State g PlacementSpot
--unusedSpotAwayFromInLinkRD x = do
-- a <- state $ randomR (0.2*pi)
-- return PSPos (f a) (const id) Nothing
-- where
-- TODO rename to any unused link facing out
anyLnkOutPS :: PlacementSpot
anyLnkOutPS = PSPos f (const id) Nothing
where
f (UnusedLink p a) = Just (PS p a, PosPl p a)
f _ = Nothing
f (UnusedLink p a) _ = Just (PS p a, UsedSpot p a)
f _ _ = Nothing
atFstLnkOut :: PlacementSpot
atFstLnkOut = PSPos f (const id) Nothing
where
f (UsedOutLink 0 i p a) = Just (PS p a, UsedOutLink 0 i p a)
f _ = Nothing
f (UsedOutLink 0 i p a) _ = Just (PS p a, UsedOutLink 0 i p a)
f _ _ = Nothing
atNthLnkOutShiftBy :: Int -> ((Point2,Float) -> (Point2,Float)) -> PlacementSpot
atNthLnkOutShiftBy n theshift = PSPos f (const id) Nothing
where
f (UsedOutLink i rmid p a) | n == i = Just (PS p' a', UsedOutLink n rmid p a)
f (UsedOutLink i rmid p a) _ | n == i = Just (PS p' a', UsedOutLink n rmid p a)
where
(p',a') = theshift (p,a)
f _ = Nothing
f _ _ = Nothing
atFstLnkOutShiftBy :: ((Point2,Float) -> (Point2,Float)) -> PlacementSpot
atFstLnkOutShiftBy = atNthLnkOutShiftBy 0
@@ -40,22 +60,22 @@ atNthLnkOutShiftInward n x = atNthLnkOutShiftBy n f
overFstLnkOut :: PlacementSpot
overFstLnkOut = PSPos f (const id) Nothing
where
f (UsedOutLink 0 _ p a) = Just (PS p a, PosPl p a)
f _ = Nothing
f (UsedOutLink 0 _ p a) _ = Just (PS p a, UsedSpot p a)
f _ _ = Nothing
anyLnkInPS :: Float -- ^ amount to shift inward
-> PlacementSpot
anyLnkInPS x = PSPos f (const id) Nothing
where
f (UnusedLink v a) = Just (PS v' a' ,PosPl v' a')
f (UnusedLink v a) _ = Just (PS v' a' ,UsedSpot v' a')
where
v' = v -.- x *.* unitVectorAtAngle (a + 0.5 * pi)
a' = a + pi
f _ = Nothing
f _ _ = Nothing
useLnkRoomPos :: RoomPos -> Maybe (PlacementSpot,RoomPos)
useLnkRoomPos rp = case rp of
(UnusedLink (V2 x y) a) -> Just (PS (V2 x y) a , PosPl (V2 x y) a)
useLnkRoomPos :: RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)
useLnkRoomPos rp _ = case rp of
(UnusedLink (V2 x y) a) -> Just (PS (V2 x y) a , UsedSpot (V2 x y) a)
_ -> Nothing
psRandRanges :: (Float,Float) -> (Float,Float) -> (Float,Float) -> State StdGen (Point2,Float)
src/Dodge/Room/Link.hs
+12
View File
@@ -16,6 +16,7 @@ module Dodge.Room.Link
, changeLinkTo
, changeLinkFrom
, randomiseOutLinks
, chooseOneInLink
) where
import Dodge.Placement.PlaceSpot
import Dodge.LevelGen.Data
@@ -29,6 +30,17 @@ import Control.Monad.State
import Control.Lens
import Data.List
import qualified Data.Set as S
--import System.Random
chooseOneInLink :: RandomGen g => Room -> State g Room
chooseOneInLink r = restrictToFstInLink <$> shuffleLinks r
restrictToFstInLink :: Room -> Room
restrictToFstInLink = rmLinks %~ f
where
f (rl:xs) | S.member InLink (_rlType rl) = rl : restrictLinkType InLink (const False) xs
| otherwise = rl : f xs
f [] = []
{- Shuffle the initial links of a room randomly. -}
randomiseOutLinks :: RandomGen g => Room -> State g Room
src/Dodge/Room/LongDoor.hs
+17 -4
View File
@@ -5,10 +5,12 @@ module Dodge.Room.LongDoor where
import Dodge.Data
import Dodge.RoomLink
import Dodge.Base
import Dodge.Tree
import Dodge.Default.Room
import Dodge.LevelGen.Data
import Dodge.Placement.Instance
import Dodge.Room.Link
import Dodge.Room.Door
import Dodge.Room.Procedural
--import Dodge.Layout.Tree.Either
--import Dodge.LevelGen.Data
@@ -20,6 +22,8 @@ import Dodge.LightSource
import Picture
import Geometry
import qualified Data.Set as S
import Data.Tree
import System.Random
import Control.Lens
import Control.Monad.State
@@ -106,7 +110,7 @@ addButtonSlowDoor x h rm = do
,( V2 (x/2+50) 5,0::Float)
]
thePlacement <- takeOne [butDoor butPos butRot ]
shuffleLinks $ setOutLinks aboveH $ setInLinks belowH (rm
shuffleLinks $ setOutLinksPD aboveH $ setInLinksPD belowH (rm
& rmPmnts %~ (thePlacement :)
& rmBound %~ (openDoorBound :)
)
@@ -116,9 +120,9 @@ addButtonSlowDoor x h rm = do
aboveH y = (sndV2 . fst) y > h + 40
butDoor _ _ = putLitButOnPos col butPosCond
$ \btid -> Just $ putDoubleDoor False col (cond' btid) (V2 0 h) (V2 x h) 2
butPosCond (UnusedLink (V2 x' y') a') | y' < 0.5 * h
= Just (PS (V2 x' y') a' , PosPl (V2 x' y') a')
butPosCond _ = Nothing
butPosCond (UnusedLink (V2 x' y') a') _ | y' < 0.5 * h
= Just (PS (V2 x' y') a' , UsedSpot (V2 x' y') a')
butPosCond _ _ = Nothing
--butPosCond _ = True -- y < h
col = dim $ light red
cond' btid w = w ^? buttons . ix btid . btState /= Just BtOff
@@ -141,3 +145,12 @@ slowDoorRoom = do
proom <- southPillarsRoom x y h
addButtonSlowDoor x h (proom & rmPmnts %~ (++ (crits ++ barrels ++ lsources)))
slowDoorRoomRunPast :: RandomGen g => State g (SubCompTree Room)
slowDoorRoomRunPast = do
r <- slowDoorRoom
return $ treeFromTrunk [PassDown door]
(Node (PassDown r)
[ singleUseAll door
, return (UseLabel 0 $ door & rmConnectsTo .~ S.singleton InLink)
]
)
src/Dodge/Room/Procedural.hs
+5 -2
View File
@@ -47,8 +47,9 @@ roomRect
-> Room
roomRect x y xn yn = defaultRoom
{ _rmPolys = [rectNSWE y 0 0 x ]
, _rmLinks = init lnks ++ [last lnks]
, _rmLinks = lnks
, _rmPath = concatMap doublePair pth
, _rmPos = map (\p -> UnusedSpot p 0) posps
, _rmPmnts = []
, _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)]
, _rmFloor = [Tile
@@ -66,8 +67,10 @@ roomRect x y xn yn = defaultRoom
wlnks = zip (map (+.+ V2 x 20) $ gridPoints 0 1 yd (yn+1)) (repeat (-pi/2))
nlnks = zip (map (+.+ V2 20 y) $ gridPoints xd (xn+1) 0 1 ) (repeat 0 )
slnks = zip (map (+.+ V2 20 0) $ gridPoints xd (xn+1) 0 1 ) (repeat pi )
lnks = map toBothLnk $ nlnks ++ elnks ++ wlnks ++ slnks
lnks = m North nlnks ++ m East elnks ++ m West wlnks ++ m South slnks
m edge = map (lnkBothAnd (OnEdge edge))
pth = linksAndPath' lnks $ map (bimap (+.+ V2 20 20) (+.+ V2 20 20)) (makeGrid xd xn yd yn)
posps = map (+.+ V2 20 20) $ gridPoints xd xn yd yn
{- Creates a rectangular room, automatically creates links and pathfinding graph at a sensible size. -}
-- it is not clear to me that this works for very small rooms (but it does seem
-- to do so)
src/Dodge/Room/RoadBlock.hs
+6 -4
View File
@@ -77,8 +77,8 @@ dirtPoly :: [Point2] -> PSType
dirtPoly = PutBlock DirtBlock [1] dirtWall . reverse
-- | A single corridor with a destructible block blocking it.
blockedCorridor' :: RandomGen g => State g Room
blockedCorridor' = do
blockedCorridorCloseBlocks :: RandomGen g => State g Room
blockedCorridorCloseBlocks = do
r <- state $ randomR (0,pi)
theblocks <- takeOne
[ -- [sPS (V2 20 40) r $ dirtPoly $ square 10]
@@ -86,8 +86,10 @@ blockedCorridor' = do
-- , 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 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
]
]
return $ corridor & rmPmnts .~ theblocks
src/Dodge/Room/Room.hs
+20 -20
View File
@@ -53,8 +53,8 @@ roomPadCut ps p = defaultRoom
, _rmPath = [(V2 0 0,p)]
}
roomPillars :: Room
roomPillars = --over rmLinks init $ -- it is unclear to me the purpose of this: perhaps to get the in link in the center?
set rmPmnts plmnts $ roomRect 240 240 2 2
roomPillars = roomRect 240 240 2 2
& rmPmnts .~ plmnts
where
plmnts = spanLightI (V2 120 24) (V2 120 216)
: mntLS vShape (V2 12 12) (V3 25 25 70)
@@ -106,8 +106,8 @@ glassSwitchBack = do
hgt <- state $ randomR (400,600)
wllen <- state $ randomR (60,wth/2-40)
let hf = hgt/5
con1 cond (UnusedLink (V2 x y) a) | cond y = Just (PS (V2 x y) a , PosPl (V2 x y) a)
con1 _ _ = Nothing
con1 cond (UnusedLink (V2 x y) a) _ | cond y = Just (PS (V2 x y) a , UsedSpot (V2 x y) a)
con1 _ _ _ = Nothing
plmnts =
[ mntLightLnkCond $ con1 (< 0.5 * hgt)
, mntLightLnkCond $ con1 (> 0.5 * hgt)
@@ -134,8 +134,8 @@ glassSwitchBack = do
glassSwitchBackCrits :: RandomGen g => State g Room
glassSwitchBackCrits = glassSwitchBack
<&> rmPmnts %~ ([spNoID (PSRoomRand 0) (PutCrit miniGunCrit)
, spNoID (PSRoomRand 1) randC1
<&> rmPmnts %~ ([spNoID (PSRoomRand 0 (uncurry PS)) (PutCrit miniGunCrit)
, spNoID (PSRoomRand 1 (uncurry PS)) randC1
] ++)
miniTree2 :: RandomGen g => State g (SubCompTree Room)
@@ -182,7 +182,7 @@ rot90Around cen p = cen +.+ vNormal (p -.- cen)
-- inside an inner tree
roomMiniIntro :: RandomGen g => State g (SubCompTree Room)
roomMiniIntro = do
midroom <- join $ takeOne [miniTree2,glassLesson]
midroom <- join $ takeOne [miniTree2] --,glassLesson]
return $ chainUses [return $ UseAll door, midroom,return $ UseAll corridor]
roomCenterPillar :: RandomGen g => State g Room
@@ -328,7 +328,7 @@ weaponLongCorridor :: RandomGen g => State g (SubCompTree Room)
weaponLongCorridor = do
root <- takeOne [tEast, tWest]
connectingRoom <- takeOne
[tEast & rmPmnts .~ [spanLightI (V2 (-40) 40) (V2 (-40) 80)]
[tEast & rmPmnts .~ [spanLightI (V2 (-30) 40) (V2 (-30) 80)]
]
i1 <- state $ randomR (2,5)
i2 <- state $ randomR (2,5)
@@ -356,16 +356,16 @@ deadEndRoom = defaultRoom
{- A random Either tree with a weapon and melee monster challenge. -}
weaponRoom :: RandomGen g => State g (SubCompTree Room)
weaponRoom = join $ takeOne
[ weaponEmptyRoom
, weaponUnderCrits
, weaponBehindPillar
, weaponBetweenPillars
, weaponLongCorridor
[-- weaponEmptyRoom
--, weaponUnderCrits
--, weaponBehindPillar
weaponBetweenPillars
--, weaponLongCorridor
]
roomCCrits :: RandomGen g => State g Room
roomCCrits = roomC 200 200
<&> rmPmnts %~ (replicate 20 (spNoID (PSRoomRand 0) randC1) ++ )
<&> rmPmnts %~ (replicate 20 (spNoID (PSRoomRand 0 (uncurry PS)) randC1) ++ )
longRoom :: RandomGen g => State g Room
longRoom = do
@@ -432,13 +432,13 @@ shootersRoom' = do
shootersRoom1 :: RandomGen g => State g Room
shootersRoom1 = shootersRoom' <&> rmPmnts %~
( (
RandomPlacement $ takeOne $ map (\i -> spNoID (PSRoomRand i) (PutCrit autoCrit))
RandomPlacement $ takeOne $ map (\i -> spNoID (PSRoomRand i (uncurry PS)) (PutCrit autoCrit))
[0,1,2]
) :)
shootersRoom :: RandomGen g => State g Room
shootersRoom = shootersRoom' <&> rmPmnts %~
( map (\i -> spNoID (PSRoomRand i) (PutCrit autoCrit))
( map (\i -> spNoID (PSRoomRand i (uncurry PS)) (PutCrit autoCrit))
[0,1,2]
++ )
@@ -477,9 +477,9 @@ pillarGrid = do
pistolerRoom :: RandomGen g => State g Room
pistolerRoom = pillarGrid
<&> rmPmnts %~ (
[spNoID (PSRoomRand 0) (PutCrit pistolCrit)
,spNoID (PSRoomRand 0) (PutCrit pistolCrit)
,spNoID (PSRoomRand 0) (PutCrit pistolCrit)
[spNoID (PSRoomRand 0 (uncurry PS)) (PutCrit pistolCrit)
,spNoID (PSRoomRand 0 (uncurry PS)) (PutCrit pistolCrit)
,spNoID (PSRoomRand 0 (uncurry PS)) (PutCrit pistolCrit)
]
++)
@@ -506,6 +506,6 @@ spawnerRoom = do
x <- state $ randomR (250,300)
y <- state $ randomR (300,400)
roomWithSpawner <- roomC x y <&>
rmPmnts %~ (spNoID (PSRoomRand 0) (PutCrit spawnerCrit) :)
rmPmnts %~ (spNoID (PSRoomRand 0 (uncurry PS)) (PutCrit spawnerCrit) :)
aRoom <- airlock
return $ treeFromTrunk [PassDown aRoom,PassDown corridor] $ singleUseAll roomWithSpawner
src/Dodge/Room/Start.hs
+6 -97
View File
@@ -10,6 +10,7 @@ import Dodge.Default
import Dodge.Tree
import Dodge.RandomHelp
import Dodge.Room.Door
import Dodge.Room.RezBox
import Dodge.Room.Corridor
import Dodge.Room.Room
import Dodge.Room.Link
@@ -67,11 +68,11 @@ startRoom :: RandomGen g => Int -> State g (SubCompTree Room)
startRoom i = join $ takeOne
[-- roomMiniIntro
--minigunfakeout
rezBoxesWp
, rezBoxesThenWeaponRoom
, rezBoxThenWeaponRoom
, rezBoxesWpCrit
, runPastStart i
-- rezBoxesWp
rezBoxesThenWeaponRoom
-- , rezBoxThenWeaponRoom
-- rezBoxesWpCrit
-- , runPastStart i
]
runPastStart :: RandomGen g => Int -> State g (SubCompTree Room)
@@ -85,33 +86,6 @@ rezBoxStart = do
ls <- rezColor
return $ treeFromPost [PassDown $ rezBox ls] (UseAll door)
rezBox :: LightSource -> Room
rezBox ls = roomRect 40 60 1 1
& rmPmnts .~ [ sPS (V2 20 1) 0 $ PutLS ls]
rezColor :: RandomGen g => State g LightSource
rezColor = do
col <- takeOne [V3 0.0 0.1 0.5, V3 0.0 0.5 0.1]
h <- takeOne [30,50,80,90,90,90,90]
rad <- takeOne [150,200,200,250,250,300,300,300]
return defaultLS
{ _lsPos = V3 0 0 h
, _lsIntensity = col
, _lsRad = rad
}
rezInvBox :: LightSource -> Room
rezInvBox = swapInOutLinks . rezBox
crAdd :: Room -> Room
crAdd = rmPmnts %~ (sPS (V2 20 10) (0.5*pi) randC1 :)
wpAdd :: Item -> Room -> Room
wpAdd wp = rmPmnts %~ f
where
f (x:xs) = sPS (V2 15 30) 1 (PutFlIt wp) : g x : xs
f _ = [sPS (V2 15 30) 1 (PutFlIt wp)]
g x = x & plIDCont .~ flickerMod
rezBoxesThenWeaponRoom :: RandomGen g => State g (SubCompTree Room)
rezBoxesThenWeaponRoom = do
@@ -124,72 +98,7 @@ rezBoxThenWeaponRoom = do
rcol <- rezColor
treeFromTrunk [PassDown $ rezBox rcol,PassDown door] <$> weaponRoom
rezBoxesWpCrit :: RandomGen g => State g (SubCompTree Room)
rezBoxesWpCrit = do
w <- state $ randomR (200,400)
h <- state $ randomR (40,40)
thecol <- rezColor
theweapon <- randBlockBreakWeapon
let bottomEdgeTest (V2 _ y,_) = y < 1
bottomPassDownTest (V2 x y,_) = y < 1 && x < 21
aroom = rezInvBox thecol
centralRoom <- filterSortOutLinksOn bottomEdgeTest ((\(V2 a b) -> (b,a)) . fst) <$>
(randomiseOutLinks =<< changeLinkTo bottomPassDownTest
((roomRectAutoLinks w h) {_rmPmnts = []}))
let n = length $ filter bottomEdgeTest $ map lnkPosDir $ _rmLinks centralRoom
i <- state $ randomR (0,n-3)
j <- state $ randomR (i,n-2)
blcor <- blockedCorridor'
let rezrooms = map adddoor
$ insertAt i (wpAdd theweapon aroom)
$ insertAt j (crAdd aroom)
$ replicate (n-3) aroom
return $ treeFromTrunk [PassDown $ rezBox thecol
, PassDown door
]
(Node (PassDown centralRoom) (rezrooms ++ [onwardtree blcor]))
where
adddoor rm = treeFromPost [PassDown door] (PassDown rm)
onwardtree blcor = treeFromPost [PassDown door] (UseAll blcor)
rezBoxesWp :: RandomGen g => State g (SubCompTree Room)
rezBoxesWp = do
w <- state $ randomR (100,400)
h <- state $ randomR (40,40)
theweapon <- randBlockBreakWeapon
thecol <- rezColor
let bottomEdgeTest (V2 _ y,_) = y < 1
aroom = rezInvBox thecol
centralRoom <- randomiseOutLinks =<< changeLinkTo bottomEdgeTest
((roomRectAutoLinks w h) {_rmPmnts = []})
blcor <- blockedCorridor'
let n = length $ filter bottomEdgeTest $ map lnkPosDir $_rmLinks centralRoom
let rezrooms = map adddoor
$ wpAdd theweapon aroom : replicate (n-2) aroom
centralRoom' <- changeLinkFrom bottomEdgeTest centralRoom
return $ treeFromTrunk [PassDown $ rezBox thecol
, PassDown door
]
(Node (PassDown centralRoom') (rezrooms ++ [onwardtree blcor]))
where
adddoor rm = treeFromPost [PassDown door] (PassDown rm)
onwardtree blcor = treeFromPost [PassDown door] (UseAll blcor)
rezBoxes :: RandomGen g => State g (SubCompTree Room)
rezBoxes = do
w <- state $ randomR (100,400)
h <- state $ randomR (40,40)
thecol <- rezColor
let bottomEdgeTest (V2 _ y,_) = y < 1
dbox = treeFromPost [PassDown door] (PassDown $ rezInvBox thecol)
centralRoom <- randomiseOutLinks =<< changeLinkTo bottomEdgeTest
((roomRectAutoLinks w h) {_rmPmnts = []})
let n = length $ filter bottomEdgeTest $ map lnkPosDir $_rmLinks centralRoom
centralRoom' <- changeLinkFrom bottomEdgeTest centralRoom
return $ treeFromTrunk [PassDown $ rezBox thecol
, PassDown door
]
(Node (PassDown centralRoom') (replicate (n-1) dbox ++ [Node (UseAll door) []]))
startRoom' :: RandomGen g => State g (SubCompTree Room)
startRoom' = do
src/Dodge/RoomLink.hs
+27 -9
View File
@@ -9,8 +9,11 @@ import Control.Lens
restrictLinkType :: RoomLinkType -> ((Point2,Float) -> Bool) -> [RoomLink] -> [RoomLink]
restrictLinkType rlt f = map g
where
g rl | f $ rlPosDir rl = rl & rlType %~ S.delete rlt
| otherwise = rl
g rl | f $ rlPosDir rl = rl
| otherwise = rl & rlType %~ S.delete rlt
getLinksOfType :: RoomLinkType -> [RoomLink] -> [RoomLink]
getLinksOfType lt = filter (S.member lt . _rlType)
restrictInLinks :: ((Point2,Float) -> Bool) -> Room -> Room
restrictInLinks f = rmLinks %~ restrictLinkType InLink f
@@ -18,17 +21,26 @@ restrictInLinks f = rmLinks %~ restrictLinkType InLink f
restrictOutLinks :: ((Point2,Float) -> Bool) -> Room -> Room
restrictOutLinks f = rmLinks %~ restrictLinkType OutLink f
setLinkType :: RoomLinkType -> ((Point2,Float) -> Bool) -> [RoomLink] -> [RoomLink]
setInLinks :: (RoomLink -> Bool) -> [RoomLink] -> [RoomLink]
setInLinks = setLinkType InLink
setLinkType :: RoomLinkType -> (RoomLink -> Bool) -> [RoomLink] -> [RoomLink]
setLinkType rlt f = map g
where
g rl | f $ rlPosDir rl = rl & rlType %~ S.delete rlt
| otherwise = rl & rlType %~ S.insert rlt
setInLinks :: ((Point2,Float) -> Bool) -> Room -> Room
setInLinks f = rmLinks %~ setLinkType InLink f
g rl | f rl = rl & rlType %~ S.insert rlt
| otherwise = rl & rlType %~ S.delete rlt
setOutLinks :: ((Point2,Float) -> Bool) -> Room -> Room
setOutLinks f = rmLinks %~ setLinkType OutLink f
setLinkTypePD :: RoomLinkType -> ((Point2,Float) -> Bool) -> [RoomLink] -> [RoomLink]
setLinkTypePD rlt f = map g
where
g rl | f $ rlPosDir rl = rl & rlType %~ S.insert rlt
| otherwise = rl & rlType %~ S.delete rlt
setInLinksPD :: ((Point2,Float) -> Bool) -> Room -> Room
setInLinksPD f = rmLinks %~ setLinkTypePD InLink f
setOutLinksPD :: ((Point2,Float) -> Bool) -> Room -> Room
setOutLinksPD f = rmLinks %~ setLinkTypePD OutLink f
swapInOutLinks :: Room -> Room
swapInOutLinks = rmLinks %~ map (rlType %~ S.map f)
@@ -66,6 +78,12 @@ inLink p a = RoomLink
,_rlPos = p
, _rlDir = a
}
lnkBothAnd :: RoomLinkType -> (Point2,Float) -> RoomLink
lnkBothAnd rlt (p,a) = RoomLink
{_rlType = S.fromList [OutLink,InLink,rlt]
,_rlPos = p
, _rlDir = a
}
toBothLnk :: (Point2,Float) -> RoomLink
toBothLnk (p,a) = RoomLink
src/Dodge/Tree/Compose.hs
+5
View File
@@ -8,11 +8,13 @@ module Dodge.Tree.Compose
, useAllAtEnd
, changeToPassDown
, overwriteLabel
, applyToCompRoot
) where
import Dodge.Tree.Compose.Data
import Dodge.Tree.Polymorphic
import Dodge.Base
import Data.Tree
import Control.Lens
expandTree :: CompTree a -> Tree a
expandTree (Node root extChildren) = case root of
@@ -24,6 +26,9 @@ expandTree (Node root extChildren) = case root of
Node (SplitDown x) xs -> Node x $ map expandTree $ zipWith Node xs
$ map (:[]) extChildren ++ repeat []
applyToCompRoot :: (a -> a) -> SubCompTree a -> SubCompTree a
applyToCompRoot f = applyToRoot (unCompose %~ f)
overwriteLabel :: Int -> (a -> ComposingNode a) -> SubCompTree a -> [SubCompTree a] -> SubCompTree a
overwriteLabel i f t ts = errorHead ("tried to overwriteLabel " ++ show i)
$ updateSingleNode islabel update t
src/Dodge/Tree/Shift.hs
+6 -1
View File
@@ -12,6 +12,7 @@ import Geometry.ConvexPoly
import Geometry.Data
import Padding
import qualified Data.Set as S
import Data.Tree
import Data.Sequence hiding (zipWith)
import Data.List (delete)
@@ -34,8 +35,12 @@ posRms bounds (parent,_) [] st = case st of
Node childi ts :<| tseq -> fmap (parent:) <$> posRms bounds childi (zipCount ts) tseq
posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
printInfoCheckNum parenti numChild childi
tryParentLinks $ zipCount $ rmOutLinks parent
tryParentLinks outlinks
where
child = fst childi
outlinks = zipCount
. Prelude.filter (not . S.null . S.intersection (_rmConnectsTo child) . _rlType)
$ _rmLinks parent
tryParentLinks [] = putStrLn "no viable link pairs, backtrack" >> return Nothing
tryParentLinks ((j,outlnk):ls) = tryChildLinks $ zipCount (rmInLinks $ fst childi)
where