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

Try to simplify link code in roomRect

Browse Source
This commit is contained in:
justin
2025-10-27 15:10:19 +00:00
parent c88fc1c729
commit 0946ee1310
9 changed files with 95 additions and 105 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Room/Airlock.hs
+3 -4
View File
@@ -177,7 +177,7 @@ airlockZ = do
defaultRoom
{ _rmPolys = [rectNSWE 120 0 0 180]
, _rmLinks = lnks
, _rmPath = linksGridToPath' lnks $ loopPairs $ rectNSWE 100 40 40 140
, _rmPath = linksDAGToPath lnks $ loopPairs $ rectNSWE 100 40 40 140
, _rmPmnts =
[ pContID (PS (V2 90 115) pi) xSwitch $
\btid ->
@@ -212,7 +212,7 @@ airlock90 =
]
]
, _rmLinks = lnks
, _rmPath = linksGridToPath' lnks $ doublePairSet (V2 40 40, V2 80 80)
, _rmPath = linksDAGToPath lnks $ [(40,80)]
, _rmPmnts =
[ pContID
(PS (V2 120 120) (3 * pi / 4))
@@ -251,8 +251,7 @@ airlockCrystal =
defaultRoom
{ _rmPolys = [rectNSWE 140 0 0 40, switchcutout]
, _rmLinks = lnks
, _rmPath = linksGridToPath' lnks
$ loopPairs [V2 20 40, V2 100 70, V2 20 110]
, _rmPath = linksDAGToPath lnks $ loopPairs [V2 20 40, V2 100 70, V2 20 110]
, _rmPmnts =
[ pContID
(PS (V2 145 70) (pi / 2))
src/Dodge/Room/Boss.hs
+1 -5
View File
@@ -32,11 +32,7 @@ roomGlassOctogon x =
]
, _rmLinks = lnks'
, _rmPath =
linksGridToPath
lnks'
[ (V2 0 x, V2 0 (- (x + 40)))
, (V2 0 (- (x + 40)), V2 0 x)
]
linksDAGToPath lnks' [ (V2 0 x, V2 0 (- (x + 40))) ]
, _rmPmnts =
[ sPS (V2 fx fx) 0 putLamp
, sPS (V2 (- fx) fx) 0 putLamp
src/Dodge/Room/Ngon.hs
+1 -2
View File
@@ -20,7 +20,7 @@ roomNgon n x = do
defaultRoom
{ _rmPolys = [poly]
, _rmLinks = map f lnks
, _rmPath = linksGridToPath (map f lnks) path4
, _rmPath = linksDAGToPath (map f lnks) path3
, _rmPmnts = [thelight]
, _rmBound = [poly]
, _rmFloor = Tiled [makeTileFromPoly poly 2]
@@ -34,7 +34,6 @@ roomNgon n x = do
path1 = polyOrthDist n (x-10)
path2 = concat $ zipWith g path1 (tail path1 <> [head path1])
path3 = loopPairs path2 <> fmap (,V2 0 0) path2
path4 = concatMap doublePair path3
poss = map (\p -> RoomPos p 0 mempty (NotLink True) mempty)
(V2 0 0 : path1)
g z y = [z, 0.5 * (z + y)]
src/Dodge/Room/Path.hs
+8 -18
View File
@@ -1,11 +1,5 @@
module Dodge.Room.Path (
gridPoints,
linksGridToPath,
-- makeGrid,
-- createPathGrid,
gridPoints'',
linksGridToPath',
) where
{-# LANGUAGE TupleSections #-}
module Dodge.Room.Path (linksDAGToPath) where
import Control.Lens
import Data.Function (on)
@@ -13,16 +7,12 @@ import Data.List
import qualified Data.Set as S
import Dodge.Data.GenWorld
import Geometry
import Grid
-- assumes subpth is symmetric
linksGridToPath :: [RoomLink] -> [(Point2, Point2)] -> S.Set (Point2, Point2)
linksGridToPath lnks subpth = S.fromList subpth <> foldMap (linkClosest . (^. rlPos)) lnks
linksDAGToPath :: Foldable f => [RoomLink] -> f (Point2, Point2) -> S.Set (Point2, Point2)
linksDAGToPath lnks xs
| null xs = foldMap doublePairSet $ ys & each %~ (, centroid ys)
| otherwise = subpth <> foldMap (linkClosest . (^. rlPos)) lnks
where
linkClosest p = doublePairSet (p, minimumBy (compare `on` dist p) $ map fst subpth)
linksGridToPath' :: Foldable f => [RoomLink] -> f (Point2, Point2) -> S.Set (Point2, Point2)
linksGridToPath' lnks subpth' = subpth <> foldMap (linkClosest . (^. rlPos)) lnks
where
subpth = foldMap doublePairSet subpth'
ys = lnks <&> _rlPos
subpth = foldMap doublePairSet xs
linkClosest p = doublePairSet (p, minimumBy (compare `on` dist p) $ S.map fst subpth)
src/Dodge/Room/Procedural.hs
+29 -19
View File
@@ -44,12 +44,8 @@ roomRect x y xn yn =
{ _rmPolys = [rectNSWE y 0 0 x]
, _rmLinks = lnks
, _rmName = "rect"
, _rmPath = foldMap doublePairSet pth
, --, _rmPos = map (roomposat (RoomPosOnPath S.empty)) posps
-- ++ map (roomposat (RoomPosOffPath S.empty)) interposps
_rmPos =
map makeonpos posps
++ map makeoffpos interposps
, _rmPath = pth
, _rmPos = map makeonpos posps ++ map makeoffpos interposps
, _rmPmnts = []
, _rmBound = [rectNSWE (y + 5) (-5) (-5) (x + 5)]
, _rmFloor =
@@ -78,20 +74,34 @@ roomRect x y xn yn =
ys = take (yn + 1) [0,yd..] & each +~ 20
yd = (y - 40) / fromIntegral yn
xd = (x - 40) / fromIntegral xn
pth = linksGridToPath lnks
$ latticeXsYs xs ys
--pth = linksGridToPath lnks
-- $ map (bimap (+.+ V2 20 20) (+.+ V2 20 20)) (makeGrid xd xn yd yn)
pth = linksDAGToPath lnks $ latticeXsYs xs ys
hls y' a e = xs <&> \x' -> RoomLink (rlt e) (V2 x' y') a
vls x' a e = ys <&> \y' -> RoomLink (rlt e) (V2 x' y') a
rlt e = S.fromList [OnEdge e, InLink, OutLink]
somelnks poffset ps a = zip (map (+.+ poffset) ps) (repeat a)
wlnks = somelnks (V2 0 20) (gridPoints 0 1 yd (yn + 1)) (pi / 2)
elnks = somelnks (V2 x 20) (gridPoints 0 1 yd (yn + 1)) (- pi / 2)
nlnks = somelnks (V2 20 y) (gridPoints xd (xn + 1) 0 1) 0
slnks = somelnks (V2 20 0) (gridPoints xd (xn + 1) 0 1) pi
lnks =
m North (FromEdge West) (FromEdge East) nlnks
++ m East (FromEdge South) (FromEdge North) elnks
++ m West (FromEdge South) (FromEdge North) wlnks
++ m South (FromEdge West) (FromEdge East) slnks
wlnks = vls 0 (pi/2) West
elnks = vls x (-pi/2) East
nlnks = hls y 0 North --somelnks (V2 20 y) (gridPoints xd (xn + 1) 0 1) 0
slnks = hls 0 pi South --somelnks (V2 20 0) (gridPoints xd (xn + 1) 0 1) pi
lnks = zipWith g nlnks [0..]
<> zipWith g slnks [0..]
<> zipWith g' elnks [0..]
<> zipWith g' wlnks [0..]
g ln xi = ln & rlType <>~ S.fromList [FromEdge West xi,FromEdge East (xn - xi)]
g' ln xi = ln & rlType <>~ S.fromList [FromEdge South xi,FromEdge North (xn - xi)]
-- lnks= m North (FromEdge West) (FromEdge East) nlnks
-- ++ m East (FromEdge South) (FromEdge North) elnks
-- ++ m West (FromEdge South) (FromEdge North) wlnks
-- ++ m South (FromEdge West) (FromEdge East) slnks
--wlnks = somelnks (V2 0 20) (gridPoints 0 1 yd (yn + 1)) (pi / 2)
--elnks = somelnks (V2 x 20) (gridPoints 0 1 yd (yn + 1)) (- pi / 2)
--nlnks = somelnks (V2 20 y) (gridPoints xd (xn + 1) 0 1) 0
--slnks = somelnks (V2 20 0) (gridPoints xd (xn + 1) 0 1) pi
--lnks =
-- m North (FromEdge West) (FromEdge East) nlnks
-- ++ m East (FromEdge South) (FromEdge North) elnks
-- ++ m West (FromEdge South) (FromEdge North) wlnks
-- ++ m South (FromEdge West) (FromEdge East) slnks
m edge edgefrom1 edgefrom2 =
zipWith (lnkBothAnd (OnEdge edge) edgefrom1 edgefrom2) [0 ..]
. zipCountDown
src/Dodge/Room/Tutorial.hs
+2 -2
View File
@@ -47,12 +47,12 @@ tutAnoTree = do
[ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
, corDoor
-- , return $ tToBTree "cor" $ return $ cleatOnward $ corridor & rmPmnts .~ mempty
, return $ tToBTree "cor" $ return $ cleatOnward $ roomGlassOctogon 200
-- , return $ tToBTree "cor" $ return $ cleatOnward $ roomGlassOctogon 200
-- , corDoor
-- , return $ tToBTree "cor" $ return $ cleatOnward (twinSlowDoorRoom 80 200 40)
-- , return $ tToBTree "cor" $ return $ cleatOnward corridor
-- , return $ tToBTree "cor" $ return $ cleatOnward airlock0
, return $ tToBTree "cor" $ return $ cleatOnward corridor
-- , return $ tToBTree "cor" $ return $ cleatOnward corridor
, tToBTree "cor" . return . cleatOnward <$> (zChasm 25)
-- , tToBTree "x" . return . cleatOnward <$> airlockSimple
-- , tToBTree "lastun" . return . cleatOnward <$> tanksRoom [] []
src/Geometry/Polygon.hs
+1
View File
@@ -165,6 +165,7 @@ grahamEliminate (x : y : z : xs)
| not $ isLHS x y z = grahamEliminate (x : z : xs)
grahamEliminate xs = xs
-- this isn't the centroid of the polygon...
centroid :: (Num (f a),Functor f, Fractional a,Foldable t) => t (f a) -> f a
centroid = L.fold $ (^/) <$> L.Fold (+) 0 id <*> L.genericLength
src/Grid.hs
+2 -1
View File
@@ -28,7 +28,8 @@ latticeXsYs xs ys =
foldMap (\y -> mkpairs xs & each . each %~ (`V2` y)) ys
<> foldMap (\x -> mkpairs ys & each . each %~ V2 x) xs
where
mkpairs zs = zip zs $ tail zs
mkpairs (z:zs) = zip (z:zs) $ zs
mkpairs [] = []
gridPointsOff :: Float -> Float -> Float -> Int -> Float -> Int -> [Point2]
gridPointsOff xoff yoff x nx y ny = map f $ gridPoints' nx ny