loop/src/Dodge/LevelGen/TriggerDoor.hs

--{-# LANGUAGE BangPatterns #-}
module Dodge.LevelGen.TriggerDoor
    ( putDoor
    , putSingleDoor
    , addButtonDoor
    , insertDoubleDoor
    ) where
import Dodge.Data
import Dodge.Base
import Dodge.Zone
import Dodge.Default.Wall
import Dodge.LevelGen.Switch
import Dodge.LevelGen.Pathing
import Dodge.LevelGen.MoveDoor
import Dodge.LevelGen.DoorPane
import Picture
import Geometry
import qualified IntMapHelp as IM
import Dodge.SoundLogic
import Dodge.SoundLogic.LoadSound
import Dodge.Data.SoundOrigin

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 -> 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 (putSingleDoor 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)

putDoor 
    :: Color 
    -> (World -> Bool)      -- ^ Opening condition
    -> [(Point2,Point2)]   -- ^ Door positions, closed to open.
                    -- Bumped out up and down by 9, not widened
    -> World 
    -> (Int,World)
putDoor col cond pss w = (drid, addWalls w & doors %~ addDoor)
  where
    drid = IM.newKey $ _doors w
    addDoor = IM.insert drid $ Door
        { _drID = drid
        , _drWallIDs = 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
        , _wlIsSeeThrough = False
        , _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
    cpss = uncurry (rectanglePairs 9) (head pss)
    setWalls n = playSound (foldl' setWall w (zip3 wlids newps cpss))
        & doors . ix drid . drStatus .~ DoorInt n
      where
        newps = uncurry (rectanglePairs 9) (pss !! n)
    setWall w' (wlid,ps,cps) = w' & walls . ix wlid . wlLine .~ ps
        & (\w'' -> foldr (changeZonedWall (wlLine .~ ps) wlid) w'' (zoneps cps)) 
-- it is not at all clear that the zoning selects the correct walls

-- TODO think about wall zoning, simplify!
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,openpos,cp) = mvDoorWithZone w' wlid openpos cp
    doClose w' (wlid,_,cp)       = mvDoorWithZone w' wlid cp      cp
    mvDoorWithZone w' wlid p zp = w'
        & walls . ix wlid %~ moveDoorToward speed p
        & (\w'' -> foldr (changeZonedWall (moveDoorToward speed p) wlid) w'' (zoneps zp))

insertDoubleDoor ::  Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World
    -> World
insertDoubleDoor isPathable col cond a b speed
    = snd . putSingleDoor isPathable col cond a (0.5 *.* (a +.+ b)) speed
    . snd . putSingleDoor isPathable col cond b (0.5 *.* (a +.+ b)) speed

putSingleDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World
    -> (Int, World)
putSingleDoor isPathable col cond a b speed w = (drid, addWalls w 
    & doors %~ addDoor)
  where
    drid = IM.newKey $ _doors w
    addDoor = IM.insert drid $ Door
        { _drID = drid
        , _drWallIDs = 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
        , _wlIsSeeThrough = False
        , _wlPathable = isPathable
        }
    pairs = rectanglePairs 9 a b
    shiftedPairs = map (bimap shiftLeft shiftLeft) pairs
    shiftLeft  = (+.+ (a -.- b))
    wlids = take 4 [IM.newKey $ _walls w ..]