Work on airlocks

2025-08-23 17:42:36 +01:00
parent f641805845
commit 32d7120177
19 changed files with 380 additions and 334 deletions
@@ -1,52 +1,51 @@
 --{-# LANGUAGE LambdaCase #-}
-module Dodge.PlacementSpot 
-    ( atFstLnkOut
-    , atNthLnkOutShiftBy
-    , rpIsOnPath
-    , rpIsOffPath
-    , rpOffPathFromEdge
-    , rpOnPathFromEdge
-    , useUnusedLnk
-    , psRandRanges
-    , useRoomPosCond
-    , isUsedLnkUnplaced
-    , anyUnusedSpot
-    , unusedSpotAwayFromLink
-    , isUnusedLnk
-    , isInLnk
-    , isOutLnk
-    , unusedSpotNearInLink
-    , randDirPS
-    , unusedSpotAwayFromInLink
-    , useLnkRoomPos
-    , atFstLnkOutShiftInward
-    , atFstLnkOutShiftBy
-    , atNthLnkOutShiftInward
-    , unusedOffPathAwayFromLink
-    , setFallback
-    , twoRoomPoss
-    , isUnusedLnkType
-    , rprBoolShift 
-    , rprShift
-    , rprBool
-    , shiftInBy
-    , resetPLUse
-    , psposAddLabel
-    , shiftByV2
-    , usedRoomLinkPoss
-    , usedRoomInLinkPoss
-    , atNthLinkOut
-    ) where
-
-import Dodge.Data.GenWorld
-import Geometry
+module Dodge.PlacementSpot (
+    atFstLnkOut,
+    atNthLnkOutShiftBy,
+    rpIsOnPath,
+    rpIsOffPath,
+    rpOffPathFromEdge,
+    rpOnPathFromEdge,
+    useUnusedLnk,
+    psRandRanges,
+    useRoomPosCond,
+    isUsedLnkUnplaced,
+    anyUnusedSpot,
+    unusedSpotAwayFromLink,
+    isUnusedLnk,
+    isInLnk,
+    isOutLnk,
+    unusedSpotNearInLink,
+    randDirPS,
+    unusedSpotAwayFromInLink,
+    useLnkRoomPos,
+    atFstLnkOutShiftInward,
+    atFstLnkOutShiftBy,
+    atNthLnkOutShiftInward,
+    unusedOffPathAwayFromLink,
+    setFallback,
+    twoRoomPoss,
+    isUnusedLnkType,
+    rprBoolShift,
+    rprShift,
+    rprBool,
+    shiftInBy,
+    resetPLUse,
+    psposAddLabel,
+    shiftByV2,
+    usedRoomLinkPoss,
+    usedRoomInLinkPoss,
+    atNthLinkOut,
+) where

 import Control.Lens
-import Data.Maybe
-import Data.Bifunctor
 import Control.Monad.State
-import System.Random
+import Data.Bifunctor
+import Data.Maybe
 import qualified Data.Set as S
+import Dodge.Data.GenWorld
+import Geometry
+import System.Random

 setDirPS :: Float -> PlacementSpot -> PlacementSpot
 setDirPS a ps = case ps of
@@ -57,16 +56,16 @@ setDirPS a ps = case ps of

 randDirPS :: RandomGen g => PlacementSpot -> State g PlacementSpot
 randDirPS ps = do
-    a <- state $ randomR (0,pi*2)
+    a <- state $ randomR (0, pi * 2)
    return $ setDirPS a ps

 isUnusedLnk :: RoomPos -> Room -> Bool
 isUnusedLnk rp _ = case _rpLinkStatus rp of
-    UnusedLink {} -> _rpPlacementUse rp == 0
+    UnusedLink{} -> _rpPlacementUse rp == 0
    _ -> False

 anyUnusedSpot :: PlacementSpot
-anyUnusedSpot = rprBool $ \rp _ -> _rpLinkStatus rp == NotLink && _rpPlacementUse rp == 0 
+anyUnusedSpot = rprBool $ \rp _ -> _rpLinkStatus rp == NotLink && _rpPlacementUse rp == 0

 psposAddLabel :: RoomPosType -> PlacementSpot -> PlacementSpot
 psposAddLabel lab = psSelect %~ (\f rp r -> f rp r & _Just . _2 . rpType %~ S.insert lab)
@@ -77,23 +76,25 @@ rprBool t = PSPos (useRoomPosRoomCond t) (const id) Nothing
 rpIsOnPath :: RoomPos -> Bool
 rpIsOnPath = any f . _rpType
  where
-    f RoomPosOnPath {} = True
+    f RoomPosOnPath{} = True
    f _ = False
+
 rpIsOffPath :: RoomPos -> Bool
 rpIsOffPath = any f . _rpType
  where
-    f RoomPosOffPath {} = True
+    f RoomPosOffPath{} = True
    f _ = False
+
 rpOffPathFromEdge :: PathFromEdge -> RoomPos -> Bool
 rpOffPathFromEdge pe = any f . _rpType
  where
-    f rt = maybe False (pe `elem`) (rt ^? offPathFromEdges) 
+    f rt = maybe False (pe `elem`) (rt ^? offPathFromEdges)

 -- test whether a roomPos is on the path with a given from edge value
 rpOnPathFromEdge :: PathFromEdge -> RoomPos -> Bool
 rpOnPathFromEdge pe = any f . _rpType
  where
-    f rt = maybe False (pe `elem`) (rt ^? onPathFromEdges) 
+    f rt = maybe False (pe `elem`) (rt ^? onPathFromEdges)

 resetPLUse :: PlacementSpot -> PlacementSpot
 resetPLUse (PSPos f g fallback) = PSPos f' g fallback
@@ -101,58 +102,64 @@ resetPLUse (PSPos f g fallback) = PSPos f' g fallback
    f' rp = fmap (second (rpPlacementUse .~ 0)) . f rp
 resetPLUse _ = error "Tried to reset _rpPlacementUse of non PSPos placement"

-rprShift
-    :: (RoomPos -> Room -> Maybe (Point2,Float)) 
-    -> PlacementSpot
+rprShift ::
+    (RoomPos -> Room -> Maybe (Point2, Float)) ->
+    PlacementSpot
 rprShift t = PSPos f (const id) Nothing
  where
    f rp r = case t rp r of
-        Just (p,a)  -> Just (PS p a, rp & rpPlacementUse +~ 1)
-        Nothing     -> Nothing
+        Just (p, a) -> Just (PS p a, rp & rpPlacementUse +~ 1)
+        Nothing -> Nothing

-rprBoolShift :: (RoomPos -> Room -> Bool) 
-    -> ((Point2,Float) -> (Point2,Float))
-    -> PlacementSpot
+rprBoolShift ::
+    (RoomPos -> Room -> Bool) ->
+    ((Point2, Float) -> (Point2, Float)) ->
+    PlacementSpot
 rprBoolShift t shift = PSPos f (const id) Nothing
  where
    f rp r
-        | t rp r    = Just (PS p a, rp & rpPlacementUse +~ 1)
+        | t rp r = Just (PS p a, rp & rpPlacementUse +~ 1)
        | otherwise = Nothing
      where
-        (p,a) = shift (_rpPos rp, _rpDir rp)
+        (p, a) = shift (_rpPos rp, _rpDir rp)

 unusedSpotAwayFromLink :: Float -> PlacementSpot
-unusedSpotAwayFromLink x = rprBool $ \rp r -> _rpLinkStatus rp == NotLink 
-    && _rpPlacementUse rp == 0 
-    && all ( (>x) . dist (_rpPos rp) ) (usedRoomLinkPoss r)
+unusedSpotAwayFromLink x = rprBool $ \rp r ->
+    _rpLinkStatus rp == NotLink
+        && _rpPlacementUse rp == 0
+        && all ((> x) . dist (_rpPos rp)) (usedRoomLinkPoss r)

 setFallback :: Placement -> Placement -> Placement
-setFallback fallback 
-    = (plSpot . psFallback %~ maybe (Just fallback) Just)
-    . (plIDCont %~ fmap (fmap (fmap $ setFallback fallback))
-    )
+setFallback fallback =
+    (plSpot . psFallback %~ maybe (Just fallback) Just)
+        . ( plIDCont %~ fmap (fmap (fmap $ setFallback fallback))
+          )

 unusedOffPathAwayFromLink :: Float -> PlacementSpot
--unusedOffPathAwayFromLink x = rprBool $ \rp r -> _rpLinkStatus rp == NotLink 
-unusedOffPathAwayFromLink x = rprBool $ \rp r -> _rpPlacementUse rp == 0 
-    && all ( (>x) . dist (_rpPos rp) ) (usedRoomLinkPoss r)
-    && rpIsOffPath rp
+--unusedOffPathAwayFromLink x = rprBool $ \rp r -> _rpLinkStatus rp == NotLink
+unusedOffPathAwayFromLink x = rprBool $ \rp r ->
+    _rpPlacementUse rp == 0
+        && all ((> x) . dist (_rpPos rp)) (usedRoomLinkPoss r)
+        && rpIsOffPath rp

 unusedSpotAwayFromInLink :: Float -> PlacementSpot
-unusedSpotAwayFromInLink x = rprBool $ \rp r -> _rpLinkStatus rp == NotLink 
-    && _rpPlacementUse rp == 0 
-    && all ( (>x) . dist (_rpPos rp) ) (usedRoomInLinkPoss r)
+unusedSpotAwayFromInLink x = rprBool $ \rp r ->
+    _rpLinkStatus rp == NotLink
+        && _rpPlacementUse rp == 0
+        && all ((> x) . dist (_rpPos rp)) (usedRoomInLinkPoss r)

 --twoUnusedLinks :: (PlacementSpot -> PlacementSpot -> Placement) -> Placement
 --twoUnusedLinks = twoRoomPoss isUnusedLnk isUnusedLnk

-twoRoomPoss :: (RoomPos -> Room -> Bool)
-    -> (RoomPos -> Room -> Bool)
-    -> (PlacementSpot -> PlacementSpot -> Placement)
-    -> Placement
-twoRoomPoss cond1 cond2 f = Placement 10 (rprBool cond1) PutNothing Nothing
-    $ \_ pl1 -> Just $ Placement 10 (rprBool cond2) PutNothing Nothing
-    $ \_ pl2 -> Just $ f (_plSpot pl1) (_plSpot pl2)
+twoRoomPoss ::
+    (RoomPos -> Room -> Bool) ->
+    (RoomPos -> Room -> Bool) ->
+    (PlacementSpot -> PlacementSpot -> Placement) ->
+    Placement
+twoRoomPoss cond1 cond2 f = Placement 10 (rprBool cond1) PutNothing Nothing $
+    \_ pl1 -> Just $
+        Placement 10 (rprBool cond2) PutNothing Nothing $
+            \_ pl2 -> Just $ f (_plSpot pl1) (_plSpot pl2)

 --isUnusedLnk :: RoomPos -> Bool
 --isUnusedLnk rp = case _rpLinkStatus rp of
@@ -161,26 +168,27 @@ twoRoomPoss cond1 cond2 f = Placement 10 (rprBool cond1) PutNothing Nothing

 isInLnk :: RoomPos -> Bool
 isInLnk rp = case _rpLinkStatus rp of
-    UsedInLink {} -> _rpPlacementUse rp == 0
+    UsedInLink{} -> _rpPlacementUse rp == 0
    _ -> False
+
 isOutLnk :: RoomPos -> Bool
 isOutLnk rp = case _rpLinkStatus rp of
-    UsedOutLink {} -> _rpPlacementUse rp == 0
+    UsedOutLink{} -> _rpPlacementUse rp == 0
    _ -> False

 useUnusedLnk :: PlacementSpot
 useUnusedLnk = rprBool isUnusedLnk

 isUsedLnkUnplaced :: RoomPos -> Bool
-isUsedLnkUnplaced  rp = case _rpLinkStatus rp of
-    UsedOutLink {} -> _rpPlacementUse rp == 0
-    UsedInLink  {} -> _rpPlacementUse rp == 0
+isUsedLnkUnplaced rp = case _rpLinkStatus rp of
+    UsedOutLink{} -> _rpPlacementUse rp == 0
+    UsedInLink{} -> _rpPlacementUse rp == 0
    _ -> False

-useRoomPosCond :: (RoomPos -> Room -> Bool) -> RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)
+useRoomPosCond :: (RoomPos -> Room -> Bool) -> RoomPos -> Room -> Maybe (PlacementSpot, RoomPos)
 useRoomPosCond f = useRoomPosRoomCond $ \rp r -> f rp r

