diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index 67905bfd1..4d95d9da1 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -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 diff --git a/src/Dodge/LevelGen/Switch.hs b/src/Dodge/LevelGen/Switch.hs new file mode 100644 index 000000000..7bc313372 --- /dev/null +++ b/src/Dodge/LevelGen/Switch.hs @@ -0,0 +1,61 @@ +module Dodge.LevelGen.Switch + where +import Dodge.Data +import Dodge.Base +import Dodge.SoundLogic + +import Picture +import Geometry + +import qualified Data.IntMap.Strict as IM + +import Control.Lens + + +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} diff --git a/src/Dodge/LevelGen/TriggerDoor.hs b/src/Dodge/LevelGen/TriggerDoor.hs new file mode 100644 index 000000000..8bf6cbc4b --- /dev/null +++ b/src/Dodge/LevelGen/TriggerDoor.hs @@ -0,0 +1,139 @@ +{-# 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 (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,hw,pl] + , [hwd,hwu] + , [hwu,plu,pl,hw] + , [plu,pld] + , [pru,hwu,hw,pr] + , [hwu,hwd] + , [hwd,prd,pr,hw] + , [prd,pru] + ] + [ [plld,pld,pl,pl] + , [pld,plu] + , [plu,pllu,pl,pl] + , [pllu,plld] + , [prru,pru,pr,pr] + , [pru,prd] + , [prd,prrd,pr,pr] + , [prrd,prru] + ] + where norm = 15 *.* 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 closedPos openPos = Door + { _wlLine = closedPos + , _wlID = n + , _doorMech = dm + , _wlColor = c + , _wlDraw = Nothing + , _wlSeen = False + , _wlIsSeeThrough = False +-- , _doorLine = [a,b,a',b'] + } + 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