--{-# 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)