Unify RoomPos constructors

src/Dodge/Layout.hs

@@ -215,17 +215,23 @@ gameRoomFromRoom rm = GameRoom
         [p +.+ 10 *.* unitVectorAtAngle a
         ,p -.- 10 *.* unitVectorAtAngle a
         ]
-    filterUnusedLinks (UnusedLink p _ _ _) = Just p
+    filterUnusedLinks rp = case _rpLinkStatus rp of
-    filterUnusedLinks _ = Nothing
+        UnusedLink{} -> Just $ _rpPos rp
-    filterUsedLinks (UsedOutLink _ _ p a _ _) = doubleShift p a
+        _ -> Nothing
-    filterUsedLinks (UsedInLink  _ p a _ _) = doubleShift p a
+    filterUsedLinks rp = case _rpLinkStatus rp of
-    filterUsedLinks _ = []
+        UsedOutLink{} -> doubleShift (_rpPos rp) (_rpDir rp)
-    undir (UsedOutLink _ _ _ a _ _) = Just $ 0.5*pi + a + snd (_rmShift rm)
+        UsedInLink{} -> doubleShift (_rpPos rp) (_rpDir rp)
-    undir (UsedInLink  _ _ a _ _) = Just $ 0.5*pi + a + snd (_rmShift rm)
+        _ -> []
-    undir _ = Nothing
+    undir rp = case _rpLinkStatus rp of
+        UsedOutLink{} -> ma
+        UsedInLink{}  -> ma
+        _ -> Nothing
+      where
+        ma = Just $ 0.5*pi + (_rpDir rp) + snd (_rmShift rm)
     closePoints x y = roundPoint2 x == roundPoint2 y
-    getDir (UsedInLink _ _ a _ _:_) = a  + snd (_rmShift rm)
+    getDir (rp:xs) = case _rpLinkStatus rp of
-    getDir (_:xs) = getDir xs
+        UsedInLink {} -> _rpDir rp + snd (_rmShift rm)
+        _ -> getDir xs
     getDir _ = 0 -- fallback
 
 floorsFromRooms :: [Room] -> [(Point3,Point3)]

src/Dodge/LevelGen/Data.hs

@@ -118,58 +118,25 @@ data RoomWire
      WallWire Point2 Float Float
 
 data RPLinkStatus
-    = UsedAsOutLink 
+    = UsedOutLink 
         { _rplsType :: S.Set RoomLinkType 
         , _rplsChildNum :: Int
         , _rplsOutRoomID :: Int
         }
-    | UsedAsInLink  
+    | UsedInLink  
         { _rplsType :: S.Set RoomLinkType 
         , _rplsInRoomID :: Int
         }
-    | UnusedAsLink  { _rplsType :: S.Set RoomLinkType }
+    | UnusedLink  { _rplsType :: S.Set RoomLinkType }
     | NotLink
   deriving (Eq,Ord,Show)
 
-data RoomPos 
+data RoomPos = RoomPos
-    = UsedOutLink 
-        { _rpChildNum  :: Int 
-        , _rpOutRoomID :: Int
-        , _rpPos :: Point2  
-        , _rpDir :: Float
-        , _rpLinkType :: S.Set RoomLinkType
-        , _rpLinkStatus :: RPLinkStatus
-        }
-    | UsedInLink 
-        { _rpInRoomID :: Int 
-        , _rpPos :: Point2 
-        , _rpDir :: Float
-        , _rpLinkType :: S.Set RoomLinkType
-        , _rpLinkStatus :: RPLinkStatus
-        }
-    | UnusedLink
-        { _rpPos :: Point2 
-        , _rpDir ::Float
-        , _rpLinkType :: S.Set RoomLinkType
-        , _rpLinkStatus :: RPLinkStatus
-        }
-    | UsedLink
-        { _rpPos :: Point2 
-        , _rpDir :: Float
-        , _rpLinkType :: S.Set RoomLinkType
-        , _rpLinkStatus :: RPLinkStatus
-        }
-    | UsedSpot
-        { _rpPos :: Point2 
-        , _rpDir :: Float
-        , _rpType :: S.Set RoomPosType
-        , _rpLinkStatus :: RPLinkStatus
-        }
-    | UnusedSpot
     { _rpPos :: Point2 
     , _rpDir :: Float
     , _rpType :: S.Set RoomPosType
     , _rpLinkStatus :: RPLinkStatus
+    , _rpPlacementUse :: Int
     }
   deriving (Eq,Ord,Show)
 