-useRoomPosRoomCond :: (RoomPos -> Room -> Bool) -> RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)
+useRoomPosRoomCond :: (RoomPos -> Room -> Bool) -> RoomPos -> Room -> Maybe (PlacementSpot, RoomPos)
 useRoomPosRoomCond t rp r
    | t rp r = Just (PS (_rpPos rp) (_rpDir rp), rp & rpPlacementUse +~ 1)
    | otherwise = Nothing
@@ -191,23 +199,24 @@ isUnusedLnkType rlt rp _ = case _rpLinkStatus rp of
    _ -> False

 unusedSpotNearInLink :: Float -> PlacementSpot
-unusedSpotNearInLink x = rprBool $ \rp r -> _rpLinkStatus rp == NotLink
-    && _rpPlacementUse rp == 0 
-    && any ( (<x) . dist (_rpPos rp) ) (usedRoomInLinkPoss r)
+unusedSpotNearInLink x = rprBool $ \rp r ->
+    _rpLinkStatus rp == NotLink
+        && _rpPlacementUse rp == 0
+        && any ((< x) . dist (_rpPos rp)) (usedRoomInLinkPoss r)

 usedRoomInLinkPoss :: Room -> [Point2]
 usedRoomInLinkPoss r = mapMaybe f $ _rmPos r
  where
    f rp = case _rpLinkStatus rp of
