Split trigger door module, improve trigger door shadows
This commit is contained in:
+4
-162
@@ -7,6 +7,8 @@ module Dodge.LevelGen
|
||||
, checkWalls
|
||||
, nubWalls
|
||||
, pairsToGraph
|
||||
, makeButton
|
||||
, makeSwitch
|
||||
)
|
||||
where
|
||||
|
||||
@@ -19,6 +21,8 @@ import Dodge.LevelGen.Block
|
||||
import Dodge.LevelGen.Pathing
|
||||
import Dodge.LevelGen.StaticWalls
|
||||
import Dodge.LevelGen.AutoDoor
|
||||
import Dodge.LevelGen.TriggerDoor
|
||||
import Dodge.LevelGen.Switch
|
||||
|
||||
import Geometry
|
||||
import Picture
|
||||
@@ -127,171 +131,9 @@ instance Shiftable PlacementSpot where
|
||||
rotateS r' (PS p r x) = PS (rotateV r' p) (r + r') x
|
||||
|
||||
|
||||
makeButton :: Color -> (World -> World) -> Button
|
||||
makeButton c eff = Button
|
||||
{ _btPict = onLayer WlLayer $ color c $ polygon $ rectNSEW 5 (-5) 10 (-10)
|
||||
, _btPos = (0,0)
|
||||
, _btRot = 0
|
||||
, _btEvent = \b w -> eff . over buttons (IM.adjust turnOn (_btID b))
|
||||
-- . set (buttons . ix (_btID b) . btPict)
|
||||
-- (onLayer WlLayer $ color c $ polygon $ rectNSEW (-3) (-5) 10 (-10))
|
||||
-- . set (buttons . ix (_btID b) . btState) BtNoLabel
|
||||
-- . set (buttons . ix (_btID b) . btEvent) (\b -> return)
|
||||
. soundOnce 1 $ w
|
||||
, _btID = 0
|
||||
, _btText = "Button"
|
||||
--, _btText = "Button"
|
||||
, _btState = BtOff
|
||||
}
|
||||
where
|
||||
turnOn bt = bt {_btState = BtNoLabel, _btPict = onPict, _btEvent = (\_ -> id)}
|
||||
onPict = (onLayer WlLayer $ color c $ polygon $ rectNSEW (-3) (-5) 10 (-10))
|
||||
|
||||
makeSwitch :: Color -> (World -> World) -> (World -> World) -> Button
|
||||
makeSwitch c effOn effOff = Button
|
||||
{ _btPict = offPict
|
||||
, _btPos = (0,0)
|
||||
, _btRot = 0
|
||||
, _btEvent = flipSwitch
|
||||
, _btID = 0
|
||||
, _btText = "Switch"
|
||||
, _btState = BtOff
|
||||
}
|
||||
where
|
||||
flipSwitch b w = switchEffect b . soundOnce 1 $ w
|
||||
switchEffect b = case _btState b of
|
||||
BtOff -> effOn . over buttons (IM.adjust turnOn (_btID b))
|
||||
BtOn -> effOff . over buttons (IM.adjust turnOff (_btID b))
|
||||
offPict = onLayer WlLayer $ color c $ pictures [--translate (-8) 4 $ circleSolid 5
|
||||
polygon $ rectNSEW (-2) (-5) (-10) (10)
|
||||
,polygon [(-2,-5),(-10,4),(-6,4),(2,-5)]
|
||||
]
|
||||
onPict = onLayer WlLayer $ color c $ pictures [--translate (8) 4 $ circleSolid 5
|
||||
polygon $ rectNSEW (-2) (-5) (-10) (10)
|
||||
,polygon [(-2,-5), (6,4),( 10,4),(2,-5)]
|
||||
]
|
||||
turnOn :: Button -> Button
|
||||
turnOn bt = bt {_btState = BtOn, _btPict = onPict}
|
||||
turnOff :: Button -> Button
|
||||
turnOff bt = bt {_btState = BtOff, _btPict = offPict}
|
||||
|
||||
|
||||
|
||||
-- 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 (not . isJust . 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 (not . isJust . 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' (\pg -> pg \\ 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
|
||||
[ [pld,hwd]
|
||||
, [hwd,hwu]
|
||||
, [hwu,plu]
|
||||
, [plu,pld]
|
||||
, [pru,hwu]
|
||||
, [hwu,hwd]
|
||||
, [hwd,prd]
|
||||
, [prd,pru]
|
||||
]
|
||||
[ [plld,pld]
|
||||
, [pld,plu]
|
||||
, [plu,pllu]
|
||||
, [pllu,plld]
|
||||
, [prru,pru]
|
||||
, [pru,prd]
|
||||
, [prd,prrd]
|
||||
, [prrd,prru]
|
||||
]
|
||||
where norm = 10 *.* errorNormalizeV 49 ( vNormal (pr -.- pl))
|
||||
hw = 0.5 *.* (pl +.+ pr)
|
||||
perp = 20 *.* normalizeV (pl -.- pr)
|
||||
--perp = pl -.- hw
|
||||
plu = pl +.+ norm
|
||||
pld = pl -.- norm
|
||||
pru = pr +.+ norm
|
||||
prd = pr -.- norm
|
||||
hwu = hw +.+ norm
|
||||
hwd = hw -.- norm
|
||||
pllu = plu +.+ perp
|
||||
plld = pld +.+ perp
|
||||
prru = pru -.- perp
|
||||
prrd = prd -.- perp
|
||||
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 [a,b] [a',b'] = Door
|
||||
{ _wlLine = [a,b]
|
||||
, _wlID = n
|
||||
, _doorMech = dm
|
||||
, _wlColor = c
|
||||
, _wlDraw = Nothing
|
||||
, _wlSeen = False
|
||||
, _wlIsSeeThrough = False
|
||||
-- , _doorLine = [a,b,a',b']
|
||||
}
|
||||
where
|
||||
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 :: Wall -> Wall
|
||||
openDoor wl = case _wlLine wl of
|
||||
((!pa):(!pb):_) -> wl {_wlLine = [mvPointToward a' pa, mvPointToward b' pb]}
|
||||
closeDoor :: Wall -> Wall
|
||||
closeDoor wl = case _wlLine wl of
|
||||
((!pa):(!pb):_) -> wl {_wlLine = [mvPointToward a pa, mvPointToward b pb]}
|
||||
changeZonedWall (!x,!y)
|
||||
= over wallsZone $ adjustIMZone openDoor x y n
|
||||
changeZonedWall' (!x,!y)
|
||||
= over wallsZone $ adjustIMZone closeDoor x y n
|
||||
|
||||
putWindowBlock :: Point2 -> Point2 -> World -> World
|
||||
putWindowBlock a b w = removePathsCrossing a b $ foldr makeBlockAt w $ zip ps ns
|
||||
|
||||
Reference in New Issue
Block a user