Unify RoomPos constructors

2022-03-10 18:40:22 +00:00
parent 7b1ac2b682
commit 01c58490fa
8 changed files with 135 additions and 127 deletions
@@ -25,18 +25,21 @@ randDirPS ps = do
 anyUnusedSpot :: PlacementSpot
 anyUnusedSpot = PSPos f (const id) Nothing
  where
-    f rp _ = case rp of
-        UnusedSpot p a t rpls -> Just (PS p a,UsedSpot p a t rpls)
-        _ -> Nothing
-
+    f rp _ 
+        | _rpLinkStatus rp == NotLink && _rpPlacementUse rp == 0 
+                    = Just $ (PS (_rpPos rp) (_rpDir rp), rp & rpPlacementUse +~ 1)
+        | otherwise = Nothing
 unusedSpotAwayFromLink :: Float -> PlacementSpot
 unusedSpotAwayFromLink x = PSPos f (const id) Nothing
  where
-    f rp r = case rp of
-        UnusedSpot p a t rpls
-            | all ( (>x) . dist p ) (usedRoomLinkPoss r)
-                -> Just (PS p a,UsedSpot p a t rpls)
-        _       -> Nothing
+    f rp r 
+        | _rpLinkStatus rp == NotLink 
+            && _rpPlacementUse rp == 0 
+            && all ( (>x) . dist p ) (usedRoomLinkPoss r)
+                    = Just $ (PS p (_rpDir rp), rp & rpPlacementUse +~ 1)
+        | otherwise = Nothing
+      where
+        p = _rpPos rp

 setFallback :: Placement -> Placement -> Placement
 setFallback fallback plmnt = plmnt
@@ -46,19 +49,27 @@ setFallback fallback plmnt = plmnt
 unusedOffPathAwayFromLink :: Float -> PlacementSpot
 unusedOffPathAwayFromLink x = PSPos f (const id) Nothing
  where
-    f rp r = case rp of
-        UnusedSpot p a t rpls
-            | all ( (>x) . dist p ) (usedRoomLinkPoss r) && RoomPosOffPath `S.member` t
-                -> Just (PS p a,UsedSpot p a t rpls)
-        _       -> Nothing
+    f rp r 
+        | _rpLinkStatus rp == NotLink 
+            && _rpPlacementUse rp == 0 
+            && all ( (>x) . dist p ) (usedRoomLinkPoss r)
+            && RoomPosOffPath `S.member` _rpType rp
+                    = Just $ (PS p (_rpDir rp), rp & rpPlacementUse +~ 1)
+        | otherwise = Nothing
+      where
+        p = _rpPos rp

 unusedSpotAwayFromInLink :: Float -> PlacementSpot
 unusedSpotAwayFromInLink x = PSPos f (const id) Nothing
  where
-    f rp r = case rp of
-        UnusedSpot p a t rpls 
-            | all ( (>x) . dist p ) (usedRoomInLinkPoss r) -> Just (PS p a,UsedSpot p a t rpls)
-        _ -> Nothing
+    f rp r 
+        | _rpLinkStatus rp == NotLink 
+            && _rpPlacementUse rp == 0 
+            && all ( (>x) . dist p ) (usedRoomInLinkPoss r)
+                    = Just $ (PS p (_rpDir rp), rp & rpPlacementUse +~ 1)
+        | otherwise = Nothing
+      where
+        p = _rpPos rp

 twoUnusedLinks :: (PlacementSpot -> PlacementSpot -> Placement)
    -> Placement
@@ -80,73 +91,88 @@ useUnusedLink = PSPos unusedLnkToPS (const id) Nothing
 useRoomPos :: (RoomPos -> Bool) -> PlacementSpot
 useRoomPos cond = PSPos (useRoomPosCond cond) (const id) Nothing

+isUnusedLnk :: RoomPos -> Bool
+isUnusedLnk rp = case _rpLinkStatus rp of
+    UnusedLink {} -> _rpPlacementUse rp == 0
+    _ -> False
+
 useRoomPosCond :: (RoomPos -> Bool)
    -> RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)
 useRoomPosCond t rp _
-    | t rp = Just (PS p a, UsedSpot p a (fromMaybe S.empty $ rp ^? rpType) NotLink)
+    | t rp = Just (PS p a, rp & rpPlacementUse +~ 1)
    | otherwise = Nothing
  where
    p = _rpPos rp
    a = _rpDir rp

 unusedLnkToPS :: RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)
-unusedLnkToPS = useRoomPosCond $ \case
+unusedLnkToPS = useRoomPosCond $ \rp -> case _rpLinkStatus rp of
    UnusedLink {} -> True
    _ -> False

 usedInLnkToPS :: RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)
-usedInLnkToPS = useRoomPosCond $ \case
+usedInLnkToPS = useRoomPosCond $ \rp -> case _rpLinkStatus rp of
    UsedInLink {} -> True
    _ -> False

 isUnusedLinkType :: RoomLinkType -> RoomPos -> Bool
