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

Continue to refactor zoning to be more stream-based

Browse Source
This commit is contained in:
justin
2022-06-28 03:21:55 +01:00
parent f6d96ec92c
commit e06527091e
34 changed files with 214 additions and 252 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Room/Airlock.hs
+5 -8
View File
@@ -24,7 +24,7 @@ airlock0 :: Room
airlock0 = defaultRoom
{ _rmPolys = [ rectNSWE 100 0 0 40 , switchcut]
, _rmLinks = muout lnks ++ muin [last lnks]
, _rmPath = [(V2 20 95,V2 20 45) ,(V2 20 45,V2 20 5) ]
, _rmPath = foldMap doublePairSet [(V2 20 95,V2 20 45) ,(V2 20 45,V2 20 5) ]
, _rmPmnts =
[pContID (PS (V2 (-35) 50) (negate $ pi/2)) (PutButton $ makeSwitch col red id id)
$ \btid -> Just $ putDoubleDoorThen thewall (not . cond' btid) 1 (V2 0 20) (V2 40 20) 2
@@ -49,7 +49,7 @@ airlockSimple = defaultRoom
{ _rmPolys =
[ rectNSWE 120 0 0 180 ]
, _rmLinks = map (uncurry outLink) (init lnks) ++ [uncurry inLink $ last lnks]
, _rmPath = concatMap (doublePair. (V2 90 30,) . fst) lnks
, _rmPath = foldMap (doublePairSet . (V2 90 30,) . fst) lnks
, _rmPmnts =
[pContID (PS (V2 90 115) pi) (PutButton $ makeSwitch col red id id)
$ \btid -> jspsJ (V2 0 0) 0 (PutDoor col (cond btid) outDoorps)
@@ -72,7 +72,7 @@ airlockZ = defaultRoom
{ _rmPolys =
[ rectNSWE 120 0 0 180 ]
, _rmLinks = muout[(V2 0 30,pi/2)] ++ muin[(V2 180 30,1.5*pi) ]
, _rmPath = []
, _rmPath = mempty
-- [(V2 0 40,V2 40 0)
-- ,(V2 40 0,V2 0 40)
-- ]
@@ -109,10 +109,7 @@ airlock90 = defaultRoom
]
]
, _rmLinks = muout[(V2 0 40,pi/2)] ++ muin[(V2 40 0,pi) ]
, _rmPath =
[(V2 0 40,V2 40 0)
,(V2 40 0,V2 0 40)
]
, _rmPath = doublePairSet (V2 0 40,V2 40 0)
, _rmPmnts =
[ pContID (PS (V2 120 120) (3 * pi/4)) (PutButton $ makeSwitch col red id id)
$ \btid -> jsps (V2 5 5) 0 $ PutDoor col (cond btid) pss
@@ -137,7 +134,7 @@ airlockCrystal :: Room
airlockCrystal = defaultRoom
{ _rmPolys = [ rectNSWE 140 0 0 40 , switchcutout ]
, _rmLinks = muout[(V2 20 130,0) ] ++ muin[(V2 20 0 ,pi) ]
, _rmPath = [ ]
, _rmPath = mempty
, _rmPmnts =
[pContID (PS (V2 145 70) (pi/2)) ( PutButton $ makeSwitch col red id id)
$ \btid -> jsps0 $ PutDoor col (cond btid) pss
src/Dodge/Room/BlinkAcross.hs
+1 -1
View File
@@ -44,7 +44,7 @@ blinkAcrossChallenge = do
emptyCorridor :: Room
emptyCorridor = corridor & rmPolys .~ []
& rmPath .~ []
& rmPath .~ mempty
& rmPmnts .~ []
& rmRandPSs .~ [psRandRanges (10,30) (30,60) (0,2*pi)]
& rmName .~ "WalledCorridor"
src/Dodge/Room/Boss.hs
+3 -3
View File
@@ -92,7 +92,7 @@ roomCross x y = defaultRoom
] ++
[uncurry inLink (V2 (y-20) (-x),pi)
]
, _rmPath = []
, _rmPath = mempty
, _rmPmnts =
[ spanLightI (V2 (x+5) x) (V2 (x+5) (-x))
, spanLightI (V2 (-x-5) x) (V2 (-x-5) (-x))
@@ -118,7 +118,7 @@ roomShuriken x y =
corner = defaultRoom
{ _rmPolys = ps
, _rmLinks = [toBothLnk (V2 (x-1) (y-20),negate $ pi/2)]
, _rmPath = []
, _rmPath = mempty
, _rmPmnts = [mntLS iShape (V2 x x) (V3 (x-20) x 70)]
, _rmBound = ps
}
@@ -143,7 +143,7 @@ roomTwistCross x y z =
corner = defaultRoom
{ _rmPolys = ps
, _rmLinks = [toBothLnk (V2 z (y-20), pi/2)]
, _rmPath = []
, _rmPath = mempty
, _rmPmnts = [mntLS iShape (V2 x x) (V3 (x-20) (x-20) 70)]
, _rmBound = map (expandPolyCorners 10) ps
}
src/Dodge/Room/Corridor.hs
+7 -6
View File
@@ -20,7 +20,7 @@ corridor :: Room
corridor = defaultRoom
{ _rmPolys = [poly]
, _rmLinks = lnks'
, _rmPath = concatMap (doublePair . (,) (V2 20 60) . fst) lnks
, _rmPath = foldMap (doublePairSet . (,) (V2 20 60) . fst) lnks
, _rmPmnts = [ spanLightI (V2 0 39.5) (V2 40 39.5) ]
, _rmBound = [ rectNSWE 50 30 (-5) 45 ]
, _rmFloor = Tiled [makeTileFromPoly poly 2]
@@ -43,7 +43,7 @@ corridor = defaultRoom
]
keyholeCorridor :: Room
keyholeCorridor = corridor
{ _rmPath = []
{ _rmPath = mempty
, _rmPmnts =
[ midWall $ rectNSWE top bot 15 0
, midWall $ rectNSWE top bot 40 25]
@@ -65,7 +65,7 @@ corridorN = defaultRoom
where lnks = [uncurry outLink (V2 20 70 ,0)
,uncurry inLink (V2 20 10 ,pi)
]
pth = doublePair (V2 20 70,V2 20 10)
pth = doublePairSet (V2 20 70,V2 20 10)
corridorWallN :: Room
corridorWallN = defaultRoom
{ _rmPolys = [rectNSWE 70 0 0 40
@@ -79,15 +79,16 @@ corridorWallN = defaultRoom
lnks = [uncurry outLink(V2 20 70 ,0)
,uncurry inLink(V2 20 10 ,pi)
]
pth = doublePair (V2 20 70,V2 20 10)
pth = doublePairSet (V2 20 70,V2 20 10)
-- this should be combined with tWest
tEast :: Room
tEast = defaultRoom
{ _rmPolys = [rectNSWE 80 0 (-20) 20
,rectNSWE 80 40 (-40) 40
]
, _rmLinks = lnks'
, _rmPath = concatMap (doublePair . (,) (V2 0 60) . fst) lnks
, _rmPath = foldMap (doublePairSet . (,) (V2 0 60) . fst) lnks
, _rmPmnts = []
, _rmBound = [ rectNSWE 70 10 0 40 ]
, _rmName = "tEast"
@@ -109,7 +110,7 @@ tWest = defaultRoom
,rectNSWE 80 40 (-40) 40
]
, _rmLinks = lnks
, _rmPath = concatMap (doublePair . (V2 0 60 ,) . _rlPos) lnks
, _rmPath = foldMap (doublePairSet . (V2 0 60 ,) . _rlPos) lnks
, _rmPmnts = []
, _rmBound = [ rectNSWE 70 10 0 40 ]
, _rmName = "tWest"
src/Dodge/Room/Door.hs
+2 -2
View File
@@ -18,7 +18,7 @@ door :: Room
door = defaultRoom
{ _rmPolys = [rectNSWE 40 0 0 40]
, _rmLinks = init lnks ++ [last lnks]
, _rmPath = [(V2 20 35,V2 20 5)]
, _rmPath = doublePairSet (V2 20 35,V2 20 5)
-- door extends into side walls (for shadows as rendered 12/03)
, _rmPmnts = [putAutoDoor (V2 0 20) (V2 40 20)]
, _rmName = "autoDoor"
@@ -33,7 +33,7 @@ triggerDoorRoom :: Int -> Room
triggerDoorRoom inplid = defaultRoom
{ _rmPolys = [rectNSWE 40 0 0 40]
, _rmLinks = [uncurry outLink (V2 20 35,0) ,uncurry inLink(V2 20 5,pi) ]
, _rmPath = [(V2 20 35,V2 20 5)]
, _rmPath = doublePairSet (V2 20 35,V2 20 5)
, _rmInPmnt = [InPlacement f inplid]
, _rmName = "triggerDoorRoom"
-- door extends into side walls (for shadows as rendered 12/03/21)
src/Dodge/Room/Link.hs
+3 -3
View File
@@ -22,7 +22,7 @@ import Data.Tile
import Dodge.RoomLink
import Control.Lens
--import qualified Data.Set as S
import qualified Data.Set as S
restrictRMInLinksPD :: ((Point2,Float) -> Bool) -> Room -> Room
restrictRMInLinksPD f = rmLinks %~ restrictLinkType InLink f
@@ -40,7 +40,7 @@ shiftRoomBy :: (Point2,Float) -> Room -> Room
shiftRoomBy shift r = r
& rmPolys %~ fmap (map (shiftPointBy shift))
& rmLinks %~ fmap (shiftLinkBy shift)
& rmPath %~ map (shiftPathBy shift)
& rmPath %~ S.map (shiftPathBy shift)
& rmBound %~ fmap (map (shiftPointBy shift))
& rmShift %~ shiftPosDirBy shift
& rmFloor . tiles %~ map
@@ -54,7 +54,7 @@ moveRoomBy :: (Point2,Float) -> Room -> Room
moveRoomBy shift r = r
& rmPolys %~ fmap (map (shiftPointBy shift))
& rmLinks %~ fmap (shiftLinkBy shift)
& rmPath %~ map (shiftPathBy shift)
& rmPath %~ S.map (shiftPathBy shift)
& rmBound %~ fmap (map (shiftPointBy shift))
& rmPmnts %~ map (shiftPlacement shift)
& rmFloor . tiles %~ map
src/Dodge/Room/LongDoor.hs
+1 -1
View File
@@ -43,7 +43,7 @@ twinSlowDoorRoom w h x = defaultRoom
[ (V2 w (h/2) , negate $ pi/2)
, (V2 (-w) (h/2) , pi/2) ]
++ [uncurry inLink (V2 0 (-h), pi) ]
, _rmPath = []
, _rmPath = mempty
, _rmPmnts =
[ pContID (PS (V2 0 (h-5)) pi) ( PutButton $ makeButton col id)
$ \btid -> jsps0J (PutSlideDr (thedoor btid) thewall 1 (V2 x 1) (V2 x h))
src/Dodge/Room/Ngon.hs
+1 -1
View File
@@ -19,7 +19,7 @@ roomNgon :: Int -> Float -> Room
roomNgon n x = defaultRoom
{ _rmPolys = [poly]
, _rmLinks = map toBothLnk lnks -- muout (init lnks) ++ muin[last lnks]
, _rmPath = [] -- TODO
, _rmPath = mempty -- TODO
, _rmPmnts = [mntLightLnkCond $ resetPLUse $ rprBool $ const . isInLnk]
, _rmBound = [poly]
, _rmFloor = Tiled [makeTileFromPoly poly 9]
src/Dodge/Room/Path.hs
+5 -5
View File
@@ -19,6 +19,7 @@ import Data.Bifunctor
import Data.Maybe
import qualified Data.Tuple.Extra as Tup
import qualified Control.Foldl as L
import qualified Data.Set as S
createPathGrid :: Room -> Room
createPathGrid rm = rm
@@ -35,13 +36,12 @@ createPathGrid rm = rm
<*> L.premap sndV2 L.minimum
<*> L.premap sndV2 L.maximum
-- ?TODO? : make this minimumOn
linksAndPath :: [(Point2,Float)] -> [(Point2,Point2)] -> [(Point2,Point2)]
linksAndPath lnks subpth = subpth ++ concatMap linkClosest lnks
linksAndPath :: [(Point2,Float)] -> [(Point2,Point2)] -> S.Set (Point2,Point2)
linksAndPath lnks subpth = S.fromList subpth <> foldMap linkClosest lnks
where
linkClosest (p,_) = doublePair (p, minimumBy (compare `on` dist p) $ map fst subpth)
linkClosest (p,_) = doublePairSet (p, minimumBy (compare `on` dist p) $ map fst subpth)
linksAndPath' :: [RoomLink] -> [(Point2,Point2)] -> [(Point2,Point2)]
linksAndPath' :: [RoomLink] -> [(Point2,Point2)] -> S.Set (Point2,Point2)
linksAndPath' = linksAndPath . map lnkPosDir
testCrossWalls
src/Dodge/Room/Procedural.hs
+6 -6
View File
@@ -49,7 +49,7 @@ roomRect x y xn yn = defaultRoom
{ _rmPolys = [rectNSWE y 0 0 x ]
, _rmLinks = lnks
, _rmName = "rect"
, _rmPath = concatMap doublePair pth
, _rmPath = foldMap doublePairSet pth
--, _rmPos = map (roomposat (RoomPosOnPath S.empty)) posps
-- ++ map (roomposat (RoomPosOffPath S.empty)) interposps
, _rmPos = map makeonpos posps'
@@ -86,7 +86,7 @@ roomRect x y xn yn = defaultRoom
++ m South (FromEdge West) (FromEdge East) slnks
m edge edgefrom1 edgefrom2 = zipWith (lnkBothAnd (OnEdge edge) edgefrom1 edgefrom2) [0..]
. zipCountDown
pth = linksAndPath' lnks $ map (bimap (+.+ V2 20 20) (+.+ V2 20 20)) (makeGrid xd xn yd yn)
pth = linksAndPath' lnks $ map (bimap (+.+ V2 20 20) (+.+ V2 20 20)) (makeGrid xd xn yd yn)
makeonpos (p,a) = RoomPos p 0 (S.singleton $ RoomPosOnPath $ makerpedges a) NotLink 0
makerpedges (a,b) = S.fromList
[PathFromEdge South b
@@ -131,7 +131,7 @@ combineRooms :: Room -> Room -> Room
combineRooms r r' = defaultRoom
{ _rmPolys = _rmPolys r ++ _rmPolys r'
, _rmLinks = _rmLinks r ++ _rmLinks r'
, _rmPath = map clampPath $ _rmPath r ++ _rmPath r'
, _rmPath = S.map clampPath $ _rmPath r <> _rmPath r'
, _rmPmnts = _rmPmnts r ++ _rmPmnts r'
, _rmBound = _rmBound r ++ _rmBound r'
, _rmPos = _rmPos r ++ _rmPos r'
@@ -163,7 +163,7 @@ quarterRoomTri w = do
pure $ defaultRoom
{ _rmPolys = [ [V2 0 0,V2 w w,V2 (-w) w] ]
, _rmLinks = [toBothLnk (V2 0 w, 0)]
, _rmPath = concatMap doublePair
, _rmPath = foldMap doublePairSet
[(V2 0 w,V2 0 (w-20))
,(V2 0 (w-20),V2 (w-20) (w-20))
,(V2 0 (w-20),V2 (55-w) (w-20))
@@ -199,7 +199,7 @@ quarterRoomSquare w = do
[ (V2 (w/2) (3*w/2), negate $ pi/4)
, (V2 (negate $ w/2) (3*w/2), pi/4)
]
, _rmPath = concatMap doublePair
, _rmPath = foldMap doublePairSet
[(V2 (0.5*w) (1.5*w),V2 (0.5*w-20) (1.5*w-20))
,(V2 (-0.5*w) (1.5*w),V2 (-0.5*w+20) (1.5*w-20))
,(V2 0 (2*w-40),V2 (-0.5*w+20) (1.5*w-20))
@@ -249,7 +249,7 @@ centerVaultRoom w h d = return $ defaultRoom
,outLink (V2 w 0) (-pi/2)
,outLink (V2 (-w) 0) (pi/2)
, inLink (V2 0 (-h)) pi ]
, _rmPath = []
, _rmPath = mempty
, _rmPmnts =
[sps0 $ PutWall (reverse $ rectNSWE d (d - 30) (d - 30) d ) defaultWall
,sps0 $ PutWall (reverse $ rectNSWE d (d - 30) (30 - d) (-d)) defaultWall
src/Dodge/Room/RoadBlock.hs
+1 -1
View File
@@ -35,7 +35,7 @@ litCorridor90 = do
, _rmLinks =
[ outLink (V2 40 (h - 80)) (-pi/2)
, inLink (V2 20 0 ) pi ]
, _rmPath = concatMap doublePair
, _rmPath = foldMap doublePairSet
[( V2 20 0 , V2 20 (h-40) )
,( V2 0 (h-40) , V2 20 (h-40) )
,( V2 40 (h-40) , V2 20 (h-40) )
src/Dodge/Room/Room.hs
+2 -2
View File
@@ -60,7 +60,7 @@ roomPadCut :: [Point2] -> Point2 -> Room
roomPadCut ps p = defaultRoom
{ _rmPolys = [ps]
, _rmLinks = muout [(p,0)] ++ muin [(V2 0 0,pi)]
, _rmPath = [(V2 0 0,p)]
, _rmPath = doublePairSet (V2 0 0,p)
}
branchWith :: Room -> [Tree Room] -> Tree Room
@@ -220,7 +220,7 @@ deadEndRoom :: Room
deadEndRoom = defaultRoom
{ _rmPolys = [rectNSWE 40 (-20) (-20) 20 ]
, _rmLinks = muout (init lnks) ++ muin [last lnks]
, _rmPath = []
, _rmPath = mempty
, _rmPmnts = [sPS (V2 0 (-10)) 0 putLamp]
, _rmBound = [rectNSWE 20 (-20) (-30) 30]
, _rmName = "deadEndRoom"
src/Dodge/Room/Treasure.hs
+1 -1
View File
@@ -27,7 +27,7 @@ triLootRoom w h = pure $ defaultRoom
, base
]
, _rmLinks = [uncurry inLink(V2 0 (-80) , pi)]
, _rmPath = doublePair (V2 0 (-80) , V2 0 (h/2))
, _rmPath = doublePairSet (V2 0 (-80) , V2 0 (h/2))
, _rmPmnts =
[sPS (V2 (15-w) 15 ) 0 $ PutID 0
,sPS (V2 (w-15) 15 ) pi $ PutID 0