loop/src/Dodge/PlacementSpot.hs

--{-# LANGUAGE LambdaCase #-}
module Dodge.PlacementSpot 
    ( atFstLnkOut
    , useUnusedLnk
    , psRandRanges
    , useRoomPosCond
    , isUsedLnkUnplaced
    , anyUnusedSpot
    , unusedSpotAwayFromLink
    , isUnusedLnk
    , isInLnk
    , unusedSpotNearInLink
    , randDirPS
    , unusedSpotAwayFromInLink
    , useLnkRoomPos
    , atFstLnkOutShiftInward
    , atFstLnkOutShiftBy
    , atNthLnkOutShiftInward
    , unusedOffPathAwayFromLink
    , setFallback
    , twoRoomPoss
    , isUnusedLnkType
    , rprBoolShift 
    , rprShift
    , rprBool
    , shiftInBy
    , resetPLUse
    , psposAddLabel
    , shiftByV2
    , usedRoomLinkPoss
    , usedRoomInLinkPoss
    ) where
--import Dodge.LevelGen.Data
import Dodge.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 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

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 -> _rpLinkStatus rp == NotLink 
    && _rpPlacementUse rp == 0 
    && all ( (>x) . dist (_rpPos rp) ) (usedRoomLinkPoss r)
    && RoomPosOffPath `S.member` _rpType 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

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 = rprBool $ \rp _ -> rp ^? rpLinkStatus . rplsChildNum == Just 0

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)