Refactor doors
This commit is contained in:
@@ -1,19 +1,18 @@
|
||||
--{-# LANGUAGE BangPatterns #-}
|
||||
{- |
|
||||
Creation of doors that open when creatures approach them.
|
||||
-}
|
||||
--{-# LANGUAGE BangPatterns #-}
|
||||
module Dodge.LevelGen.AutoDoor
|
||||
where
|
||||
( addAutoDoor
|
||||
) where
|
||||
import Dodge.Data
|
||||
--import Dodge.Creature.State.Data
|
||||
import Dodge.Base
|
||||
import Dodge.SoundLogic
|
||||
import Dodge.SoundLogic.Synonyms
|
||||
import Dodge.Creature.Property
|
||||
import Dodge.LevelGen.MoveDoor
|
||||
import Geometry
|
||||
--import Dodge.LevelGen.MoveDoor
|
||||
import Dodge.LevelGen.DoorPane
|
||||
--import Geometry
|
||||
import Picture
|
||||
import qualified DoubleStack as DS
|
||||
--import qualified DoubleStack as DS
|
||||
import qualified IntMapHelp as IM
|
||||
|
||||
--import Data.List
|
||||
@@ -35,69 +34,13 @@ autoDoorAt
|
||||
-> IM.IntMap Wall
|
||||
autoDoorAt a b wls = IM.union wls $ IM.fromList $ zip is $ mkAutoDoor a b is
|
||||
where
|
||||
i = IM.newKey wls
|
||||
is = [i..]
|
||||
is = [IM.newKey wls..]
|
||||
|
||||
mkAutoDoor
|
||||
:: Point2 -- ^ Left point
|
||||
-> Point2 -- ^ Right point (though the two points should be symmetric)
|
||||
-> [Int] -- ^ Wall ids
|
||||
-> [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 = h $ (+.+ parallel) . (-.- normalizeV parallel)
|
||||
shiftR = h $ (-.- parallel) . (+.+ normalizeV parallel)
|
||||
h func (x,y) = (func x,func y)
|
||||
|
||||
addSound (x:ys) = f x : ys
|
||||
addSound _ = error "Trying to add a sound to malformed auto door"
|
||||
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)
|
||||
|
||||
autoDoorPane
|
||||
:: (Point2,Point2) -- ^ Trigger line
|
||||
-> Int -- ^ Wall id
|
||||
-> (Point2,Point2) -- ^ Closed position
|
||||
-> (Point2,Point2) -- ^ Open position
|
||||
-> Wall
|
||||
autoDoorPane (trigx,trigy) n closedPos openPos = Door
|
||||
{ _wlLine = closedPos
|
||||
, _wlID = n
|
||||
, _doorMech = dm
|
||||
, _wlColor = dim yellow
|
||||
, _wlSeen = False
|
||||
, _wlIsSeeThrough = False
|
||||
, _doorPathable = True
|
||||
, _drPositions = DS.singleton closedPos
|
||||
}
|
||||
where
|
||||
dm = doorMechan n (zoneps closedPos) openDoor closeDoor cond
|
||||
cond = any (crNearSeg 40 trigx trigy) . IM.filter isAnimate . _creatures
|
||||
openDoor = moveDoorToward openPos
|
||||
closeDoor = moveDoorToward closedPos
|
||||
mkAutoDoor pl pr = mkDoubleDoor (dim yellow) True cond pl pr
|
||||
where
|
||||
cond = any (crNearSeg 40 pl pr) . IM.filter isAnimate . _creatures
|
||||
|
||||
@@ -1,13 +1,20 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
module Dodge.LevelGen.MoveDoor
|
||||
where
|
||||
( doorMechan
|
||||
, zoneps
|
||||
, moveDoorToward
|
||||
, addSoundToDoor
|
||||
) where
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
import Dodge.Base.Zone
|
||||
import Dodge.SoundLogic
|
||||
import Dodge.SoundLogic.Synonyms
|
||||
import Geometry
|
||||
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
import Control.Lens
|
||||
|
||||
-- This deserves a clean up
|
||||
mvP :: Point2 -> Point2 -> Point2
|
||||
{-# INLINE mvP #-}
|
||||
@@ -22,9 +29,11 @@ moveDoorToward :: (Point2,Point2) -> Wall -> Wall
|
||||
moveDoorToward (ex,ey) wls = wls & wlLine %~ mvPs (ex,ey)
|
||||
|
||||
zoneps :: (Point2, Point2) -> [(Int,Int)]
|
||||
{-# INLINE zoneps #-}
|
||||
zoneps (a,b)
|
||||
| dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b]
|
||||
| otherwise = map zoneOfPoint $ divideLine (2*zoneSize) a b
|
||||
| dist a b <= 2 * zoneSize
|
||||
= [zoneOfPoint $ pHalf a b]
|
||||
| otherwise = map zoneOfPoint $ divideLine zoneSize a b
|
||||
|
||||
doorMechan
|
||||
:: Int
|
||||
@@ -35,15 +44,28 @@ doorMechan
|
||||
-> World
|
||||
-> World
|
||||
doorMechan n zonePs openEff closeEff cond w
|
||||
| cond w = flip (foldr $ changeZonedWall'' openEff n) zonePs
|
||||
| cond w = flip (foldr $ changeZonedWall openEff n) zonePs
|
||||
$ over walls (IM.adjust openEff n) w
|
||||
| otherwise = flip (foldr $ changeZonedWall'' closeEff n) zonePs
|
||||
| otherwise = flip (foldr $ changeZonedWall closeEff n) zonePs
|
||||
$ over walls (IM.adjust closeEff n) w
|
||||
|
||||
changeZonedWall''
|
||||
changeZonedWall
|
||||
:: (Wall -> Wall)
|
||||
-> Int
|
||||
-> (Int,Int)
|
||||
-> World
|
||||
-> World
|
||||
changeZonedWall'' eff n (x,y) = over wallsZone $ adjustIMZone eff x y n
|
||||
changeZonedWall eff n (x,y) = over wallsZone $ adjustIMZone eff x y n
|
||||
|
||||
addSoundToDoor :: Int -> Point2 -> Point2 -> [Wall] -> [Wall]
|
||||
addSoundToDoor _ _ _ [] = error "When creating door tried to add sound to nothing"
|
||||
addSoundToDoor i pld hwd (x:ys) = f x : ys
|
||||
where
|
||||
f wl = over doorMech g wl
|
||||
where
|
||||
g dm w
|
||||
| dist wp pld > 2 && dist wp hwd > 2
|
||||
= soundFrom (WallSound i) (fromIntegral doorSound) 1 0 $ dm w
|
||||
| otherwise = dm w
|
||||
where
|
||||
wp = snd $ _wlLine (_walls w IM.! i)
|
||||
|
||||
@@ -1,14 +1,17 @@
|
||||
--{-# LANGUAGE BangPatterns #-}
|
||||
module Dodge.LevelGen.TriggerDoor
|
||||
where
|
||||
( putDoor
|
||||
, putDoubleDoor
|
||||
, addButtonDoor
|
||||
, addSwitchDoor
|
||||
) where
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
import Dodge.Base.Zone
|
||||
import Dodge.SoundLogic
|
||||
import Dodge.SoundLogic.Synonyms
|
||||
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
|
||||
@@ -37,7 +40,6 @@ addButtonDoor c btp btr a b w = over buttons (IM.insert bid bt)
|
||||
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 -> World -> World
|
||||
addSwitchDoor c btp btr a b w = over buttons (IM.insert bid bt)
|
||||
@@ -59,10 +61,9 @@ addSwitchDoor c btp btr a b w = over buttons (IM.insert bid bt)
|
||||
closeDoor w' = over pathGraph' (\\ removedPairs)
|
||||
. over pathGraph (flip run_ $ delMapEdgesM removedPairs) $ w'
|
||||
|
||||
|
||||
putDoor
|
||||
:: Color
|
||||
-> (World -> Bool)
|
||||
-> (World -> Bool) -- ^ Opening condition
|
||||
-> [(Point2,Point2)] -- ^ Door positions, closed to open.
|
||||
-- Bumped out up and down by 9, not widened
|
||||
-> World
|
||||
@@ -76,7 +77,7 @@ putDoor c cond pss = over walls triggerDoor
|
||||
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
|
||||
triggerDoubleDoor wls = IM.union wls $ IM.fromList $ zip is $ mkDoubleDoor c False cond a b is
|
||||
where
|
||||
is = [IM.newKey wls..]
|
||||
|
||||
@@ -98,76 +99,14 @@ toPanePoints (x,y) =
|
||||
]
|
||||
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
|
||||
dm = doorMechan n (zoneps closedPos) openDoor closeDoor cond
|
||||
openDoor = moveDoorToward openPos
|
||||
closeDoor = moveDoorToward closedPos
|
||||
{- |
|
||||
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
|
||||
-> (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
|
||||
|
||||
Reference in New Issue
Block a user