module Dodge.RoomLink (
    muout,
    muin,
    outLink,
    inLink,
    restrictLinkType,
    overLnkType,
    lnkPosDir,
    overLnkPosDir,
    toBothLnk,
    rmInLinks,
    rmOutLinks,
    setOutLinksPD,
    setOutLinksByType,
    setInLinksPD,
    restrictOutLinks,
    restrictInLinks,
    setOutLinks,
    setInLinks,
    setInLinksByType,
    setLinkType,
    getLinksOfType,
    swapInOutLinks,
) where

import Control.Lens
import Data.List (partition)
import qualified Data.Set as S
import Dodge.Data.GenWorld
import Geometry

restrictLinkType :: RoomLinkType -> ((Point2, Float) -> Bool) -> [RoomLink] -> [RoomLink]
restrictLinkType rlt f = map g
  where
    g rl
        | f $ rlPosDir rl = rl
        | otherwise = rl & rlType %~ S.delete rlt

getLinksOfType :: RoomLinkType -> [RoomLink] -> [RoomLink]
getLinksOfType lt = filter (S.member lt . _rlType)

restrictInLinks :: ((Point2, Float) -> Bool) -> Room -> Room
restrictInLinks = over rmLinks . restrictLinkType InLink

restrictOutLinks :: ((Point2, Float) -> Bool) -> Room -> Room
restrictOutLinks f = rmLinks %~ restrictLinkType OutLink f

setOutLinks :: (RoomLink -> Bool) -> [RoomLink] -> [RoomLink]
setOutLinks = setLinkType OutLink

setInLinks :: (RoomLink -> Bool) -> [RoomLink] -> [RoomLink]
setInLinks = setLinkType InLink

setInLinksByType :: RoomLinkType -> [RoomLink] -> [RoomLink]
setInLinksByType lt = setInLinks (\rl -> lt `S.member` _rlType rl)

setOutLinksByType :: RoomLinkType -> [RoomLink] -> [RoomLink]
setOutLinksByType lt = setOutLinks (\rl -> lt `S.member` _rlType rl)

setLinkType :: RoomLinkType -> (RoomLink -> Bool) -> [RoomLink] -> [RoomLink]
setLinkType rlt f = map g
  where
    g rl
        | f rl = rl & rlType %~ S.insert rlt
        | otherwise = rl & rlType %~ S.delete rlt

setLinkTypePD :: RoomLinkType -> ((Point2, Float) -> Bool) -> [RoomLink] -> [RoomLink]
setLinkTypePD rlt f = map g
  where
    g rl
        | f $ rlPosDir rl = rl & rlType %~ S.insert rlt
        | otherwise = rl & rlType %~ S.delete rlt

setInLinksPD :: ((Point2, Float) -> Bool) -> Room -> Room
setInLinksPD f = rmLinks %~ setLinkTypePD InLink f

setOutLinksPD :: ((Point2, Float) -> Bool) -> Room -> Room
setOutLinksPD f = rmLinks %~ setLinkTypePD OutLink f

swapInOutLinks :: Room -> Room
swapInOutLinks = rmLinks %~ map (rlType %~ S.map f)
  where
    f InLink = OutLink
    f OutLink = InLink
    f x = x

overLnkType :: RoomLinkType -> ([RoomLink] -> [RoomLink]) -> Room -> Room
overLnkType lt f = rmLinks %~ g
  where
    g lnks =
        let (xs, ys) = partition (S.member lt . _rlType) lnks
         in f xs ++ ys

rlPosDir :: RoomLink -> (Point2, Float)
rlPosDir rl = (_rlPos rl, _rlDir rl)

lnkPosDir :: RoomLink -> (Point2, Float)
lnkPosDir rl = (_rlPos rl, _rlDir rl)

overLnkPosDir :: ((Point2, Float) -> (Point2, Float)) -> RoomLink -> RoomLink
overLnkPosDir f rl = rl & rlPos .~ p & rlDir .~ a
  where
    (p, a) = f (_rlPos rl, _rlDir rl)

outLink :: Point2 -> Float -> RoomLink
outLink p a =
    RoomLink
        { _rlType = S.singleton OutLink
        , _rlPos = p
        , _rlDir = a
        }

inLink :: Point2 -> Float -> RoomLink
inLink p a =
    RoomLink
        { _rlType = S.singleton InLink
        , _rlPos = p
        , _rlDir = a
        }

toBothLnk :: (Point2, Float) -> RoomLink
toBothLnk (p, a) =
    RoomLink
        { _rlType = S.fromList [OutLink, InLink]
        , _rlPos = p
        , _rlDir = a
        }

muout :: [(Point2, Float)] -> [RoomLink]
muout = map (uncurry outLink)

muin :: [(Point2, Float)] -> [RoomLink]
muin = map (uncurry inLink)

rmLinksOfType :: RoomLinkType -> Room -> [RoomLink]
rmLinksOfType lt = filter (S.member lt . _rlType) . _rmLinks

rmOutLinks, rmInLinks :: Room -> [RoomLink]
rmOutLinks = rmLinksOfType OutLink
rmInLinks = rmLinksOfType InLink