-isUnusedLinkType rlt rp = case rp of
-    UnusedLink{_rpLinkType = rlts} -> rlt `S.member` rlts
+isUnusedLinkType rlt rp = case _rpLinkStatus rp of
+    UnusedLink{_rplsType = rlts} -> rlt `S.member` rlts
    _ -> False

+-- TODO unify this with other xSpotNear/FarLink
 unusedSpotNearInLink :: Float -> PlacementSpot
 unusedSpotNearInLink x = PSPos f (const id) Nothing
  where
-    f rp r = case rp of
-        UnusedSpot p a t rpls 
-            | any ( (<x) . dist p ) (usedRoomInLinkPoss r) -> Just (PS p a,UsedSpot p a t rpls)
-        _ -> Nothing
+    f rp r 
+        | _rpLinkStatus rp == NotLink 
+            && _rpPlacementUse rp == 0 
+            && any ( (<x) . dist p ) (usedRoomInLinkPoss r)
+                    = Just $ (PS p (_rpDir rp), rp & rpPlacementUse +~ 1)
+        | otherwise = Nothing
+      where
+        p = _rpPos rp

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

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

 -- TODO rename to any unused link facing out
+-- note this can REUSE unused links
 anyLnkOutPS :: PlacementSpot
 anyLnkOutPS = PSPos f (const id) Nothing
  where
-    f (UnusedLink p a _ rpls) _ = Just (PS p a, UsedSpot p a S.empty rpls)
-    f _ _ = Nothing
+    f rp _ = case _rpLinkStatus rp of
+        UnusedLink {} -> Just (PS (_rpPos rp) (_rpDir rp), rp & rpPlacementUse +~ 1)
+        _ -> Nothing
    
 atFstLnkOut :: PlacementSpot
 atFstLnkOut = PSPos f (const id) Nothing
  where
-    f (UsedOutLink 0 i p a lt rpls) _ = Just (PS p a, UsedOutLink 0 i p a lt rpls)
-    f _                     _ = Nothing
+    f rp _ = case _rpLinkStatus rp of
+        UsedOutLink {_rplsChildNum = 0} -> Just (PS (_rpPos rp) (_rpDir rp), rp & rpPlacementUse +~ 1)
+        _ -> Nothing

 atNthLnkOutShiftBy :: Int -> ((Point2,Float) -> (Point2,Float)) -> PlacementSpot
 atNthLnkOutShiftBy n theshift = PSPos f (const id) Nothing
  where
-    f (UsedOutLink i rmid p a lt rpls) _ | n == i = Just (PS p' a', UsedOutLink n rmid p a lt rpls)
+    f rp _ = case _rpLinkStatus rp of
+        UsedOutLink {_rplsChildNum = i} | i == n 
+            -> Just (PS p a, rp & rpPlacementUse +~ 1)
+        _   -> Nothing
      where
-        (p',a') = theshift (p,a)
-    f _ _ = Nothing
+        (p,a) = theshift (_rpPos rp,_rpDir rp)

 atFstLnkOutShiftBy :: ((Point2,Float) -> (Point2,Float)) -> PlacementSpot
 atFstLnkOutShiftBy = atNthLnkOutShiftBy 0
@@ -159,25 +185,31 @@ atNthLnkOutShiftInward n x = atNthLnkOutShiftBy n f
  where
    f (p,a) = (p +.+ rotateV a (V2 0 (negate x)),a)

+-- does not change the placement use count
 overFstLnkOut :: PlacementSpot
 overFstLnkOut = PSPos f (const id) Nothing
  where
-    f (UsedOutLink 0 _ p a lt rpls) _ = Just (PS p a, UsedLink p a lt rpls)
-    f _ _ = Nothing
+    f rp _ = case _rpLinkStatus rp of
+        UsedOutLink {_rplsChildNum = 0} -> Just (PS (_rpPos rp) (_rpDir rp), rp)
+        _ -> Nothing

 anyLnkInPS :: Float -- ^ amount to shift inward
    -> PlacementSpot
 anyLnkInPS x = PSPos f (const id) Nothing
  where
-    f (UnusedLink v a _ rpls) _ = Just (PS v' a' ,UsedSpot v' a' S.empty rpls)
+    f rp _ = case _rpLinkStatus rp of
+        UnusedLink {} -> Just (PS v' a', rp & rpPlacementUse +~ 1)
+        _ -> Nothing
      where
-        v' = v -.- x *.* unitVectorAtAngle (a + 0.5 * pi)
+        a = _rpDir rp
+        v' = _rpPos rp -.- x *.* unitVectorAtAngle (a + 0.5 * pi)
        a' = a + pi
-    f _ _ = Nothing

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

 psRandRanges :: (Float,Float) -> (Float,Float) -> (Float,Float) -> State StdGen (Point2,Float)