Add rooms, placements and room positions

2022-03-08 22:57:58 +00:00
parent 2e1c7f2687
commit ff6064a3b6
14 changed files with 315 additions and 138 deletions
@@ -2,16 +2,18 @@ module Dodge.PlacementSpot where
 import Dodge.LevelGen.Data
 import Geometry

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

 setDirPS :: Float -> PlacementSpot -> PlacementSpot
 setDirPS a ps = case ps of
    PS p _ -> PS p a
    PSNoShiftCont p _ -> PS p a
-    PSPos f re fb -> PSPos (\rp r -> fmap (first (setDirPS a)) (f rp r)) re fb
+    PSPos f rmeff fb -> PSPos (\rp r -> fmap (first (setDirPS a)) (f rp r)) rmeff fb
    PSRoomRand i f -> PSRoomRand i (fmap (setDirPS a) f)

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

+anyUnusedSpot :: PlacementSpot
+anyUnusedSpot = PSPos f (const id) Nothing
+  where
+    f rp _ = case rp of
+        UnusedSpot p a t -> Just (PS p a,UsedSpot p a t)
+        _ -> Nothing
+
+unusedSpotAwayFromLink :: Float -> PlacementSpot
+unusedSpotAwayFromLink x = PSPos f (const id) Nothing
+  where
+    f rp r = case rp of
+        UnusedSpot p a t
+            | all ( (>x) . dist p ) (usedRoomLinkPoss r)
+                -> Just (PS p a,UsedSpot p a t)
+        _       -> Nothing
+
+unusedOffPathAwayFromLink :: Float -> PlacementSpot
+unusedOffPathAwayFromLink x = PSPos f (const id) Nothing
+  where
+    f rp r = case rp of
+        UnusedSpot p a t
+            | all ( (>x) . dist p ) (usedRoomLinkPoss r) && RoomPosOffPath `S.member` t
+                -> Just (PS p a,UsedSpot p a t)
+        _       -> Nothing
+
 unusedSpotAwayFromInLink :: Float -> PlacementSpot
 unusedSpotAwayFromInLink x = PSPos f (const id) Nothing
  where
    f rp r = case rp of
-        UnusedSpot p a | all ( (>x) . dist p ) inlinkposs -> Just (PS p a,UsedSpot p a)
+        UnusedSpot p a t | all ( (>x) . dist p ) (usedRoomInLinkPoss r) -> Just (PS p a,UsedSpot p a t)
        _ -> Nothing
-      where
-        inlinkposs = usedRoomInLinkPoss r
+
+twoUnusedLinks :: (PlacementSpot -> PlacementSpot -> Placement)
+    -> Placement
+twoUnusedLinks f = Placement useUnusedLink PutNothing Nothing
+    $ \pl1 -> Just $ Placement useUnusedLink PutNothing Nothing
+    $ \pl2 -> Just $ f (_plSpot pl1) (_plSpot pl2)
+
+twoRoomPoss :: (RoomPos -> Bool)
+    -> (RoomPos -> Bool)
+    -> (PlacementSpot -> PlacementSpot -> Placement)
+    -> Placement
+twoRoomPoss cond1 cond2 f = Placement (useRoomPos cond1) PutNothing Nothing
+    $ \pl1 -> Just $ Placement (useRoomPos cond2) PutNothing Nothing
+    $ \pl2 -> Just $ f (_plSpot pl1) (_plSpot pl2)
+
+useUnusedLink :: PlacementSpot
+useUnusedLink = PSPos unusedLnkToPS (const id) Nothing
+
+useRoomPos :: (RoomPos -> Bool) -> PlacementSpot
+useRoomPos cond = PSPos (useRoomPosCond cond) (const id) Nothing
+
+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))
+    | otherwise = Nothing
+  where
+    p = _rpPos rp
+    a = _rpDir rp
+
+unusedLnkToPS :: RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)
+unusedLnkToPS = useRoomPosCond $ \rp -> case rp of
+    UnusedLink {} -> True
+    _ -> False
+
+isUnusedLinkType :: RoomLinkType -> RoomPos -> Bool
+isUnusedLinkType rlt rp = case rp of
+    UnusedLink{_rpLinkType = rlts} -> rlt `S.member` rlts
+    _ -> False

 unusedSpotNearInLink :: Float -> PlacementSpot
 unusedSpotNearInLink x = PSPos f (const id) Nothing
  where
    f rp r = case rp of