src/Dodge/PlacementSpot.hs

@@ -25,18 +25,21 @@ randDirPS ps = do
 anyUnusedSpot :: PlacementSpot
 anyUnusedSpot = PSPos f (const id) Nothing
   where
-    f rp _ = case rp of
+    f rp _ 
-        UnusedSpot p a t rpls -> Just (PS p a,UsedSpot p a t rpls)
+        | _rpLinkStatus rp == NotLink && _rpPlacementUse rp == 0 
-        _ -> Nothing
+                    = 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
+    f rp r 
-        UnusedSpot p a t rpls
+        | _rpLinkStatus rp == NotLink 
-            | all ( (>x) . dist p ) (usedRoomLinkPoss r)
+            && _rpPlacementUse rp == 0 
-                -> Just (PS p a,UsedSpot p a t rpls)
+            && all ( (>x) . dist p ) (usedRoomLinkPoss r)
-        _       -> Nothing
+                    = 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
+    f rp r 
-        UnusedSpot p a t rpls
+        | _rpLinkStatus rp == NotLink 
-            | all ( (>x) . dist p ) (usedRoomLinkPoss r) && RoomPosOffPath `S.member` t
+            && _rpPlacementUse rp == 0 
-                -> Just (PS p a,UsedSpot p a t rpls)
+            && all ( (>x) . dist p ) (usedRoomLinkPoss r)
-        _       -> Nothing
+            && 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
+    f rp r 
-        UnusedSpot p a t rpls 
+        | _rpLinkStatus rp == NotLink 
-            | all ( (>x) . dist p ) (usedRoomInLinkPoss r) -> Just (PS p a,UsedSpot p a t rpls)
+            && _rpPlacementUse rp == 0 
-        _ -> Nothing
+            && 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
+isUnusedLinkType rlt rp = case _rpLinkStatus rp of
-    UnusedLink{_rpLinkType = rlts} -> rlt `S.member` rlts
+    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
+    f rp r 
-        UnusedSpot p a t rpls 
+        | _rpLinkStatus rp == NotLink 
-            | any ( (<x) . dist p ) (usedRoomInLinkPoss r) -> Just (PS p a,UsedSpot p a t rpls)
+            && _rpPlacementUse rp == 0 
-        _ -> Nothing
+            && 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 rp _ = case _rpLinkStatus rp of
-    f _ _ = Nothing
+        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 rp _ = case _rpLinkStatus rp of
-    f _                     _ = Nothing
+        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)
+        (p,a) = theshift (_rpPos rp,_rpDir rp)
-    f _ _ = Nothing
 
 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 rp _ = case _rpLinkStatus rp of
-    f _ _ = Nothing
+        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
+useLnkRoomPos rp _ = case _rpLinkStatus rp of
-    (UnusedLink (V2 x y) a lt rpls) -> Just (PS (V2 x y) a , UsedLink (V2 x y) a lt rpls)
+    UnusedLink {} -> Just (PS (_rpPos rp) (_rpDir rp) , rp & rpPlacementUse +~ 1)
     _ -> Nothing
 
 psRandRanges :: (Float,Float) -> (Float,Float) -> (Float,Float) -> State StdGen (Point2,Float)

src/Dodge/Room/LongDoor.hs

@@ -132,9 +132,7 @@ addButtonSlowDoor x h rm = do
         $ Nothing
     getdoorpos drid w = let Just (a,b) = w ^? doors . ix drid . drPos
         in (b, argV (a-.-b))
