--{-# LANGUAGE BangPatterns #-}
module Dodge.Placement.PlaceSpot.TriggerDoor
    ( plDoor
    , plSlideDoor
    ) where
import Dodge.Data
import Dodge.Zone
import Dodge.Base
import Dodge.Path
import Dodge.Default.Door
import Dodge.Wall.Move
import Dodge.LevelGen.DoorPane
import Picture
import Geometry
import qualified IntMapHelp as IM
import Dodge.SoundLogic
import LensHelp
--import Dodge.LevelGen.LevelStructure

--import Data.Maybe
import Data.List
import qualified Data.IntSet as IS
import qualified Data.Graph.Inductive as FGL
import qualified Streaming.Prelude as S
plDoor :: Color
    -> EdgeObstacle
    -> (World -> Bool)      -- ^ Opening condition
    -> [(Point2,Point2)]   -- ^ Door positions, closed to open.
                    -- Bumped out up and down by 9, not widened
    -> World
    -> (Int,World)
plDoor col eo cond pss gw = (drid, addWalls $ gw & doors %~ addDoor) -- carefull with the ordering of addWalls
  where
    drid = IM.newKey $ _doors gw
    addDoor = IM.insert drid $ defaultDoor
        { _drID = drid
        , _drWallIDs = IS.fromList wlids
        , _drStatus = DoorInt 0
        , _drTrigger = cond
        , _drMech   = doorMechanismStepwise nsteps drid wlids pss
        , _drPos = head pss
        , _drOpenPos = head pss
        , _drClosePos = last pss
        , _drObstacleType = eo
        }
    nsteps = length pss - 1
    wlids = take 4 [IM.newKey $ _walls gw ..]
    wlps' = uncurry (rectanglePairs 9) $ head pss
    addWalls w' = foldl' (addDoorWall eo drid $ switchWallCol col) w' $ zip wlids wlps'

addDoorWall :: EdgeObstacle -> Int -> Wall -> World -> (Int,(Point2,Point2)) -> World
addDoorWall eo drid wl w (wlid,wlps) = w' 
    & walls %~ IM.insert wlid wl
        { _wlLine = wlps
        , _wlID = wlid
        , _wlStructure = DoorPart drid
        }
    & doors . ix drid . drObstructs .++~ es
  where
    (w',es) = uncurry (obstructPathsCrossing eo) wlps w
-- TODO use vector instead of list, perhaps also memoisation of rectanglePairs
-- TODO update _drPos
-- perhaps also remove use of DoorInt in favour of DoorOpen/DoorClosed
-- perhaps only store intermediate door pos pairs, calculate all wall positions
-- on the fly
doorMechanismStepwise :: Int -> Int -> [Int] -> [(Point2,Point2)] -> Door -> World -> World
doorMechanismStepwise nsteps drid wlids pss dr w 
    | toOpen = case _drStatus dr of
        DoorInt x | x == nsteps -> w
        DoorInt x               -> setWalls (x+1)
        _                       -> w
    | otherwise = case _drStatus dr of
        DoorInt 0 -> w
        DoorInt x -> setWalls (x-1)
        _         -> w
  where
    playSound = soundContinue (WallSound drid) (fst $ head pss) slideDoorS (Just 1)
    toOpen = _drTrigger dr w
    setWalls n = playSound (foldl' (&) w (zipWith moveWallID wlids newps))
        & doors . ix drid . drStatus .~ DoorInt n
      where
        newps = uncurry (rectanglePairs 9) (pss !! n)
-- it is not at all clear that the zoning selects the correct walls

-- TODO sort out why DoorClosed status does not update correctly 22/06/23
doorMechanism :: Door -> World -> World
doorMechanism dr w = case mvDir of
    Just d -> w
        & flip (IS.foldl' (flip (`translateWallID` d))) (_drWallIDs dr)
        & moveUpdate 
        & doors . ix drid . drPos . each %~ (+.+ d)
        & maybeClearDoorPaths (_drObstacleType dr) (_drObstructs dr)
    Nothing -> w
  where
    toOpen = _drTrigger dr w
    mvDir
        | toOpen && _drStatus dr == DoorOpen = Nothing -- Not sure why necessary
        | toOpen && dist dpos dop > 0.5 = Just $ vecBetweenSpeed speed dpos dop
        | dist dpos dcp > 0.5           = Just $ vecBetweenSpeed speed dpos dcp
        | otherwise = Nothing
    speed = _drSpeed dr
    drid = _drID dr
    moveUpdate = playSound . setStatus
    playSound = soundContinue (WallSound drid) dpos slideDoorS (Just 1)
    dpos = snd $ _drPos dr
    dop = snd $ _drOpenPos dr
    dcp = snd $ _drClosePos dr
    setStatus
        | dist dpos dop < 1 = doors . ix drid . drStatus .~ DoorOpen
        | dist dpos dcp < 1 = doors . ix drid . drStatus .~ DoorClosed
        | otherwise                       = doors . ix drid . drStatus .~ DoorHalfway

maybeClearDoorPaths :: EdgeObstacle -> [(Int,Int,PathEdge)] -> World -> World
maybeClearDoorPaths eo es w = foldl' (maybeClearDoorPath eo) w es

maybeClearDoorPath :: EdgeObstacle -> World -> (Int,Int,PathEdge) -> World
maybeClearDoorPath eo w (x,y,pe)
    | runIdentity . S.any_ (const True) $ overlapSegWalls (_peStart pe) (_peEnd pe) $ wlsNearSeg (_peStart pe) (_peEnd pe) w 
        = w & pathGraph %~ FGL.insEdge (x,y,pe & peObstacles . at eo ?~ ()) . FGL.delEdge (x,y)
    | otherwise 
        = w & pathGraph %~ FGL.insEdge (x,y,pe & peObstacles . at eo .~ Nothing) . FGL.delEdge (x,y) 

plSlideDoor 
    :: Door 
    -> Wall
    -> EdgeObstacle
    -> Float
    -> Point2 
    -> Point2 
    -> World
    -> (Int, World)
plSlideDoor dr wl eo shiftOffset a b gw 
    = (drid, addDoorWalls $ gw & doors %~ addDoor)
  where
    drid = IM.newKey $ _doors gw
    addDoor = IM.insert drid $ dr
        { _drID = drid
        , _drWallIDs = IS.fromList wlids
        , _drStatus = DoorClosed
        , _drMech   = doorMechanism
        , _drPos = (a,b)
        , _drOpenPos = (shiftLeft a,shiftLeft b)
        , _drClosePos = (a,b)
        , _drObstacleType = eo
        }
    addDoorWalls w' = foldl' (addDoorWall eo drid wl) w' $ zip wlids pairs
    pairs = rectanglePairs 9 a b
    shiftLeft  = (+.+ (a -.- b +.+ shiftOffset *.* normalizeV (b -.- a)))
    wlids = take 4 [IM.newKey $ _walls gw ..]
-- old code that may help with pathing
--import Dodge.LevelGen.Pathing
--import Data.Graph.Inductive hiding ((&))
--addButtonDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> Float -> World -> (Int, World)
--addButtonDoor c btp btr a b speed w 
--    = (,) 0
--    . over buttons (IM.insert bid bt) 
--    $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
--    $ set pathGraph newGraph
--    $ set pathGraphP newGraphPairs
--    $ snd (placeSlideDoor False c cond a b speed w)
--  where 
--    bid = IM.newKey $ _buttons w
--    cond w' = BtNoLabel == _btState (_buttons w' IM.! bid)
--    bt = (makeButton c eff) {_btPos = btp, _btRot = btr, _btID = bid}
--    (newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg a b)) 
--                                             $ _pathGraphP w
--    newGraph = pairsToGraph dist newGraphPairs
--    insertPoint  pp@(_,V2 x y) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
--    eff w' = over pathGraphP (removedPairs ++) 
--             . over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
--    f (x,y) = (x,y,dist x y)