-        UsedInLink {} -> Just $ _rpPos rp
+        UsedInLink{} -> Just $ _rpPos rp
        _ -> Nothing

 usedRoomLinkPoss :: Room -> [Point2]
 usedRoomLinkPoss r = mapMaybe f $ _rmPos r
  where
    f rp = case _rpLinkStatus rp of
-        UsedInLink {} -> Just $ _rpPos rp
-        UsedOutLink {} -> Just $ _rpPos rp
+        UsedInLink{} -> Just $ _rpPos rp
+        UsedOutLink{} -> Just $ _rpPos rp
        _ -> Nothing

 atFstLnkOut :: PlacementSpot
@@ -216,44 +225,45 @@ atFstLnkOut = atNthLinkOut 0
 atNthLinkOut :: Int -> PlacementSpot
 atNthLinkOut n = rprBool $ \rp _ -> rp ^? rpLinkStatus . rplsChildNum == Just n

-atNthLnkOutShiftBy :: Int -> ((Point2,Float) -> (Point2,Float)) -> PlacementSpot
-atNthLnkOutShiftBy n = rprBoolShift 
-    $ \ rp _ -> rp ^? rpLinkStatus . rplsChildNum == Just n
+atNthLnkOutShiftBy :: Int -> ((Point2, Float) -> (Point2, Float)) -> PlacementSpot
+atNthLnkOutShiftBy n = rprBoolShift $
+    \rp _ -> rp ^? rpLinkStatus . rplsChildNum == Just n
+
 --atNthLnkOutShiftBy n theshift = PSPos f (const id) Nothing
 --  where
 --    f rp _ = case _rpLinkStatus rp of