-        UnusedSpot p a | any ( (<x) . dist p ) inlinkposs -> Just (PS p a,UsedSpot p a)
+        UnusedSpot p a t | any ( (<x) . dist p ) (usedRoomInLinkPoss r) -> Just (PS p a,UsedSpot p a t)
        _ -> Nothing
-      where
-        inlinkposs = usedRoomInLinkPoss r

 usedRoomInLinkPoss :: Room -> [Point2]
 usedRoomInLinkPoss r = mapMaybe f $ _rmPos r
@@ -44,23 +106,31 @@ usedRoomInLinkPoss r = mapMaybe f $ _rmPos r
        UsedInLink {} -> Just $ _rpPos rp
        _ -> Nothing

+usedRoomLinkPoss :: Room -> [Point2]
+usedRoomLinkPoss r = mapMaybe f $ _rmPos r
+  where
+    f rp = case rp of
+        UsedInLink {} -> Just $ _rpPos rp
+        UsedOutLink {} -> Just $ _rpPos rp
+        _ -> Nothing
+
 -- TODO rename to any unused link facing out
 anyLnkOutPS :: PlacementSpot
 anyLnkOutPS = PSPos f (const id) Nothing
  where
-    f (UnusedLink p a) _ = Just (PS p a, UsedSpot p a)
+    f (UnusedLink p a _) _ = Just (PS p a, UsedSpot p a S.empty)
    f _ _ = Nothing
    
 atFstLnkOut :: PlacementSpot
 atFstLnkOut = PSPos f (const id) Nothing
  where
-    f (UsedOutLink 0 i p a) _ = Just (PS p a, UsedOutLink 0 i p a)
+    f (UsedOutLink 0 i p a lt) _ = Just (PS p a, UsedOutLink 0 i p a lt)
    f _                     _ = Nothing

 atNthLnkOutShiftBy :: Int -> ((Point2,Float) -> (Point2,Float)) -> PlacementSpot
 atNthLnkOutShiftBy n theshift = PSPos f (const id) Nothing
  where
-    f (UsedOutLink i rmid p a) _ | n == i = Just (PS p' a', UsedOutLink n rmid p a)
+    f (UsedOutLink i rmid p a lt) _ | n == i = Just (PS p' a', UsedOutLink n rmid p a lt)
      where
        (p',a') = theshift (p,a)
    f _ _ = Nothing
@@ -79,14 +149,14 @@ atNthLnkOutShiftInward n x = atNthLnkOutShiftBy n f
 overFstLnkOut :: PlacementSpot
 overFstLnkOut = PSPos f (const id) Nothing
  where
-    f (UsedOutLink 0 _ p a) _ = Just (PS p a, UsedSpot p a)
+    f (UsedOutLink 0 _ p a lt) _ = Just (PS p a, UsedLink p a lt)
    f _ _ = Nothing

 anyLnkInPS :: Float -- ^ amount to shift inward
    -> PlacementSpot
 anyLnkInPS x = PSPos f (const id) Nothing
  where
-    f (UnusedLink v a) _ = Just (PS v' a' ,UsedSpot v' a')
+    f (UnusedLink v a _) _ = Just (PS v' a' ,UsedSpot v' a' S.empty)
      where
        v' = v -.- x *.* unitVectorAtAngle (a + 0.5 * pi)
        a' = a + pi
@@ -94,7 +164,7 @@ anyLnkInPS x = PSPos f (const id) Nothing

 useLnkRoomPos :: RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)
 useLnkRoomPos rp _ = case rp of
-    (UnusedLink (V2 x y) a) -> Just (PS (V2 x y) a , UsedSpot (V2 x y) a)
+    (UnusedLink (V2 x y) a lt) -> Just (PS (V2 x y) a , UsedLink (V2 x y) a lt)
    _ -> Nothing

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