loop/src/Dodge/PlacementSpot.hs

--{-# 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 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 _rpLinkStatus rp of
    UnusedLink{} -> _rpPlacementUse rp == 0
    _ -> False

anyUnusedSpot :: PlacementSpot
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)

rprBool :: (RoomPos -> Room -> Bool) -> PlacementSpot
rprBool t = PSPos (useRoomPosRoomCond t) (const id) Nothing

rpIsOnPath :: RoomPos -> Bool
rpIsOnPath = any f . _rpType
  where
    f RoomPosOnPath{} = True
    f _ = False

rpIsOffPath :: RoomPos -> Bool
rpIsOffPath = any f . _rpType
  where
    f RoomPosOffPath{} = True
    f _ = False

rpOffPathFromEdge :: PathFromEdge -> RoomPos -> Bool
rpOffPathFromEdge pe = any f . _rpType
  where
    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)

resetPLUse :: PlacementSpot -> PlacementSpot
resetPLUse (PSPos f g fallback) = PSPos f' g fallback
  where
    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 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

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)
        | otherwise = Nothing
      where
        (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)

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 ->
    _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)

--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 $
    \_ pl1 -> Just $
        Placement (rprBool cond2) PutNothing 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 _rpLinkStatus rp of
    UsedInLink{} -> _rpPlacementUse rp == 0
    _ -> False

isOutLnk :: RoomPos -> Bool
isOutLnk rp = case _rpLinkStatus rp of
    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
    _ -> False

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 t rp r
    | t rp r = Just (PS (_rpPos rp) (_rpDir rp), rp & rpPlacementUse +~ 1)
    | otherwise = Nothing

isUnusedLnkType :: RoomLinkType -> RoomPos -> Room -> Bool
isUnusedLnkType rlt rp _ = case _rpLinkStatus rp of
    UnusedLink{_rplsType = rlts} -> rlt `S.member` rlts && _rpPlacementUse rp == 0
    _ -> False

unusedSpotNearInLink :: Float -> PlacementSpot
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
        _ -> 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
        _ -> Nothing

atFstLnkOut :: PlacementSpot
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 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)) -> 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)

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 :: RoomPos -> Room -> Maybe (PlacementSpot, RoomPos)
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)
psRandRanges xranges yranges aranges = do
    x <- state $ randomR xranges
    y <- state $ randomR yranges
    a <- state $ randomR aranges
    return (V2 x y, a)