-    butPosCond (UnusedLink (V2 x' y') a' _ rpls) _ | y' < 0.5 * h 
+    butPosCond = useRoomPosCond $ \rp -> isUnusedLnk rp && yV2 (_rpPos rp) < 0.5 * h 
-                = Just (PS (V2 x' y') a' , UsedSpot (V2 x' y') a' (S.singleton RoomPosExLink) rpls)
-    butPosCond _ _ = Nothing
     --butPosCond _ = True -- y < h
     col = dim $ light red
     cond' btid w = w ^? buttons . ix btid . btState /= Just BtOff

src/Dodge/Room/Procedural.hs

@@ -53,8 +53,8 @@ roomRect x y xn yn = defaultRoom
     { _rmPolys = [rectNSWE  y 0 0 x ]
     , _rmLinks = lnks
     , _rmPath  = concatMap doublePair pth
-    , _rmPos   = map (\pd -> UnusedSpot pd 0 (S.singleton RoomPosOnPath) NotLink) posps
+    , _rmPos   = map (roomposat RoomPosOnPath) posps
-        ++ map (\pd -> UnusedSpot pd 0 (S.singleton RoomPosOffPath) NotLink) interposps
+        ++ map (roomposat RoomPosOffPath) interposps
     , _rmPmnts    = []
     , _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)]
     , _rmFloor = Tiled [Tile 
@@ -66,6 +66,7 @@ roomRect x y xn yn = defaultRoom
     , _rmRandPSs = [psRandRanges (10,x-10) (10,y-10) (0,2*pi)]
     }
   where 
+    roomposat onoffpath p = RoomPos p 0 (S.singleton onoffpath) NotLink 0
     yd = (y - 40) / fromIntegral yn
     xd = (x - 40) / fromIntegral xn
     somelnks poffset ps a = zip (map (+.+ poffset) ps) (repeat a)
@@ -147,8 +148,8 @@ quarterRoomTri w = do
             , sPS (V2 (w-15) (w-25)) pi PutNothing 
             ]
         , _rmPos = 
-            [ UnusedSpot (V2 (w-20) (w-20)) pi S.empty NotLink
+            [ RoomPos (V2 (w-20) (w-20)) pi S.empty NotLink 0
-            , UnusedSpot (V2 (w-15) (w-25)) pi S.empty NotLink
+            , RoomPos (V2 (w-15) (w-25)) pi S.empty NotLink 0
             ]
         , _rmBound  = [[V2 0 0,V2 w w,V2 (-w) w]]
         }
@@ -188,8 +189,9 @@ quarterRoomSquare w = do
             , sPS (V2 20 (2*w-40)) pi PutNothing
             , sPS (V2 25 (2*w-45)) pi PutNothing
             ]
-        , _rmPos = [UnusedSpot (V2 20 (2*w-40)) pi S.empty NotLink
+        , _rmPos = 
-                , UnusedSpot (V2 25 (2*w-45)) pi S.empty NotLink
+                [ RoomPos (V2 20 (2*w-40)) pi S.empty NotLink 0
+                , RoomPos (V2 25 (2*w-45)) pi S.empty NotLink 0
                 ]
         , _rmBound = [map toV2 [(w,w),(0,2*w),(-w,w)]]
         }

src/Dodge/Room/Room.hs

@@ -24,7 +24,7 @@ import Tile
 import MonadHelp
 import LensHelp
 
-import qualified Data.Set as S
+--import qualified Data.Set as S
 import Control.Monad.State
 --import Control.Monad.Loops
 import System.Random
@@ -83,13 +83,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 _ rpls) _ 
-            | cond y = Just (PS (V2 x y) a , UsedSpot (V2 x y) a (S.singleton RoomPosExLink) rpls)
-        con1 _ _ _ = Nothing
         plmnts = 
