{-# 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 qualified DoubleStack as DS
import qualified IntMapHelp as IM

import Data.List
import Data.Maybe
import Control.Lens
import Data.Graph.Inductive hiding ((&))

-- 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
    $ putDoubleDoor c cond a b 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)) 
                                             $ _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
    $ putDoubleDoor c cond a b w
  where 
    bid = IM.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'


putDoor 
    :: Color 
    -> (World -> Bool) 
    -> [(Point2,Point2)]   -- ^ Door positions, closed to open.
                    -- Bumped out up and down by 9, not widened
    -> World 
    -> World
putDoor c cond pss = over walls triggerDoor
  where
    triggerDoor wls = IM.union wls $ IM.fromList $ zip is $ mkTriggerDoor c cond pss is
      where
        is = [IM.newKey wls..]

putDoubleDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> World -> World
putDoubleDoor c cond a b = over walls triggerDoubleDoor
  where
    triggerDoubleDoor wls = IM.union wls $ IM.fromList $ zip is $ mkTriggerDoubleDoor c cond a b is
      where
        is = [IM.newKey wls..]

mkTriggerDoor 
    :: Color 
    -> (World -> Bool)      -- ^ Opening condition
    -> [(Point2,Point2)]    -- ^ List of wall position pairs, closed to open
    -> [Int]                -- ^ Wall ids
    -> [Wall]
mkTriggerDoor c cond ppairs is = zipWith (triggerDoorPane c cond) is $
    transpose $ map toPanePoints ppairs

toPanePoints :: (Point2,Point2) -> [(Point2,Point2)]
toPanePoints (x,y) = 
    [ (y +.+ perp, y -.- perp)
    , (y -.- perp, x -.- perp)
    , (x -.- perp, x +.+ perp)
    , (x +.+ perp, y +.+ perp)
    ]
  where
    perp = 9 *.* errorNormalizeV 49 ( vNormal (x -.- y))

mkTriggerDoubleDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> [Int] -> [Wall]
mkTriggerDoubleDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPaneLinear 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 = h (+.+ (0.5 *.* (pr -.- pl)))
    shiftLeft = h (+.+ (0.5 *.* (pl -.- pr)))
    h func (x,y) = (func x,func y)
    norm = 9 *.* 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:ys) = f x : ys
    addSound _ = error "When creating a trigger door, added a sound to nothing"
    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 = snd $ _wlLine (_walls w IM.! head xs)

triggerDoorPaneLinear
    :: Color 
    -> (World -> Bool)  -- ^ Opening condition
    -> Int              -- ^ Wall id
    -> (Point2,Point2)         -- ^ Closed position
    -> (Point2,Point2)         -- ^ Open position
    -> Wall
triggerDoorPaneLinear c cond n closedPos openPos = Door
    { _wlLine = closedPos
    , _wlID = n
    , _doorMech = dm
    , _wlColor = c
    , _wlSeen = False
    , _wlIsSeeThrough = False
    , _doorPathable = False
    , _drPositions = DS.singleton closedPos
    }
  where 
    a = fst closedPos
    b = snd closedPos
    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
    mvPs (ex,ey) (sx,sy) = (mvP ex sx,mvP ey sy)
    moveToward :: (Point2,Point2) -> Wall -> Wall
    moveToward (ex,ey) wls = wls & wlLine %~ mvPs (ex,ey)
    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

{- |
Zoning might be an issue here.
It is necessary in the current version, but I am not sure of its behaviour. -}
triggerDoorPane
    :: Color 
    -> (World -> Bool)  -- ^ Opening condition
    -> Int              -- ^ Wall id
    -> [(Point2,Point2)]       -- ^ List of positions: closed to open
    -> Wall
triggerDoorPane c cond n poss = Door
    { _wlLine = head poss
    , _wlID = n
    , _doorMech = dm
    , _wlColor = c
    , _wlSeen = False
    , _wlIsSeeThrough = False
    , _doorPathable = False
    , _drPositions = DS.fromListL poss
    }
  where 
    dm w | cond w    = flip (foldr changeZonedWall) allZoneps
                       $ over walls (IM.adjust openDoor n) w -- . wlLine . ix 0) (mvPointToward a')
         | otherwise = flip (foldr changeZonedWall') allZoneps
                       $ over walls (IM.adjust closeDoor n) w -- . wlLine . ix 0) (mvPointToward a)
    openDoor  = updatePos . (drPositions %~ DS.pushL)
    closeDoor = updatePos . (drPositions %~ DS.pushR)
    updatePos :: Wall -> Wall
    updatePos d = d & wlLine %~ maybe id const (DS.head <$> (d ^? drPositions))
    changeZonedWall (!x,!y) 
          = over wallsZone $ adjustIMZone openDoor x y n
    changeZonedWall' (!x,!y) 
          = over wallsZone $ adjustIMZone closeDoor x y n
    allZoneps = nub $ concatMap zoneps poss
    zoneps (a,b)
        | dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b]
        | otherwise = map zoneOfPoint $ divideLine (2*zoneSize) a b