loop/src/Dodge/LevelGen/TriggerDoor.hs

--{-# LANGUAGE BangPatterns #-}
module Dodge.LevelGen.TriggerDoor
    ( putDoor
    , putDoubleDoor
    , putSingleDoor
    , addButtonDoor
    , addSwitchDoor
    ) where
import Dodge.Data
import Dodge.Base
import Dodge.Base.Zone
import Dodge.LevelGen.Switch
import Dodge.LevelGen.Pathing
import Dodge.LevelGen.MoveDoor
import Dodge.LevelGen.DoorPane
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 -> Float -> World -> World
addButtonDoor c btp btr a b speed 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 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)) 
                                             $ _pathGraph' w
    newGraph = pairsToGraph dist newGraphPairs
    insertPoint  pp@(_,V2 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)
-- this has been repeated at least three times: TO BE UNIFIED, REFACTORED
addSwitchDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> Float -> World -> World
addSwitchDoor c btp btr a b speed 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 speed 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@(_,V2 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)      -- ^ Opening condition
    -> [(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 -> Float -> World -> World
putDoubleDoor c cond a b speed = over walls triggerDoubleDoor
  where
    triggerDoubleDoor wls = IM.union wls $ IM.fromList $ zip is $ mkDoubleDoor c False cond a b speed is
      where
        is = [IM.newKey wls..]

putSingleDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World -> World
putSingleDoor c cond a b speed = over walls putTheDoor
  where
    putTheDoor wls = IM.union wls $ IM.fromList $ zip is $ mkSingleDoor c False cond a b speed 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]
{-# INLINE mkTriggerDoor #-}
mkTriggerDoor c cond ppairs is = zipWith (triggerDoorPane c cond) is $
    transpose $ map toPanePoints ppairs

toPanePoints :: (Point2,Point2) -> [(Point2,Point2)]
{-# INLINE toPanePoints #-}
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))
{- |
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 = doorMechan n allZoneps openDoor closeDoor cond 
    openDoor  = updatePos . (drPositions %~ DS.pushL)
    closeDoor = updatePos . (drPositions %~ DS.pushR)
    updatePos :: Wall -> Wall
    updatePos d = d & wlLine %~ maybe id const (DS.head <$> (d ^? drPositions))
    allZoneps = nub $ concatMap zoneps poss