139 lines
5.4 KiB
Haskell
139 lines
5.4 KiB
Haskell
{-# 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
|