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

import Dodge.Base.CardinalPoint
import Control.Lens
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

isMidEdgeLink :: Room -> CardinalPoint -> RoomLink -> Bool
isMidEdgeLink r x rl
    | x == North || x == South = g West (f $ r ^?! rmType . numLinkEW)
        && OnEdge x `S.member` (rl ^. rlType)
    | otherwise = g South (f $ r ^?! rmType . numLinkNS)
        && OnEdge x `S.member` (rl ^. rlType)
  where
    f y | even y = [y `div` 2]
        | otherwise = [y `div` 2, 1 + (y `div` 2)]
    g a = any (\y -> FromEdge a y `S.member` (rl ^. rlType))

isCornerLink :: CardinalPointBetween -> RoomLink -> Bool
isCornerLink x rl = (OnEdge a `S.member` xs && FromEdge b 0 `S.member` xs)
    || (OnEdge b `S.member` xs && FromEdge a 0 `S.member` xs)
  where
    xs = rl ^. rlType
    (a,b) = cardinalBetweenAdj x

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) -> [RoomLink] -> [RoomLink]
overLnkType lt f = each %~ g
  where
    g lnk | lt `S.member` _rlType lnk = f lnk
        | otherwise = lnk

rlPosDir :: RoomLink -> (Point2, Float)
rlPosDir 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