diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index b8a66b3cd..efa15d275 100644 --- a/src/Dodge/Base.hs +++ b/src/Dodge/Base.hs @@ -750,3 +750,13 @@ wallsLOS !ls !c !p = all (\l -> wallLOS l c p) ls translateDrawing = translate rotateDrawing = rotate + +mvPointTowardAtSpeed :: Float -> Point2 -> Point2 -> Point2 +mvPointTowardAtSpeed speed !ep !p + | dist p ep < speed = ep + | otherwise = p +.+ speed *.* normalizeV (ep -.- p) + +mvPointToward :: Point2 -> Point2 -> Point2 +mvPointToward !ep !p | dist p ep < 1 = ep + | otherwise = p +.+ normalizeV (ep -.- p) + diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index a623fa5ec..67905bfd1 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -14,17 +14,17 @@ import Dodge.Data import Dodge.Base import Dodge.SoundLogic import Dodge.Prototypes + import Dodge.LevelGen.Block import Dodge.LevelGen.Pathing - import Dodge.LevelGen.StaticWalls +import Dodge.LevelGen.AutoDoor import Geometry import Picture import System.Random -import Control.DeepSeq (deepseq) import Control.Monad.State import Data.List @@ -293,9 +293,6 @@ triggerDoorPane c cond n [a,b] [a',b'] = Door changeZonedWall' (!x,!y) = over wallsZone $ adjustIMZone closeDoor x y n -addAutoDoor :: Point2 -> Point2 -> World -> World -addAutoDoor a b = over walls (autoDoorAt a b) - putWindowBlock :: Point2 -> Point2 -> World -> World putWindowBlock a b w = removePathsCrossing a b $ foldr makeBlockAt w $ zip ps ns where d = dist a b @@ -363,113 +360,7 @@ putWindowBlock a b w = removePathsCrossing a b $ foldr makeBlockAt w $ zip ps ns f = IM.insert k0 l . IM.insert k1 t . IM.insert k2 r . IM.insert k3 b in over walls f w -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 $ zipWith4 (autoDoorPane [pl,pr]) - xs - [ True - , False - , True - , True - , False - , True - ] - [ [pld,hwd,hw,pl] - , [hwd,hwu] - , [hwu,plu,pl,hw] - , [pru,hwu,hw,pr] - , [hwu,hwd] - , [hwd,prd,pr,hw] - ] - [ [plld,pld,pl,pl] - , [pld,plu] - , [plu,pllu,pl,pl] - , [prru,pru,pr,pr] - , [pru,prd] - , [prd,prrd,pr,pr] - ] - where norm = 15.1 *.* errorNormalizeV 49 ( vNormal (pr -.- pl)) - -- .1 hack, there was flickering - hw = 0.5 *.* (pl +.+ pr) - parallel = 20 *.* normalizeV (pl -.- pr) - plu = pl +.+ norm - pld = pl -.- norm - pru = pr +.+ norm - prd = pr -.- norm - hwu = hw +.+ norm - hwd = hw -.- norm - pllu = plu +.+ parallel - plld = pld +.+ parallel - prru = pru -.- parallel - prrd = prd -.- 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 - -mvPointTowardAtSpeed :: Float -> Point2 -> Point2 -> Point2 -mvPointTowardAtSpeed speed !ep !p - | dist p ep < speed = ep - | otherwise = p +.+ speed *.* normalizeV (ep -.- p) - -mvPointToward :: Point2 -> Point2 -> Point2 -mvPointToward !ep !p | dist p ep < 1 = ep - | otherwise = p +.+ normalizeV (ep -.- p) - -drawAutoDoor :: Wall -> Drawing -drawAutoDoor wl = onLayerL [levLayer WlLayer, layer2] - $ pictures [color c $ polygon [x,x +.+ n2,y +.+ n2, y] - ,color (dark c) $ line [x,y] - ] - where - (x:y:_) = _wlLine wl - c = _wlColor wl - nm = errorNormalizeV 543 (y -.- x) - t = 5 *.* nm - n = vNormal t - n2 = 3 *.* n - layer2 | _wlIsSeeThrough wl = 0 - | isJust $ wl ^? doorMech = 1 - | otherwise = 2 - -autoDoorPane :: [Point2] -> Int -> Bool -> [Point2] -> [Point2] -> Wall -autoDoorPane trigL n castShad closedPos openPos = AutoDoor - { _wlLine = closedPos - , _wlID = n - , _doorMech = dm - , _wlColor = dim $ yellow - , _wlDraw = Nothing - , _wlSeen = False - , _wlIsSeeThrough = False - , _wlCastShadow = castShad - } - 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 shiftPointBy (pos,rot) p = pos +.+ rotateV rot p diff --git a/src/Dodge/LevelGen/AutoDoor.hs b/src/Dodge/LevelGen/AutoDoor.hs new file mode 100644 index 000000000..1e978e43b --- /dev/null +++ b/src/Dodge/LevelGen/AutoDoor.hs @@ -0,0 +1,118 @@ +{-# 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 $ zipWith4 (autoDoorPane [pl,pr]) + xs + [ True + , False + , True + , True + , False + , True + ] + [ [pld,hwd,hw,pl] + , [hwd,hwu] + , [hwu,plu,pl,hw] + , [pru,hwu,hw,pr] + , [hwu,hwd] + , [hwd,prd,pr,hw] + ] + [ [plld,pld,pl,pl] + , [pld,plu] + , [plu,pllu,pl,pl] + , [prru,pru,pr,pr] + , [pru,prd] + , [prd,prrd,pr,pr] + ] + where norm = 15.1 *.* errorNormalizeV 49 ( vNormal (pr -.- pl)) + -- .1 hack, there was flickering + hw = 0.5 *.* (pl +.+ pr) + parallel = 20 *.* normalizeV (pl -.- pr) + plu = pl +.+ norm + pld = pl -.- norm + pru = pr +.+ norm + prd = pr -.- norm + hwu = hw +.+ norm + hwd = hw -.- norm + pllu = plu +.+ parallel + plld = pld +.+ parallel + prru = pru -.- parallel + prrd = prd -.- 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 + +drawAutoDoor :: Wall -> Drawing +drawAutoDoor wl = onLayerL [levLayer WlLayer, layer2] + $ pictures [color c $ polygon [x,x +.+ n2,y +.+ n2, y] + ,color (dark c) $ line [x,y] + ] + where + (x:y:_) = _wlLine wl + c = _wlColor wl + nm = errorNormalizeV 543 (y -.- x) + t = 5 *.* nm + n = vNormal t + n2 = 3 *.* n + layer2 | _wlIsSeeThrough wl = 0 + | isJust $ wl ^? doorMech = 1 + | otherwise = 2 + +autoDoorPane :: [Point2] -> Int -> Bool -> [Point2] -> [Point2] -> Wall +autoDoorPane trigL n castShad closedPos openPos = AutoDoor + { _wlLine = closedPos + , _wlID = n + , _doorMech = dm + , _wlColor = dim $ yellow + , _wlDraw = Nothing + , _wlSeen = False + , _wlIsSeeThrough = False + , _wlCastShadow = castShad + } + 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 diff --git a/src/Dodge/LevelGen/Pathing.hs b/src/Dodge/LevelGen/Pathing.hs new file mode 100644 index 000000000..46b44f7d0 --- /dev/null +++ b/src/Dodge/LevelGen/Pathing.hs @@ -0,0 +1,29 @@ +module Dodge.LevelGen.Pathing + where +import Geometry + +import Control.Lens + +import Dodge.Data +import Dodge.Base + +import Data.Maybe +import Data.List + +import qualified Data.IntMap as IM +import Data.Graph.Inductive hiding ((&)) +import Data.Graph.Inductive.NodeMap + +pairsToGraph :: (Ord a, Eq a, Eq b) => (a -> a -> b) -> [(a,a)] -> Gr a b +pairsToGraph f pairs = let nodes = nub (map fst pairs ++ map snd pairs) + pairs' = map (\(x,y)->(x,y,f x y)) pairs + in undir $ run_ Data.Graph.Inductive.empty $ insMapNodesM nodes >> insMapEdgesM pairs' + +removePathsCrossing :: Point2 -> Point2 -> World -> World +removePathsCrossing a b w = set pathGraph newGraph $ set pathGraph' pg' + $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph)) + w + where pg' = filter (not . isJust . uncurry (intersectSegSeg' a b)) $ _pathGraph' w + insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp] + newGraph = pairsToGraph dist pg' + diff --git a/src/Dodge/Rooms.hs b/src/Dodge/Rooms.hs index 14ab16370..f69f03b72 100644 --- a/src/Dodge/Rooms.hs +++ b/src/Dodge/Rooms.hs @@ -48,7 +48,7 @@ lev1 = do -- [randomiseLinks =<< pistolerRoom] [return $ return $ Right deadEndRoom ] - ++ [roomMiniIntro] + ++ [slowDoorRoom] ++ [return $ connectRoom corridor ,return $ connectRoom door] -- ++ [randomiseLinks =<< longRoom] @@ -711,7 +711,8 @@ slowDoorRoom = do xs' <- sequence $ replicate 5 $ state $ randomR (10,x-10) ys' <- sequence $ replicate 5 $ state $ randomR (h+20,y) let crits = zipWith (\p r -> PS p r randC1) ps rs - lsources = [PS (x/2,30) 0 basicLS, PS (x/2,y-30) 0 basicLS] + --lsources = [PS (x/2,30) 0 basicLS, PS (x/2,y-30) 0 basicLS] + lsources = [PS (x/2,y-30) 0 basicLS] let barrels = zipWith (\x y -> PS (x,y) 0 $ PutCrit explosiveBarrel) xs' ys' let pillarsa = [] let pillarsb = putBlockRect (x/5-20) (x/5+20) (h/2-20) (h/2+20) diff --git a/src/Dodge/Weapons.hs b/src/Dodge/Weapons.hs index af69b9197..11b5dd0fb 100644 --- a/src/Dodge/Weapons.hs +++ b/src/Dodge/Weapons.hs @@ -109,7 +109,7 @@ autoGun = defaultGun , _wpReloadTime = 80 , _wpReloadState = 0 -- , _wpFireRate = 6 - , _wpFireRate = 5 + , _wpFireRate = 6 , _wpFireState = 0 , _wpFire = autoFireMode , _wpSpread = autogunSpread @@ -383,7 +383,7 @@ hvAutoGun = autoGun , _wpReloadState = 0 , _wpFireRate = 25 , _wpFireState = 0 - , _wpFire = rateIncAB 24 12 (torqueBeforeForced 0.1 mkHvBul) + , _wpFire = rateIncAB 24 10 (torqueBeforeForced 0.1 mkHvBul) $torqueAfter 0.2 mkHvBul , _wpSpread = autogunSpread , _wpRange = 20