--        UsedOutLink {_rplsChildNum = i} | i == n 
+--        UsedOutLink {_rplsChildNum = i} | i == n
 --            -> Just (PS p a, rp & rpPlacementUse +~ 1)
 --        _   -> Nothing
 --      where
 --        (p,a) = theshift (_rpPos rp,_rpDir rp)

-atFstLnkOutShiftBy :: ((Point2,Float) -> (Point2,Float)) -> PlacementSpot
+atFstLnkOutShiftBy :: ((Point2, Float) -> (Point2, Float)) -> PlacementSpot
 atFstLnkOutShiftBy = atNthLnkOutShiftBy 0

 atFstLnkOutShiftInward :: Float -> PlacementSpot
 atFstLnkOutShiftInward = atNthLnkOutShiftInward 0

 atNthLnkOutShiftInward :: Int -> Float -> PlacementSpot
-atNthLnkOutShiftInward n x = atNthLnkOutShiftBy n
-    $ \ (p,a) -> (p +.+ rotateV a (V2 0 (negate x)),a)
+atNthLnkOutShiftInward n x = atNthLnkOutShiftBy n $
+    \(p, a) -> (p +.+ rotateV a (V2 0 (negate x)), a)

-shiftInBy :: Float -> (Point2,Float) -> (Point2,Float)
-shiftInBy x (p,a) = (p +.+ rotateV a (V2 0 (negate x)),a)
+shiftInBy :: Float -> (Point2, Float) -> (Point2, Float)
+shiftInBy x (p, a) = (p +.+ rotateV a (V2 0 (negate x)), a)

-shiftByV2 :: Point2 -> (Point2,Float) -> (Point2,Float)
-shiftByV2 x (p,a) = (p +.+ rotateV a x,a)
+shiftByV2 :: Point2 -> (Point2, Float) -> (Point2, Float)
+shiftByV2 x (p, a) = (p +.+ rotateV a x, a)

 -- this should probably check the placement use, but so should others: should
 -- unify these
-useLnkRoomPos :: RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)
+useLnkRoomPos :: RoomPos -> Room -> Maybe (PlacementSpot, RoomPos)
 useLnkRoomPos rp _ = case _rpLinkStatus rp of
-    UnusedLink {} -> Just (PS (_rpPos rp) (_rpDir rp) , rp & rpPlacementUse +~ 1)
+    UnusedLink{} -> Just (PS (_rpPos rp) (_rpDir rp), rp & rpPlacementUse +~ 1)
    _ -> Nothing

-psRandRanges :: (Float,Float) -> (Float,Float) -> (Float,Float) -> State StdGen (Point2,Float)
+psRandRanges :: (Float, Float) -> (Float, Float) -> (Float, Float) -> State StdGen (Point2, Float)
 psRandRanges xranges yranges aranges = do
    x <- state $ randomR xranges
    y <- state $ randomR yranges
    a <- state $ randomR aranges
-    return (V2 x y,a)
+    return (V2 x y, a)