266 lines
8.2 KiB
Haskell
266 lines
8.2 KiB
Haskell
--{-# LANGUAGE LambdaCase #-}
|
|
module Dodge.PlacementSpot (
|
|
atFstLnkOut,
|
|
atNthLnkOutShiftBy,
|
|
rpIsOnGrid,
|
|
rpIsOffGrid,
|
|
rpOffPathFromEdge,
|
|
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 Control.Monad.State
|
|
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
|
|
PS p _ -> PS p a
|
|
PSNoShiftCont p _ -> PS p a
|
|
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
|
|
randDirPS ps = do
|
|
a <- state $ randomR (0, pi * 2)
|
|
return $ setDirPS a ps
|
|
|
|
isUnusedLnk :: RoomPos -> Room -> Bool
|
|
isUnusedLnk rp _ = case _rpType rp of
|
|
UnusedLink{} -> null $ _rpPlacementUse rp
|
|
_ -> False
|
|
|
|
anyUnusedSpot :: PlacementSpot
|
|
anyUnusedSpot = rprBool $ \rp _ -> notLink (_rpType rp) && null (_rpPlacementUse rp)
|
|
|
|
psposAddLabel :: RoomPosFlag -> PlacementSpot -> PlacementSpot
|
|
psposAddLabel lab = psSelect %~ (\f rp r -> f rp r & _Just . _2 . rpFlags %~ S.insert lab)
|
|
|
|
rprBool :: (RoomPos -> Room -> Bool) -> PlacementSpot
|
|
rprBool t = PSPos (useRoomPosRoomCond (S.singleton UsedPosLow) t) (const id) Nothing
|
|
|
|
rpIsOnGrid :: RoomPos -> Bool
|
|
rpIsOnGrid = any f . _rpFlags
|
|
where
|
|
f RoomPosOnGrid{} = True
|
|
f _ = False
|
|
|
|
rpIsOffGrid :: RoomPos -> Bool
|
|
rpIsOffGrid = any f . _rpFlags
|
|
where
|
|
f RoomPosOffGrid{} = True
|
|
f _ = False
|
|
|
|
rpOffPathFromEdge :: PathFromEdge -> RoomPos -> Bool
|
|
rpOffPathFromEdge pe = any f . _rpFlags
|
|
where
|
|
f rt = maybe False (pe `elem`) (rt ^? offGridFromEdges)
|
|
|
|
resetPLUse :: PlacementSpot -> PlacementSpot
|
|
resetPLUse (PSPos f g fallback) = PSPos f' g fallback
|
|
where
|
|
f' rp = fmap (second (rpPlacementUse .~ mempty)) . f rp
|
|
resetPLUse _ = error "Tried to reset _rpPlacementUse of non PSPos placement"
|
|
|
|
rprShift ::
|
|
(RoomPos -> Room -> Maybe ((Point2, Float), S.Set UsedPos)) ->
|
|
PlacementSpot
|
|
rprShift t = PSPos f (const id) Nothing
|
|
where
|
|
f rp r = case t rp r of
|
|
Just ((p, a), xs) -> Just (PS p a, rp & rpPlacementUse <>~ xs)
|
|
Nothing -> Nothing
|
|
|
|
rprBoolShift ::
|
|
(RoomPos -> Room -> Bool) ->
|
|
((Point2, Float) -> ((Point2, Float), S.Set UsedPos)) ->
|
|
PlacementSpot
|
|
rprBoolShift t shift = PSPos f (const id) Nothing
|
|
where
|
|
f rp r
|
|
| t rp r = Just (PS p a, rp & rpPlacementUse <>~ xs)
|
|
| otherwise = Nothing
|
|
where
|
|
((p, a), xs) = shift (_rpPos rp, _rpDir rp)
|
|
|
|
unusedSpotAwayFromLink :: Float -> PlacementSpot
|
|
unusedSpotAwayFromLink x = rprBool $ \rp r ->
|
|
notLink (_rpType rp)
|
|
&& null (_rpPlacementUse rp)
|
|
&& 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))
|
|
)
|
|
|
|
unusedOffPathAwayFromLink :: Float -> PlacementSpot
|
|
unusedOffPathAwayFromLink x = rprBool $ \rp r ->
|
|
null (_rpPlacementUse rp)
|
|
&& all ((> x) . dist (_rpPos rp)) (usedRoomLinkPoss r)
|
|
&& rpIsOffGrid rp
|
|
|
|
unusedSpotAwayFromInLink :: Float -> PlacementSpot
|
|
unusedSpotAwayFromInLink x = rprBool $ \rp r ->
|
|
notLink (_rpType rp)
|
|
&& null (_rpPlacementUse rp)
|
|
&& 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 (rprBool cond1) PutNothing Nothing Nothing $
|
|
\_ pl1 -> Just $
|
|
Placement (rprBool cond2) PutNothing Nothing Nothing $
|
|
\_ pl2 -> Just $ f (_plSpot pl1) (_plSpot pl2)
|
|
|
|
--isUnusedLnk :: RoomPos -> Bool
|
|
--isUnusedLnk rp = case _rpLinkStatus rp of
|
|
-- UnusedLink {} -> _rpPlacementUse rp == 0
|
|
-- _ -> False
|
|
|
|
isInLnk :: RoomPos -> Bool
|
|
isInLnk rp = case _rpType rp of
|
|
UsedInLink{} -> null $ _rpPlacementUse rp
|
|
_ -> False
|
|
|
|
isOutLnk :: RoomPos -> Bool
|
|
isOutLnk rp = case _rpType rp of
|
|
UsedOutLink{} -> null $ _rpPlacementUse rp
|
|
_ -> False
|
|
|
|
useUnusedLnk :: PlacementSpot
|
|
useUnusedLnk = rprBool isUnusedLnk
|
|
|
|
isUsedLnkUnplaced :: RoomPos -> Bool
|
|
isUsedLnkUnplaced rp = case _rpType rp of
|
|
UsedOutLink{} -> null (_rpPlacementUse rp)
|
|
UsedInLink{} -> null (_rpPlacementUse rp)
|
|
_ -> False
|
|
|
|
useRoomPosCond :: (RoomPos -> Room -> Bool) -> RoomPos -> Room -> Maybe (PlacementSpot, RoomPos)
|
|
useRoomPosCond f = useRoomPosRoomCond (S.singleton UsedPosLow) $ \rp r -> f rp r
|
|
|
|
useRoomPosRoomCond :: S.Set UsedPos
|
|
-> (RoomPos -> Room -> Bool) -> RoomPos -> Room
|
|
-> Maybe (PlacementSpot, RoomPos)
|
|
useRoomPosRoomCond xs t rp r
|
|
| t rp r = Just (PS (_rpPos rp) (_rpDir rp), rp & rpPlacementUse <>~ xs)
|
|
| otherwise = Nothing
|
|
|
|
isUnusedLnkType :: RoomLinkType -> RoomPos -> Room -> Bool
|
|
isUnusedLnkType rlt rp _ = case _rpType rp of
|
|
UnusedLink{_rplsType = rlts} -> rlt `S.member` rlts
|
|
&& null (_rpPlacementUse rp)
|
|
_ -> False
|
|
|
|
unusedSpotNearInLink :: Float -> PlacementSpot
|
|
unusedSpotNearInLink x = rprBool $ \rp r ->
|
|
notLink (_rpType rp)
|
|
&& null (_rpPlacementUse rp)
|
|
&& any ((< x) . dist (_rpPos rp)) (usedRoomInLinkPoss r)
|
|
|
|
usedRoomInLinkPoss :: Room -> [Point2]
|
|
usedRoomInLinkPoss r = mapMaybe f $ _rmPos r
|
|
where
|
|
f rp = case _rpType rp of
|
|
UsedInLink{} -> Just $ _rpPos rp
|
|
_ -> Nothing
|
|
|
|
usedRoomLinkPoss :: Room -> [Point2]
|
|
usedRoomLinkPoss r = mapMaybe f $ _rmPos r
|
|
where
|
|
f rp = case _rpType rp of
|
|
UsedInLink{} -> Just $ _rpPos rp
|
|
UsedOutLink{} -> Just $ _rpPos rp
|
|
_ -> Nothing
|
|
|
|
atFstLnkOut :: PlacementSpot
|
|
atFstLnkOut = atNthLinkOut 0
|
|
|
|
atNthLinkOut :: Int -> PlacementSpot
|
|
atNthLinkOut n = rprBool $ \rp _ -> rp ^? rpType . rplsChildNum == Just n
|
|
|
|
atNthLnkOutShiftBy :: Int -> ((Point2, Float) -> ((Point2, Float),S.Set UsedPos))
|
|
-> PlacementSpot
|
|
atNthLnkOutShiftBy n = rprBoolShift $
|
|
\rp _ -> rp ^? rpType . rplsChildNum == Just n
|
|
|
|
--atNthLnkOutShiftBy n theshift = PSPos f (const id) Nothing
|
|
-- where
|
|
-- f rp _ = case _rpLinkStatus rp of
|
|
-- 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), S.Set UsedPos)) -> 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), S.singleton UsedPosLow)
|
|
|
|
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)
|
|
|
|
-- this should probably check the placement use, but so should others: should
|
|
-- unify these
|
|
useLnkRoomPos :: S.Set UsedPos -> RoomPos -> Room -> Maybe (PlacementSpot, RoomPos)
|
|
useLnkRoomPos xs rp _ = case _rpType rp of
|
|
UnusedLink{} -> Just (PS (_rpPos rp) (_rpDir rp), rp & rpPlacementUse <>~ xs)
|
|
_ -> Nothing
|
|
|
|
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)
|