90 lines
3.2 KiB
Haskell
90 lines
3.2 KiB
Haskell
{-# LANGUAGE BangPatterns #-}
|
|
module Dodge.LevelGen.AutoDoor
|
|
where
|
|
import Dodge.Data
|
|
import Dodge.Base
|
|
import Dodge.SoundLogic
|
|
|
|
import Geometry
|
|
import Picture
|
|
|
|
import Data.List
|
|
import Data.Maybe
|
|
import qualified Data.IntMap.Strict as IM
|
|
|
|
import Control.Lens
|
|
import Control.DeepSeq (deepseq)
|
|
|
|
addAutoDoor :: Point2 -> Point2 -> World -> World
|
|
addAutoDoor a b = over walls (autoDoorAt a b)
|
|
|
|
autoDoorAt :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
|
|
autoDoorAt a b wls = IM.union wls $ IM.fromList $ zip is $ mkAutoDoor a b is
|
|
where i = newKey wls
|
|
is = [i..]
|
|
|
|
mkAutoDoor :: Point2 -> Point2 -> [Int] -> [Wall]
|
|
mkAutoDoor pl pr xs = addSound $ zipWith3 (autoDoorPane [pl,pr])
|
|
xs
|
|
(lDoorClosed ++ rDoorClosed)
|
|
(map shiftL lDoorClosed ++ map shiftR rDoorClosed)
|
|
where lDoorClosed = [ [pld,hwd]
|
|
, [hwd,hwu]
|
|
, [hwu,plu]
|
|
]
|
|
rDoorClosed = [ [pru,hwu]
|
|
, [hwu,hwd]
|
|
, [hwd,prd]
|
|
]
|
|
norm = 10 *.* errorNormalizeV 49 ( vNormal (pr -.- pl))
|
|
hw = 0.5 *.* (pl +.+ pr)
|
|
parallel = 0.5 *.* (pl -.- pr)
|
|
plu = pl +.+ norm
|
|
pld = pl -.- norm
|
|
pru = pr +.+ norm
|
|
prd = pr -.- norm
|
|
hwu = hw +.+ norm
|
|
hwd = hw -.- norm
|
|
shiftL = map $ (+.+ parallel) . (-.- normalizeV parallel)
|
|
shiftR = map $ (-.- parallel) . (+.+ normalizeV parallel)
|
|
|
|
addSound (x:xs) = f x : xs
|
|
f wl = over doorMech g wl
|
|
g dm w | dist wp pld > 1 && dist wp hwd > 1
|
|
= soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0 $ dm w
|
|
| otherwise = dm w
|
|
where wp = (_wlLine $ _walls w IM.! (head xs)) !! 1
|
|
|
|
autoDoorPane :: [Point2] -> Int -> [Point2] -> [Point2] -> Wall
|
|
autoDoorPane trigL n closedPos openPos = Door
|
|
{ _wlLine = closedPos
|
|
, _wlID = n
|
|
, _doorMech = dm
|
|
, _wlColor = dim $ yellow
|
|
, _wlDraw = Nothing
|
|
, _wlSeen = False
|
|
, _wlIsSeeThrough = False
|
|
, _doorPathable = True
|
|
}
|
|
where
|
|
a = closedPos !! 0
|
|
b = closedPos !! 1
|
|
dm w | crsNearLine 40 trigL w
|
|
= flip (foldr changeZonedWall) zoneps
|
|
$ over walls (IM.adjust openDoor n) w
|
|
| otherwise = flip (foldr changeZonedWall') zoneps
|
|
$ over walls (IM.adjust closeDoor n) w
|
|
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}
|
|
--deepseq ps $ w & wlLine %~ zipWith mvP ps
|
|
openDoor = moveToward openPos
|
|
closeDoor = moveToward closedPos
|
|
zoneps | dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b]
|
|
| otherwise = map zoneOfPoint $ divideLine (2*zoneSize) a b
|
|
changeZonedWall (!x,!y)
|
|
= over wallsZone $ adjustIMZone openDoor x y n
|
|
changeZonedWall' (!x,!y)
|
|
= over wallsZone $ adjustIMZone closeDoor x y n
|