{-# LANGUAGE BangPatterns #-}
module Dodge.LevelGen.TriggerDoor
    where
import Dodge.Data
import Dodge.Base
import Dodge.SoundLogic
import Dodge.LevelGen.Switch
import Dodge.LevelGen.Pathing

import Picture
import Geometry

import Data.List
import Data.Maybe
import qualified Data.IntMap.Strict as IM

import Control.Lens
import Control.DeepSeq (deepseq)

import Data.Graph.Inductive hiding ((&))
import Data.Graph.Inductive.NodeMap

-- probably don't have to rebuild the entire graph, oh well
addButtonDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> World -> World
addButtonDoor c btp btr a b w = over buttons (IM.insert bid bt) 
    $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
    $ set pathGraph newGraph
    $ set pathGraph' newGraphPairs
    $ addTriggerDoor c cond a b w
  where 
    bid = 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)) 
                                             $ _pathGraph' w
    newGraph = pairsToGraph dist newGraphPairs
    insertPoint  pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
    eff w' = over pathGraph' (removedPairs ++) 
             . over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
    f (x,y) = (x,y,dist x y)

addSwitchDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> World -> World
addSwitchDoor c btp btr a b w = over buttons (IM.insert bid bt) 
    $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
    $ set pathGraph newGraph
    $ set pathGraph' newGraphPairs
    $ addTriggerDoor c cond a b w
  where 
    bid = newKey $ _buttons w
    cond w = BtOn == _btState (_buttons w IM.! bid)
    bt = (makeSwitch c openDoor closeDoor) {_btPos = btp, _btRot = btr, _btID = bid}
    (newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg' a b)) 
                                             $ _pathGraph' w
    newGraph = pairsToGraph dist newGraphPairs
    insertPoint  pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
    openDoor w' = over pathGraph' (removedPairs ++) 
                  . over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
    f (x,y) = (x,y,dist x y)
    closeDoor w' = over pathGraph' (\\ removedPairs)
                  . over pathGraph (flip run_ $ delMapEdgesM removedPairs) $ w'

addTriggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> World -> World
addTriggerDoor c cond a b = over walls (triggerDoor c cond a b)

triggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
triggerDoor c cond a b wls = IM.union wls $ IM.fromList $ zip is $ mkTriggerDoor c cond a b is
  where 
    i = newKey wls
    is = [i..]

mkTriggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> [Int] -> [Wall]
mkTriggerDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPane c cond)
    xs
    (leftDoor ++ rightDoor)
    (map shiftLeft leftDoor ++ map shiftRight rightDoor)
  where 
    leftDoor = 
        [ [pld +.+ perp,hwd]
        , [hwd,         hwu]
        , [hwu,         plu +.+ perp]
        , [plu +.+ perp,pld +.+ perp]
        ]
    rightDoor =
        [ [pru -.- perp,hwu]
        , [hwu,         hwd]
        , [hwd,         prd -.- perp]
        , [prd -.- perp,pru -.- perp]
        ]
    shiftRight = map (+.+ (0.5 *.* (pr -.- pl)))
    shiftLeft = map (+.+ (0.5 *.* (pl -.- pr)))
    norm = 14 *.* errorNormalizeV 49 ( vNormal (pr -.- pl))
    hw = 0.5 *.* (pl +.+ pr)
    perp = 5 *.* normalizeV (pl -.- pr)
    plu = pl +.+ norm
    pld = pl -.- norm
    pru = pr +.+ norm
    prd = pr -.- norm
    hwu = hw +.+ norm
    hwd = hw -.- norm
    addSound (x:xs) = f x : xs
    f wl = over doorMech g wl
    g dm w | dist wp pld > 2 && dist wp hwd > 2 
                    = soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0
                                                                    $ dm w
            | otherwise = dm w
          where 
            wp = _wlLine (_walls w IM.! (head xs)) !! 1

triggerDoorPane :: Color -> (World -> Bool) -> Int -> [Point2] -> [Point2] -> Wall
triggerDoorPane c cond n closedPos openPos = Door
    { _wlLine = closedPos
    , _wlID = n
    , _doorMech = dm
    , _wlColor = c
    , _wlDraw = Nothing
    , _wlSeen = False
    , _wlIsSeeThrough = False
    , _doorPathable = False
    }
  where 
    a = closedPos !! 0
    b = closedPos !! 1
    dm w | cond w    = flip (foldr changeZonedWall) zoneps
                       $ over walls (IM.adjust openDoor n) w -- . wlLine . ix 0) (mvPointToward a')
         | otherwise = flip (foldr changeZonedWall') zoneps
                       $ over walls (IM.adjust closeDoor n) w -- . wlLine . ix 0) (mvPointToward a)
    zoneps | dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b]
           | otherwise = map zoneOfPoint $ divideLine (2*zoneSize) a b
    mvP !ep !p = mvPointTowardAtSpeed 2 ep p
    moveToward :: [Point2] -> Wall -> Wall
    moveToward !ps w = let !newPs = zipWith mvP ps $ _wlLine w
                       in  deepseq newPs $ w {_wlLine = newPs}
    openDoor = moveToward openPos
    closeDoor = moveToward closedPos
    changeZonedWall (!x,!y) 
          = over wallsZone $ adjustIMZone openDoor x y n
    changeZonedWall' (!x,!y) 
          = over wallsZone $ adjustIMZone closeDoor x y n