--{-# LANGUAGE BangPatterns #-}
module Dodge.Placement.PlaceSpot.TriggerDoor
    ( placeDoor
    , placeSlideDoor
    ) where
import Dodge.Data
import Dodge.Default.Wall
import Dodge.Wall.Move
import Dodge.LevelGen.DoorPane
import Picture
import Geometry
import qualified IntMapHelp as IM
import Dodge.SoundLogic
import Dodge.LevelGen.LevelStructure

import Data.List
import Control.Lens
--import Data.Graph.Inductive hiding ((&))
import qualified Data.IntSet as IS
placeDoor 
    :: Color 
    -> (World -> Bool)      -- ^ Opening condition
    -> [(Point2,Point2)]   -- ^ Door positions, closed to open.
                    -- Bumped out up and down by 9, not widened
    -> GenWorld 
    -> (Int,GenWorld)
placeDoor col cond pss gw = (drid, gw & gWorld  .~ (addWalls w & doors %~ addDoor))
  where
    w = _gWorld gw
    drid = IM.newKey $ _doors w
    addDoor = IM.insert drid $ Door
        { _drID = drid
        , _drWallIDs = IS.fromList wlids
        , _drStatus = DoorInt 0
        , _drTrigger = cond
        , _drMech   = doorMechanismStepwise nsteps drid wlids pss
        }
    nsteps = length pss - 1
    wlids = take 4 [IM.newKey $ _walls w ..]
    wlps' = uncurry (rectanglePairs 9) $ head pss
    addWalls w' = foldl' addWall w' $ zip wlids wlps'
    addWall w' (wlid, wlps) = w' & walls %~ IM.insert wlid defaultWall
        { _wlLine = wlps
        , _wlID = wlid
        , _wlColor = col
        , _wlSeen = False
        , _wlOpacity = Opaque
        , _wlPathable = False
        }
-- TODO use vector instead of list, perhaps also memoisation of rectanglePairs
-- perhaps also remove use of DoorInt in favour of DoorOpen/DoorClosed
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

doorMechanism :: Int -> Float -> [(Int,(Point2,Point2),(Point2,Point2))] -> Door -> World -> World
doorMechanism drid speed wlidOpCps dr w 
    | toOpen     && dstatus /= DoorOpen   = moveUpdate $ foldl' doOpen  w wlidOpCps
    | not toOpen && dstatus /= DoorClosed = moveUpdate $ foldl' doClose w wlidOpCps
    | otherwise = w
  where
    moveUpdate = playSound . setStatus
    playSound = soundContinue (WallSound drid) (fst cpos) slideDoorS (Just 1)
    setStatus
        | dist (fst wlpos) (fst opos) < 1 = doors . ix drid . drStatus .~ DoorOpen
        | dist (fst wlpos) (fst cpos) < 1 = doors . ix drid . drStatus .~ DoorClosed
        | otherwise                       = doors . ix drid . drStatus .~ DoorHalfway
    (wlid',opos,cpos) = head wlidOpCps
    wlpos   = _wlLine $ _walls w IM.! wlid'
    toOpen  = _drTrigger dr w
    dstatus = _drStatus dr
    doOpen  w' (wlid,opp, _) = moveWallIDToward wlid speed opp w'
    doClose w' (wlid,_ ,clp) = moveWallIDToward wlid speed clp w'

-- TODO cut pathing if not pathable, reset when opened
placeSlideDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> GenWorld
    -> (Int, GenWorld)
placeSlideDoor isPathable col cond a b speed gw = (drid, gw & gWorld .~ (addWalls w & doors %~ addDoor))
  where
    w = _gWorld gw
    drid = IM.newKey $ _doors w
    addDoor = IM.insert drid $ Door
        { _drID = drid
        , _drWallIDs = IS.fromList wlids
        , _drStatus = DoorClosed
        , _drTrigger = cond
        , _drMech   = doorMechanism drid speed (zip3 wlids shiftedPairs pairs)
        }
    addWalls w' = foldl' addWall w' $ zip wlids pairs
    addWall w' (wlid, wlps) = w' & walls %~ IM.insert wlid defaultWall
        { _wlLine = wlps
        , _wlID = wlid
        , _wlColor = col
        , _wlSeen       = False
        , _wlOpacity    = Opaque
        , _wlPathable   = isPathable
        }
    pairs = rectanglePairs 9 a b
    shiftedPairs = map (bimap shiftLeft shiftLeft) pairs
    shiftLeft  = (+.+ (a -.- b))
    wlids = take 4 [IM.newKey $ _walls w ..]
-- 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)
