209 lines
7.7 KiB
Haskell
209 lines
7.7 KiB
Haskell
{-# LANGUAGE BangPatterns #-}
|
|
module Dodge.LevelGen.TriggerDoor
|
|
where
|
|
import Dodge.Data
|
|
import Dodge.Base
|
|
import Dodge.SoundLogic
|
|
import Dodge.SoundLogic.Synonyms
|
|
import Dodge.LevelGen.Switch
|
|
import Dodge.LevelGen.Pathing
|
|
import Dodge.LevelGen.MoveDoor
|
|
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
|
|
openDoor = moveDoorToward openPos
|
|
closeDoor = moveDoorToward 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
|