-            [ mntLightLnkCond $ con1 (< 0.5 * hgt)
+            [ windowLine (V2 (wth-60   )    hf ) (V2 wllen  hf   )
-            , mntLightLnkCond $ con1 (> 0.5 * hgt)
-            ,windowLine (V2 (wth-60   )    hf ) (V2 wllen  hf   )
             ,windowLine (V2 (wth-wllen) (2*hf)) (V2 60    (2*hf))
             ,windowLine (V2 (wth-60   ) (3*hf)) (V2 wllen (3*hf))
             ,windowLine (V2 (wth-wllen) (4*hf)) (V2 60    (4*hf))

src/Dodge/Tree/Shift.hs

@@ -14,7 +14,7 @@ import Padding
 import LensHelp hiding (Empty, (<|) , (|>))
 --import Control.Lens hiding (Empty, (<|) , (|>))
 
---import qualified Data.Set as S
+import qualified Data.Set as S
 import Data.Tree
 import Data.Sequence hiding (zipWith)
 import Data.List (delete)
@@ -67,13 +67,12 @@ posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
             clipping = or (convexPolysOverlap <$> newBounds <*> bounds)
             updateparent rm = doLnkEff (lnkPosDir outlnk) $ rm 
                 & rmLinks    %~ delete outlnk 
-                & rmPos      .:~ UsedOutLink
+                & rmPos      .:~ RoomPos
-                    { _rpChildNum = numChild 
+                    { _rpPos = fst (lnkPosDir outlnk)
-                    , _rpOutRoomID = snd childi
-                    , _rpPos = fst (lnkPosDir outlnk)
                     , _rpDir = snd (lnkPosDir outlnk)
-                    , _rpLinkType = _rlType outlnk
+                    , _rpType = S.empty
-                    , _rpLinkStatus = UsedAsOutLink (_rlType outlnk) numChild (snd childi)
+                    , _rpLinkStatus = UsedOutLink (_rlType outlnk) numChild (snd childi)
+                    , _rpPlacementUse = 0
                     }
                 & rmChildren .:~ snd childi
             shiftedoutlink = shiftLinkBy (_rmShift parent) outlnk
@@ -81,12 +80,12 @@ posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
                 & rmMParent ?~ snd parenti
                 & rmMID     ?~ snd childi
                 & rmLinks   %~ delete il 
-                & rmPos     .:~ UsedInLink 
+                & rmPos     .:~ RoomPos 
-                    { _rpInRoomID = 0
+                    { _rpPos = fst (lnkPosDir il)
-                    , _rpPos = fst (lnkPosDir il)
                     , _rpDir = snd (lnkPosDir il)
-                    , _rpLinkType = _rlType il
+                    , _rpType = S.empty
-                    , _rpLinkStatus = UsedAsInLink (_rlType il) 0
+                    , _rpLinkStatus = UsedInLink (_rlType il) (snd parenti)
+                    , _rpPlacementUse = 0
                     }
             shiftedt = applyToRoot
                 (first $ updatechild . shiftRoomShiftToLink (lnkPosDir shiftedoutlink) (lnkPosDir il)) 
@@ -95,11 +94,12 @@ posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
 createUnusedLinkPos :: Room -> Room
 createUnusedLinkPos rm = rm & rmPos .++~ map f (_rmLinks rm)
   where
-    f rl = UnusedLink
+    f rl = RoomPos
         { _rpPos = _rlPos rl
         , _rpDir = _rlDir rl
-        , _rpLinkType = _rlType rl
+        , _rpType = S.empty
-        , _rpLinkStatus = UnusedAsLink $ _rlType rl
+        , _rpLinkStatus = UnusedLink $ _rlType rl
+        , _rpPlacementUse = 0
         }
 
 zipCount :: [a] -> [(Int,a)]

src/Geometry/Vector.hs

@@ -153,3 +153,11 @@ tweenAngles frac a1 a2
         | abs (a1' - a2') < pi = frac' * (a1' - a2') + a2'
         | a1' > a2'   = go frac' (a1' - 2*pi) a2'
         | otherwise = go frac' a1' (a2' - 2*pi)
+
+xV2 :: Point2 -> Float
+{-# INLINE xV2 #-}
+xV2 (V2 x _) = x
+
+yV2 :: Point2 -> Float
+{-# INLINE yV2 #-}
+yV2 (V2 _ y) = y