From e0570ed54c7bbde68187c79673f086a8b56cd379 Mon Sep 17 00:00:00 2001 From: jgk Date: Mon, 29 Mar 2021 02:42:59 +0200 Subject: [PATCH 1/5] Cleanup --- src/Dodge/LevelGen/StaticWalls.hs | 31 ++-- src/Geometry.hs | 233 +++++++++++++++++------------- 2 files changed, 146 insertions(+), 118 deletions(-) diff --git a/src/Dodge/LevelGen/StaticWalls.hs b/src/Dodge/LevelGen/StaticWalls.hs index e68aba06b..c31212278 100644 --- a/src/Dodge/LevelGen/StaticWalls.hs +++ b/src/Dodge/LevelGen/StaticWalls.hs @@ -22,15 +22,15 @@ type WallP = (Point2,Point2) cutWalls :: [Point2] -> [WallP] -> [WallP] cutWalls ps wls = case mapMaybe (flip checkWallRight newWalls) newWalls of [] -> newWalls - errs -> error $ "cutWalls: when cutting poly:\n" ++ show ps + errs -> error $ "during level generation function cutWalls: when cutting poly:\n" ++ show ps ++ "\nRight corner errors:\n" ++ unlines (map show errs) - ++ "\nStart walls:\n" - ++ unlines (map show wls) - ++ "\nEnd walls:\n" - ++ unlines (map show newWalls) ++ "\nLeft corner errors:\n" ++ unlines (map show errsL) + ++ "\nWalls before cut:\n" + ++ unlines (map show wls) + ++ "\nWalls after cut:\n" + ++ unlines (map show newWalls) where newWalls = cutWalls' ps wls errsL = mapMaybe (flip checkWallLeft newWalls) newWalls @@ -144,30 +144,27 @@ fusePoint ps p = fromMaybe p $ findClosePoint ps p -- if either wall point is not moved, this point gets added to the list fuseWall :: ([Point2], WallP) -> ([Point2], WallP) fuseWall (ps, (x,y)) = ( nub (x':y':ps) , (x',y') ) - where x' = fusePoint ps x - y' = fusePoint (x':ps) y + where + x' = fusePoint ps x + y' = fusePoint (x':ps) y -- given list of points and collection of walls, fuses the wall ends if -- they are close to the list of points or each other fuseWallsWith :: [Point2] -> [WallP] -> [WallP] fuseWallsWith zs ws = snd $ foldr fuseWalls' (zs, []) ws - where fuseWalls' w (ps, ws) = let (qs, w') = fuseWall (ps, w) - in (qs, w' : ws) + where + fuseWalls' w (ps, ws) = + let (qs, w') = fuseWall (ps, w) + in (qs, w' : ws) wallIsZeroLength (x,y) = x == y removeWallsInPolygon :: [Point2] -> [WallP] -> [WallP] removeWallsInPolygon ps walls = filter (not . cond) walls - where cond wall = pointInsidePolygon (fst wall) ps + where + cond wall = pointInsidePolygon (fst wall) ps && pointInsidePolygon (snd wall) ps -pointInsidePolygon :: Point2 -> [Point2] -> Bool -pointInsidePolygon p (x:xs) = all (\l -> not (uncurry isRHS l (p +.+ normalizeV s))) pairs - || any (\l -> uncurry isOnLine l p) pairs - where pairs = zip (x:xs) (xs ++ [x]) - s = ((1/fromIntegral (length (x:xs))) *.* (foldr1 (+.+) (x:xs))) - -.- p - ------------------------------------------------------------------------------------ -- idea: create inner walls to draw and to cast shadows createInnerWalls :: IM.IntMap Wall -> IM.IntMap Wall diff --git a/src/Geometry.hs b/src/Geometry.hs index 0c0daac0d..af5147c2b 100644 --- a/src/Geometry.hs +++ b/src/Geometry.hs @@ -20,139 +20,154 @@ import Control.Applicative -- TODO add bang patterns alongLineBy :: Float -> Point2 -> Point2 -> Point2 -alongLineBy x a b = a +.+ y *.* normalizeV (b -.- a) +alongLineBy !x !a !b = a +.+ y *.* normalizeV (b -.- a) where y = min x $ dist a b closestPointOnLine :: Point2 -> Point2 -> Point2 -> Point2 {-# INLINE closestPointOnLine #-} -closestPointOnLine a b p - = a +.+ u *.* (b -.- a) - where u = closestPointOnLineParam a b p +closestPointOnLine !a !b !p = a +.+ u *.* (b -.- a) + where u = closestPointOnLineParam a b p closestPointOnLineParam :: Point2 -> Point2 -> Point2 -> Float {-# INLINE closestPointOnLineParam #-} -closestPointOnLineParam a b p +closestPointOnLineParam !a !b !p = (p -.- a) `dotV` (b -.- a) / (b -.- a) `dotV` (b -.- a) -- the following helper draws a rectangle based on maximal N E S W values rectNESW :: Float -> Float -> Float -> Float -> [Point2] -rectNESW a b c d = [(b,a),(b,c),(d,c),(d,a) - ] +rectNESW !a !b !c !d = [(b,a),(b,c),(d,c),(d,a) ] + rectNSEW :: Float -> Float -> Float -> Float -> [Point2] -rectNSEW n s e w = rectNESW n e s w +rectNSEW !n !s !e !w = rectNESW n e s w rectNSWE :: Float -> Float -> Float -> Float -> [Point2] -rectNSWE n s w e = [ (w,n), (w,s), (e,s), (e,n)] +rectNSWE !n !s !w !e = [ (w,n), (w,s), (e,s), (e,n)] -- -- the following filters points in a polygon: supposes the points in the -- polygon are listed in anticlockwise order pointInOrOnPolygon :: Point2 -> [Point2] -> Bool -pointInOrOnPolygon p (x:xs) = all (\l -> not (uncurry isRHS l p)) $ zip (x:xs) (xs ++ [x]) +pointInOrOnPolygon !p (x:xs) = all (\l -> not (uncurry isRHS l p)) $ zip (x:xs) (xs ++ [x]) pointInPolygon :: Point2 -> [Point2] -> Bool -pointInPolygon p [] = False -pointInPolygon p (x:xs) = all (\l -> uncurry (errorIsLHS 1) l p) $ zip (x:xs) (xs ++ [x]) +pointInPolygon !p [] = False +pointInPolygon !p (x:xs) = all (\l -> uncurry (errorIsLHS 1) l p) $ zip (x:xs) (xs ++ [x]) + +pointInsidePolygon :: Point2 -> [Point2] -> Bool +pointInsidePolygon !p (x:xs) = all (\l -> not (uncurry isRHS l (p +.+ normalizeV s))) pairs + || any (\l -> uncurry isOnLine l p) pairs + where + pairs = zip (x:xs) (xs ++ [x]) + s = ((1/fromIntegral (length (x:xs))) *.* (foldr1 (+.+) (x:xs))) -.- p + errorPointInPolygon :: Int -> Point2 -> [Point2] -> Bool -errorPointInPolygon i p xs | length xs == 1 = error "one point polygon" - | length xs == 2 = error "two point polygon" - | nub xs == xs = pointInPolygon p xs - | otherwise = error $ "errorPointInPolygon "++ show i +errorPointInPolygon !i !p xs + | length xs == 1 = error "one point polygon" + | length xs == 2 = error "two point polygon" + | nub xs == xs = pointInPolygon p xs + | otherwise = error $ "errorPointInPolygon "++ show i errorNormalizeV :: Int -> Point2 -> Point2 -errorNormalizeV i (0,0) = error $ "problem with function: errorNormalizeV "++show i -errorNormalizeV i p = normalizeV p +errorNormalizeV !i !(0,0) = error $ "problem with function: errorNormalizeV "++show i +errorNormalizeV !i !p = normalizeV p errorAngleVV :: Int -> Point2 -> Point2 -> Float -errorAngleVV i (0,0) _ = error $ "problem with function: errorAngleVV "++show i -errorAngleVV i _ (0,0) = error $ "problem with function: errorAngleVV "++show i -errorAngleVV i p p' = angleVV p p' +errorAngleVV !i !(0,0) _ = error $ "problem with function: errorAngleVV "++show i +errorAngleVV !i _ !(0,0) = error $ "problem with function: errorAngleVV "++show i +errorAngleVV !i !p !p' = angleVV p p' errorIsLHS :: Int -> Point2 -> Point2 -> Point2 -> Bool -errorIsLHS i x y | x == y = error $ "problem with function: errorIsLHS " - ++show i - | otherwise = isLHS x y +errorIsLHS !i !x !y + | x == y = error $ "problem with function: errorIsLHS " ++show i + | otherwise = isLHS x y errorClosestPointOnLine :: Int -> Point2 -> Point2 -> Point2 -> Point2 -errorClosestPointOnLine i x y | x == y = error $ "problem with function: errorClosestPointOnLine " - ++show i - | otherwise = closestPointOnLine x y +errorClosestPointOnLine !i !x !y + | x == y = error $ "problem with function: errorClosestPointOnLine " ++show i + | otherwise = closestPointOnLine x y errorClosestPointOnLineParam :: Int -> Point2 -> Point2 -> Point2 -> Float -errorClosestPointOnLineParam i x y z | x == y = dist x z --- error $ "problem with function: errorClosestPointOnLineParam " ++show i - | otherwise = closestPointOnLineParam x y z +errorClosestPointOnLineParam !i !x! y! z + | x == y = dist x z + | otherwise = closestPointOnLineParam x y z safeNormalizeV :: Point2 -> Point2 -safeNormalizeV (0,0) = (0,0) -safeNormalizeV p = normalizeV p +safeNormalizeV !(0,0) = (0,0) +safeNormalizeV !p = normalizeV p -- tests whether a point is on the LHS of a line -- this has been called somewhere with l1 == l2 isLHS :: Point2 -> Point2 -> Point2 -> Bool {-# INLINE isLHS #-} isLHS' :: (Float, Float) -> (Float, Float) -> Point2 -> Bool -isLHS' l1 l2 p | l1 == l2 = False - | otherwise = closestPointOnLineParam l1 (l1 +.+ vNormal (l2 -.- l1)) p < 0 +isLHS' !l1 !l2 !p + | l1 == l2 = False + | otherwise = closestPointOnLineParam l1 (l1 +.+ vNormal (l2 -.- l1)) p < 0 -isLHS (x,y) (x',y') (x'',y'') +isLHS !(x,y) !(x',y') !(x'',y'') | (x,y) == (x',y') = False | otherwise = a1 * b2 - a2 * b1 > 0 - where a1 = x' - x - a2 = y' - y - b1 = x'' - x - b2 = y'' - y + where + a1 = x' - x + a2 = y' - y + b1 = x'' - x + b2 = y'' - y isRHS :: Point2 -> Point2 -> Point2 -> Bool {-# INLINE isRHS #-} -isRHS (x,y) (x',y') (x'',y'') +isRHS !(x,y) !(x',y') !(x'',y'') | (x,y) == (x',y') = False | otherwise = a1 * b2 - a2 * b1 < 0 - where a1 = x' - x - a2 = y' - y - b1 = x'' - x - b2 = y'' - y ---isRHS l1 l2 p = closestPointOnLineParam l1 (l1 +.+ vNormal (l2 -.- l1)) p > 0 + where + a1 = x' - x + a2 = y' - y + b1 = x'' - x + b2 = y'' - y -- reorders points to be anticlockwise around their center orderPolygon :: [Point2] -> [Point2] orderPolygon [] = [] orderPolygon ps = sortBy (compare `on` \p -> argV (p -.- cen)) ps - where cen = 1/ fromIntegral (length ps) *.* foldr1 (+.+) ps + where + cen = 1/ fromIntegral (length ps) *.* foldr1 (+.+) ps dist :: Point2 -> Point2 -> Float {-# INLINE dist #-} -dist p1 p2 = magV (p2 -.- p1) +dist !p1 !p2 = magV (p2 -.- p1) pHalf :: Point2 -> Point2 -> Point2 -pHalf a b = 0.5 *.* (a +.+ b) +pHalf !a !b = 0.5 *.* (a +.+ b) circOnLine' :: Point2 -> Point2 -> Point2 -> Float -> Bool -circOnLine' p1 p2 c rad = isJustTrue (fmap (\p -> magV (p -.- c) < rad) y) - where y = intersectSegLine' p1 p2 c (c +.+ vNormal (p1 -.- p2)) - isJustTrue (Just True) = True - isJustTrue _ = False +circOnLine' !p1 !p2 !c !rad = isJustTrue (fmap (\p -> magV (p -.- c) < rad) y) + where + y = intersectSegLine' p1 p2 c (c +.+ vNormal (p1 -.- p2)) + isJustTrue (Just True) = True + isJustTrue _ = False circOnLine :: Point2 -> Point2 -> Point2 -> Float -> Bool -circOnLine p1 p2 c rad = magV (p1 -.- c) <= rad || magV (p2 -.- c) <= rad +circOnLine !p1 !p2 !c !rad = magV (p1 -.- c) <= rad || magV (p2 -.- c) <= rad || isJustTrue (fmap (\p -> magV (p -.- c) < rad) y) - where y = intersectSegLine' p1 p2 c (c +.+ vNormal (p1 -.- p2)) - isJustTrue (Just True) = True - isJustTrue _ = False + where + y = intersectSegLine' p1 p2 c (c +.+ vNormal (p1 -.- p2)) + isJustTrue (Just True) = True + isJustTrue _ = False difference :: (Ord a, Num a) => a -> a -> a -difference x y | x > y = x - y - | otherwise = y - x +difference x y + | x > y = x - y + | otherwise = y - x reflectIn :: Point2 -> Point2 -> Point2 -reflectIn line vec = let angle = 2 * angleBetween line vec - in rotateV angle vec +reflectIn line vec = + let angle = 2 * angleBetween line vec + in rotateV angle vec angleBetween :: Point2 -> Point2 -> Float angleBetween v1 v2 = argV v1 - argV v2 @@ -163,8 +178,10 @@ doublePair (x,y) = [(x,y),(y,x)] polysIntersect :: [Point2] -> [Point2] -> Bool polysIntersect (p:ps) (q:qs) = any isJust $ (\(a,b) (c,d) -> myIntersectSegSeg a b c d) <$> pairs1 <*> pairs2 - where pairs1 = zip (p:ps) (ps++[p]) - pairs2 = zip (q:qs) (qs++[q]) + where + pairs1 = zip (p:ps) (ps++[p]) + pairs2 = zip (q:qs) (qs++[q]) + polysIntersect [] _ = False polysIntersect _ [] = False @@ -178,22 +195,24 @@ nRaysRad :: Int -> Float -> [Point2] nRaysRad n x = take n $ iterate (rotateV (2*pi/fromIntegral n)) (x,0) -- angles go from 0 to 2pi, need to work out what is left of another - isLeftOfA :: Float -> Float -> Bool -isLeftOfA angle1 angle2 = (angle1 - angle2 < pi && angle1 > angle2) - || (angle2 - angle1 > pi && angle2 > angle1) +isLeftOfA angle1 angle2 = + (angle1 - angle2 < pi && angle1 > angle2) + || (angle2 - angle1 > pi && angle2 > angle1) isLeftOf :: Point2 -> Point2 -> Bool isLeftOf x y = isLeftOfA (argV x) (argV y) -- diffAngles has an issue... - diffAngles :: Float -> Float -> Float -diffAngles x y | diff > pi = diffAngles (x - 2*pi) y - | diff >= 0 = diff - | diff > -pi = -diff - | otherwise = diffAngles (x + 2*pi) y - where diff = x-y +diffAngles x y + | diff > pi = diffAngles (x - 2*pi) y + | diff >= 0 = diff + | diff > -pi = -diff + | otherwise = diffAngles (x + 2*pi) y + where + diff = x-y + differenceAngles = diffAngles angleDifference = diffAngles @@ -205,9 +224,10 @@ ssaTri :: Float -> Float -> Float -> Float ssaTri ab bc a | sin a == 0 = 0 | bc == 0 = ab - | otherwise = let c = asin ( (ab * sin a)/bc) - b = pi - (a + c) - in sin b * bc / sin a + | otherwise = + let c = asin ( (ab * sin a)/bc) + b = pi - (a + c) + in sin b * bc / sin a -- fix points: we now fix the triangle in the coordinate system, and return a -- third unknown point: @@ -233,8 +253,9 @@ ssaTriPointCorrect :: Point2 -> Point2 -> Point2 -> Float -> Maybe Point2 ssaTriPointCorrect pa pb pc' bc | param <= 1 && param >= 0 = Just p | otherwise = Nothing - where p = ssaTriPoint pa pb pc' bc - param = closestPointOnLineParam pa pc' p + where + p = ssaTriPoint pa pb pc' bc + param = closestPointOnLineParam pa pc' p closestPointOnSeg :: Point2 -> Point2 -> Point2 -> Point2 @@ -244,9 +265,10 @@ closestPointOnSeg segP1 segP2 p | otherwise = errorClosestPointOnLine 2 segP1 segP2 p pointInCircle :: Point2 -> Float -> Point2 -> Maybe Point2 -pointInCircle p r c | p == c = Just p - | magV (p -.- c) < r = Just p - | otherwise = Nothing +pointInCircle p r c + | p == c = Just p + | magV (p -.- c) < r = Just p + | otherwise = Nothing --determines if a moving point intersects with a circle, --if so, returns a point on circle that intersects with the line passing @@ -272,34 +294,39 @@ collidePointCircCorrect p1 p2 rad c = ssaTriPointCorrect p2 c p1 rad -- finds the height of a triangle using herons formula -- the base is the line between the first two points heron :: Point2 -> Point2 -> Point2 -> Float -heron x y z | x == y = 0 - | otherwise = let a = magV $ x -.- y - b = magV $ y -.- z - c = magV $ z -.- x - s = (a+b+c)/2 - area = sqrt(s*(s-a)*(s-b)*(s-c)) - in 2*area/a +heron x y z + | x == y = 0 + | otherwise = + let a = magV $ x -.- y + b = magV $ y -.- z + c = magV $ z -.- x + s = (a+b+c)/2 + area = sqrt(s*(s-a)*(s-b)*(s-c)) + in 2*area/a -- multiplies reflection in normal by factor reflectInParam :: Float -> Point2 -> Point2 -> Point2 -reflectInParam x line vec = let angle = 2 * angleBetween line vec - rAng = rotateV angle vec - p = x *.* errorClosestPointOnLine 3 (0,0) (vNormal line) rAng - in rAng -.- p +reflectInParam x line vec = + let angle = 2 * angleBetween line vec + rAng = rotateV angle vec + p = x *.* errorClosestPointOnLine 3 (0,0) (vNormal line) rAng + in rAng -.- p reflectIn' :: Point2 -> Point2 -> Point2 -> Point2 -> Point2 reflectIn' l1 l2 v1 v2 = v1 +.+ reflectIn (l1 -.- l2) (v2 -.- v1) isOnLine :: Point2 -> Point2 -> Point2 -> Bool -isOnLine l1 l2 p = errorClosestPointOnLineParam 10 l1 (l1 +.+ vNormal (l2 -.- l1)) p == 0 - && errorClosestPointOnLineParam 11 l1 l2 p <= 1 - && errorClosestPointOnLineParam 12 l1 l2 p >= 0 +isOnLine l1 l2 p = + errorClosestPointOnLineParam 10 l1 (l1 +.+ vNormal (l2 -.- l1)) p == 0 + && errorClosestPointOnLineParam 11 l1 l2 p <= 1 + && errorClosestPointOnLineParam 12 l1 l2 p >= 0 -- the take 5000 here is a hack, otherwise divideLine seems to sometimes -- generate an infinite list, and I don't know why divideLine :: Float -> Point2 -> Point2 -> [Point2] --divideLine x a b = map (\i -> a +.+ (i / (fromIntegral numPoints)) *.* (b -.- a)) -divideLine x a b = take 5000 +divideLine x a b = + take 5000 $ map (\i -> a +.+ (fromIntegral i / fromIntegral numPoints *.* (b -.- a)) ) ns where @@ -335,11 +362,12 @@ bresenham pa@(xa,ya) pb@(xb,yb) = map maySwitch . unfoldr go $ (x1,y1,0) go (xTemp, yTemp, error) | xTemp > x2 = Nothing | otherwise = Just ((xTemp, yTemp), (xTemp + 1, newY, newError)) - where + where tempError = error + deltay - (newY, newError) = if (2*tempError) >= deltax - then (yTemp+ystep,tempError-deltax) - else (yTemp,tempError) + (newY, newError) = + if (2*tempError) >= deltax + then (yTemp+ystep,tempError-deltax) + else (yTemp,tempError) digitalLine :: (Int,Int) -> (Int,Int) -> [(Int,Int)] digitalLine (x1,y1) (x2,y2) @@ -364,9 +392,12 @@ nPointsOnCirc :: Int -> Float -> [Point2] nPointsOnCirc n rad = take n $ iterate (rotateV (2*pi/fromIntegral n)) (rad,0) lineInPolygon :: Point2 -> Point2 -> [Point2] -> Bool -lineInPolygon a b ps = pointInPolygon a ps || pointInPolygon b ps - || any (isJust . uncurry (intersectSegSeg' a b)) pss - where pss = zip ps (tail ps ++ [head ps]) +lineInPolygon a b ps = + pointInPolygon a ps + || pointInPolygon b ps + || any (isJust . uncurry (intersectSegSeg' a b)) pss + where + pss = zip ps (tail ps ++ [head ps]) makeLoopPairs :: [Point2] -> [(Point2,Point2)] makeLoopPairs [] = error "tried to make loop with empty list of points" From c959b7d59c842acaf08fe24367f524e6688eb3ab Mon Sep 17 00:00:00 2001 From: jgk Date: Mon, 29 Mar 2021 11:27:30 +0200 Subject: [PATCH 2/5] Runtime broken level generation --- src/Dodge/Data.hs | 26 +- src/Dodge/Debug.hs | 69 +-- src/Dodge/Default.hs | 12 +- src/Dodge/Item/Weapon.hs | 583 +++++++++++++------------- src/Dodge/Rendering.hs | 2 +- src/Dodge/Room/Data.hs | 1 + src/Dodge/Rooms.hs | 12 +- src/Dodge/Update.hs | 2 +- src/Dodge/WorldEvent/SpawnParticle.hs | 18 +- 9 files changed, 356 insertions(+), 369 deletions(-) diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 4269e558f..39ba76d6f 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -479,21 +479,21 @@ type HitEffect = Particle' -> [(Point2, (Either3 Creature Wall ForceField))] -> data Projectile = Projectile - { _ptPos :: Point2 - , _ptStartPos :: Point2 - , _ptVel :: Point2 - , _ptPict :: Picture - , _ptID :: Int - , _ptUpdate :: World -> World + { _pjPos :: Point2 + , _pjStartPos :: Point2 + , _pjVel :: Point2 + , _pjPict :: Picture + , _pjID :: Int + , _pjUpdate :: World -> World } | Shell - { _ptPos :: Point2 - , _ptStartPos :: Point2 - , _ptVel :: Point2 - , _ptPict :: Picture - , _ptID :: Int - , _ptUpdate :: World -> World - , _ptExplosion :: Point2-> World -> World + { _pjPos :: Point2 + , _pjStartPos :: Point2 + , _pjVel :: Point2 + , _pjPict :: Picture + , _pjID :: Int + , _pjUpdate :: World -> World + , _pjPayload :: Point2-> World -> World } data DamageType diff --git a/src/Dodge/Debug.hs b/src/Dodge/Debug.hs index 5ec296c47..17abdbf4c 100644 --- a/src/Dodge/Debug.hs +++ b/src/Dodge/Debug.hs @@ -12,39 +12,42 @@ import Control.Lens import qualified Data.IntMap.Strict as IM drawCircleAtFor :: Point2 -> Int -> World -> World -drawCircleAtFor p t w = - let n = newProjectileKey w - in over projectiles ( IM.insert n - Projectile { _ptPos = p - , _ptStartPos = p - , _ptVel = (0,0) - , _ptPict = onLayer PtLayer $ uncurry translate p $ color white $ circleSolid 20 - , _ptID = n - , _ptUpdate = ptTimer t n - } ) w +drawCircleAtFor p t w = w & projectiles %~ + IM.insert k Projectile + { _pjPos = p + , _pjStartPos = p + , _pjVel = (0,0) + , _pjPict = onLayer PtLayer $ uncurry translate p $ color white $ circleSolid 20 + , _pjID = k + , _pjUpdate = pjTimer t k + } + where + k = newKey $ _projectiles w drawCircleAtForCol :: Point2 -> Int -> Color -> World -> World -drawCircleAtForCol p t col w = - let n = newProjectileKey w - in over projectiles ( IM.insert n - Projectile { _ptPos = p - , _ptStartPos = p - , _ptVel = (0,0) - , _ptPict = onLayer PtLayer $ uncurry translate p $ color col $ circleSolid 20 - , _ptID = n - , _ptUpdate = ptTimer t n - } ) w +drawCircleAtForCol p t col w = w & projectiles %~ + IM.insert k Projectile + { _pjPos = p + , _pjStartPos = p + , _pjVel = (0,0) + , _pjPict = onLayer PtLayer $ uncurry translate p $ color col $ circleSolid 20 + , _pjID = k + , _pjUpdate = pjTimer t k + } + where + k = newKey $ _projectiles w drawLineForCol :: [Point2] -> Int -> Color -> World -> World -drawLineForCol ps t col w = - let n = newProjectileKey w - in over projectiles ( IM.insert n - Projectile { _ptPos = head ps - , _ptStartPos = head ps - , _ptVel = (0,0) - , _ptPict = onLayer PtLayer $ color col $ lineOfThickness 5 ps - , _ptID = n - , _ptUpdate = ptTimer t n - } ) w +drawLineForCol ps t col w = w & projectiles %~ + IM.insert k Projectile + { _pjPos = head ps + , _pjStartPos = head ps + , _pjVel = (0,0) + , _pjPict = onLayer PtLayer $ color col $ lineOfThickness 5 ps + , _pjID = k + , _pjUpdate = pjTimer t k + } + where + k = newKey $ _projectiles w -ptTimer :: Int -> Int -> World -> World -ptTimer 0 i = over projectiles (IM.delete i) -ptTimer time i = set (projectiles . ix i . ptUpdate) $ ptTimer (time - 1) i +pjTimer :: Int -> Int -> World -> World +pjTimer 0 i = projectiles %~ IM.delete i +pjTimer time i = projectiles . ix i . pjUpdate .~ pjTimer (time - 1) i diff --git a/src/Dodge/Default.hs b/src/Dodge/Default.hs index 027e44db6..10b2ed9c8 100644 --- a/src/Dodge/Default.hs +++ b/src/Dodge/Default.hs @@ -161,12 +161,12 @@ defaultButton = Button , _btState = BtOff } defaultPT = Projectile - { _ptPos = (0,0) - , _ptStartPos = (0,0) - , _ptVel = (0,0) - , _ptPict = blank - , _ptID = 0 - , _ptUpdate = id + { _pjPos = (0,0) + , _pjStartPos = (0,0) + , _pjVel = (0,0) + , _pjPict = blank + , _pjID = 0 + , _pjUpdate = id } defaultPP = PressPlate { _ppPict = onLayer PressPlateLayer $ color (dim $ dim $ bright $ blue) $ circleSolid 5 diff --git a/src/Dodge/Item/Weapon.hs b/src/Dodge/Item/Weapon.hs index 090f6489c..1cb76928c 100644 --- a/src/Dodge/Item/Weapon.hs +++ b/src/Dodge/Item/Weapon.hs @@ -732,121 +732,121 @@ aRocket = aRocket' makeShellAt makeShellAt :: Int -> Int -> Point2 -> Float -> Projectile makeShellAt i cid pos dir = Shell - { _ptPos = pos - , _ptStartPos = pos - , _ptVel = rotateV dir (1,0) - , _ptPict = blank -- onLayer PtLayer $ uncurry translate pos $ rotate (radToDeg dir) shellPic - , _ptID = i - , _ptUpdate = moveShell 50 i cid 0 (rotateV dir (2,0)) - , _ptExplosion = shellExplosionAt + { _pjPos = pos + , _pjStartPos = pos + , _pjVel = rotateV dir (1,0) + , _pjPict = blank -- onLayer PtLayer $ uncurry translate pos $ rotate (radToDeg dir) shellPic + , _pjID = i + , _pjUpdate = moveShell 50 i cid 0 (rotateV dir (2,0)) + , _pjPayload = shellExplosionAt } makeFlameShellAt :: Int -> Int -> Point2 -> Float -> Projectile makeFlameShellAt i cid pos dir = Shell - { _ptPos = pos - , _ptStartPos = pos - , _ptVel = rotateV dir (1,0) - , _ptPict = blank -- onLayer PtLayer $ uncurry translate pos $ rotate (radToDeg dir) shellPic - , _ptID = i - , _ptUpdate = moveShell 50 i cid 0 (rotateV dir (2,0)) - , _ptExplosion = makeFlameExplosionAt + { _pjPos = pos + , _pjStartPos = pos + , _pjVel = rotateV dir (1,0) + , _pjPict = blank -- onLayer PtLayer $ uncurry translate pos $ rotate (radToDeg dir) shellPic + , _pjID = i + , _pjUpdate = moveShell 50 i cid 0 (rotateV dir (2,0)) + , _pjPayload = makeFlameExplosionAt } makePoisonShellAt :: Int -> Int -> Point2 -> Float -> Projectile makePoisonShellAt i cid pos dir = Shell - { _ptPos = pos - , _ptStartPos = pos - , _ptVel = rotateV dir (1,0) - , _ptPict = blank -- onLayer PtLayer $ uncurry translate pos $ rotate (radToDeg dir) shellPic - , _ptID = i - , _ptUpdate = moveShell 50 i cid 0 (rotateV dir (2,0)) - , _ptExplosion = makePoisonExplosionAt + { _pjPos = pos + , _pjStartPos = pos + , _pjVel = rotateV dir (1,0) + , _pjPict = blank -- onLayer PtLayer $ uncurry translate pos $ rotate (radToDeg dir) shellPic + , _pjID = i + , _pjUpdate = moveShell 50 i cid 0 (rotateV dir (2,0)) + , _pjPayload = makePoisonExplosionAt } makeTeslaShellAt :: Int -> Int -> Point2 -> Float -> Projectile makeTeslaShellAt i cid pos dir = Shell - { _ptPos = pos - , _ptStartPos = pos - , _ptVel = rotateV dir (1,0) - , _ptPict = blank -- onLayer PtLayer $ uncurry translate pos $ rotate (radToDeg dir) shellPic - , _ptID = i - , _ptUpdate = moveShell 50 i cid 0 (rotateV dir (2,0)) - , _ptExplosion = makeTeslaExplosionAt + { _pjPos = pos + , _pjStartPos = pos + , _pjVel = rotateV dir (1,0) + , _pjPict = blank -- onLayer PtLayer $ uncurry translate pos $ rotate (radToDeg dir) shellPic + , _pjID = i + , _pjUpdate = moveShell 50 i cid 0 (rotateV dir (2,0)) + , _pjPayload = makeTeslaExplosionAt } moveShell :: Int -> Int -> Int -> Float -> Point2 -> World -> World moveShell time i cid rot accel w | time > 40 = if circOnSomeWall oldPos 4 w - then projectileExplosion oldPos $ over projectiles (IM.delete i) w - else over (projectiles . ix i . ptPos) (+.+ vel) - $ set (projectiles . ix i . ptPict) piclow - $ set (projectiles . ix i . ptUpdate) - (moveShell (time-1) i cid rot (rotateV rot accel)) - w + then projectileExplosion oldPos $ over projectiles (IM.delete i) w + else over (projectiles . ix i . pjPos) (+.+ vel) + $ set (projectiles . ix i . pjPict) piclow + $ set (projectiles . ix i . pjUpdate) + (moveShell (time-1) i cid rot (rotateV rot accel)) + w | time == 35 = case thingHit of - Just p -> projectileExplosion oldPos - $ over projectiles (IM.delete i) w - Nothing -> over (projectiles . ix i . ptPos) (+.+ vel) - $ set (projectiles . ix i . ptPict) pic - $ set (projectiles . ix i . ptUpdate) - (moveShell (time-1) i cid spin accel) - w + Just p -> projectileExplosion oldPos + $ over projectiles (IM.delete i) w + Nothing -> over (projectiles . ix i . pjPos) (+.+ vel) + $ set (projectiles . ix i . pjPict) pic + $ set (projectiles . ix i . pjUpdate) + (moveShell (time-1) i cid spin accel) + w | time >= 20 = case thingHit of - Just p -> projectileExplosion oldPos - $ over projectiles (IM.delete i) w - Nothing -> over (projectiles . ix i . ptPos) (+.+ vel) - $ set (projectiles . ix i . ptPict) pic - $ set (projectiles . ix i . ptUpdate) - (moveShell (time-1) i cid rot (rotateV rot accel)) - w - | time > -99 - = case thingHit of - Just p -> projectileExplosion oldPos - $ stopSoundFrom (ShellSound i) - $ over projectiles (IM.delete i) w - Nothing -> over (projectiles . ix i . ptPos) (+.+ vel) - $ set randGen g - $ set (projectiles . ix i . ptPict) pic - $ set (projectiles . ix i . ptUpdate) - (moveShell (time-1) i cid rot (rotateV rot accel)) - $ over (projectiles . ix i . ptVel) (\v -> accel +.+ frict *.* v) - $ soundFrom (ShellSound i) (fromIntegral smokeTrailSound) (1) 250 - $ makeFlameletTimed oldPos - (0.5 *.* rotateV (pi+sparkD) accel) Nothing 3 10 - $ smokeGen - w + Just p -> projectileExplosion oldPos + $ over projectiles (IM.delete i) w + Nothing -> over (projectiles . ix i . pjPos) (+.+ vel) + $ set (projectiles . ix i . pjPict) pic + $ set (projectiles . ix i . pjUpdate) + (moveShell (time-1) i cid rot (rotateV rot accel)) + w + | time > -99 = case thingHit of + Just p -> projectileExplosion oldPos + $ stopSoundFrom (ShellSound i) + $ over projectiles (IM.delete i) w + Nothing -> over (projectiles . ix i . pjPos) (+.+ vel) + $ set randGen g + $ set (projectiles . ix i . pjPict) pic + $ set (projectiles . ix i . pjUpdate) + (moveShell (time-1) i cid rot (rotateV rot accel)) + $ over (projectiles . ix i . pjVel) (\v -> accel +.+ frict *.* v) + $ soundFrom (ShellSound i) (fromIntegral smokeTrailSound) (1) 250 + $ makeFlameletTimed oldPos + (0.5 *.* rotateV (pi+sparkD) accel) Nothing 3 10 + $ smokeGen + w | time > -200 = case thingHit of - Just p -> projectileExplosion oldPos - $ stopSoundFrom (ShellSound i) - $ over projectiles (IM.delete i) w - Nothing -> over (projectiles . ix i . ptPos) (+.+ vel) - $ set (projectiles . ix i . ptPict) pic - $ set (projectiles . ix i . ptUpdate) - (moveShell (time-1) i cid rot (rotateV rot accel)) - w + Just p -> projectileExplosion oldPos + $ stopSoundFrom (ShellSound i) + $ over projectiles (IM.delete i) w + Nothing -> over (projectiles . ix i . pjPos) (+.+ vel) + $ set (projectiles . ix i . pjPict) pic + $ set (projectiles . ix i . pjUpdate) + (moveShell (time-1) i cid rot (rotateV rot accel)) + w | otherwise = projectileExplosion oldPos $ stopSoundFrom (ShellSound i) $ over projectiles (IM.delete i) w - where pt = _projectiles w IM.! i - oldPos = _ptPos pt - vel = _ptVel pt - projectileExplosion = _ptExplosion pt - newPos = oldPos +.+ vel - (frict,g) = randomR (0.6,0.9) $ _randGen w - (sparkD,_) = randomR (-0.5,0.5) $ _randGen w - dir = argV $ vel - pic = onLayer PtLayer $ uncurry translate newPos $ rotate (argV accel) shellPic - piclow = onLayerL [levLayer CrLayer - 2] - $ uncurry translate newPos $ rotate (argV accel) shellPic - hitCr = fmap fst $ collideCircCrsPoint oldPos newPos 4 w - hitWl = fmap fst $ collideCircWalls' oldPos newPos 2 $ wallsNearPoint newPos w - thingHit = hitCr <|> hitWl - spin = case w ^? creatures . ix cid of - Just cr -> min 0.1 $ max (-0.1) - $ (normalizeAnglePi (dir - _crDir cr)) / 20 - _ -> 0 - r1 = _randGen w & evalState (randInCirc 10) - smokeGen = makeSmokeCloudAt (oldPos +.+ r1 +.+ 30 *.* (normalizeV (oldPos -.- newPos))) + where + pj = _projectiles w IM.! i + oldPos = _pjPos pj + vel = _pjVel pj + projectileExplosion = _pjPayload pj + newPos = oldPos +.+ vel + (frict,g) = randomR (0.6,0.9) $ _randGen w + (sparkD,_) = randomR (-0.5,0.5) $ _randGen w + dir = argV $ vel + pic = onLayer PtLayer $ uncurry translate newPos $ rotate (argV accel) shellPic + piclow = onLayerL [levLayer CrLayer - 2] + $ uncurry translate newPos $ rotate (argV accel) shellPic + hitCr = fmap fst $ collideCircCrsPoint oldPos newPos 4 w + hitWl = fmap fst $ collideCircWalls' oldPos newPos 2 $ wallsNearPoint newPos w + thingHit = hitCr <|> hitWl + spin = case w ^? creatures . ix cid of + Just cr -> min 0.1 $ max (-0.1) + $ (normalizeAnglePi (dir - _crDir cr)) / 20 + _ -> 0 + r1 = _randGen w & evalState (randInCirc 10) + smokeGen = makeSmokeCloudAt (oldPos +.+ r1 +.+ 30 *.* (normalizeV (oldPos -.- newPos))) normalizeAnglePi angle | normalizeAngle angle > pi = normalizeAngle angle - 2*pi @@ -865,15 +865,16 @@ shellExplosionAt = makeExplosionAt tractorBeamAt :: Int -> Int -> Point2 -> Float -> Projectile tractorBeamAt colID i pos dir = Projectile - { _ptPos = pos - , _ptStartPos = p' - , _ptVel = d - , _ptPict = blank - , _ptID = i - , _ptUpdate = updateTractor colID 10 i + { _pjPos = pos + , _pjStartPos = p' + , _pjVel = d + , _pjPict = blank + , _pjID = i + , _pjUpdate = updateTractor colID 10 i } - where d = unitVectorAtAngle dir - p' = pos +.+ 400 *.* d + where + d = unitVectorAtAngle dir + p' = pos +.+ 400 *.* d aGasCloud :: Int -> World -> World aGasCloud cid w @@ -925,74 +926,74 @@ reflect a b = a + 2*(a-b) moveGrenade :: Int -> Float -> Int -> World -> World moveGrenade 0 dir pID w = over projectiles (IM.delete pID) - $ explosion (_ptPos (_projectiles w IM.! pID)) + $ explosion (_pjPos (_projectiles w IM.! pID)) -- $ set (pointToItem (_itemPositions w IM.! wpID) . itEquipPict) -- (drawWeapon $ grenadePic 50) w - where - pt = _projectiles w IM.! pID - explosion = _ptExplosion pt + where + pj = _projectiles w IM.! pID + explosion = _pjPayload pj moveGrenade time dir pID w = case hitWl of Just _ -> soundOnce (fromIntegral tapQuiet) updatedWorld _ -> updatedWorld - where - updatedWorld = updateV $ set (projectiles . ix pID . ptPos) finalPos - $ set (projectiles .ix pID.ptPict) + where + updatedWorld = updateV $ set (projectiles . ix pID . pjPos) finalPos + $ set (projectiles .ix pID.pjPict) (onLayer PtLayer $ uncurry translate newPos $ rotate dir $ grenadePic time) - $ set (projectiles .ix pID.ptUpdate) (moveGrenade (time-1) dir pID) w - pt = _projectiles w IM.! pID - oldPos = _ptPos pt - newPos = _ptVel pt +.+ oldPos + $ set (projectiles .ix pID.pjUpdate) (moveGrenade (time-1) dir pID) w + pj = _projectiles w IM.! pID + oldPos = _pjPos pj + newPos = _pjVel pj +.+ oldPos hitWl = collideCircWalls' oldPos newPos 4 $ wallsNearPoint newPos w finalPos = fromMaybe newPos (fmap fst hitWl) - setV v = set (projectiles .ix pID.ptVel) v + setV v = set (projectiles .ix pID.pjVel) v updateV = fromMaybe id (fmap (setV.snd) hitWl) pointToItem (InInv cid invid) = creatures . ix cid . crInv . ix invid pointToItem (OnFloor flid) = floorItems . ix flid . flIt retireRemoteRocket :: Int -> Int -> Int -> World -> World -retireRemoteRocket itid 0 ptid w +retireRemoteRocket itid 0 pjid w = set (pointToItem (_itemPositions w IM.! itid) . itAttachment . _Just . scopePos) (0,0) $ set (pointToItem (_itemPositions w IM.! itid) . wpFire) fireRemoteLauncher - (w & projectiles %~ IM.delete ptid) -retireRemoteRocket itid t ptid w = setScope w & projectiles . ix ptid . ptUpdate .~ retireRemoteRocket itid (t-1) ptid + (w & projectiles %~ IM.delete pjid) +retireRemoteRocket itid t pjid w = setScope w & projectiles . ix pjid . pjUpdate .~ retireRemoteRocket itid (t-1) pjid where setScope w' = case _itemPositions w' IM.! itid of InInv cid invid -> w' & creatures . ix cid . crInv . ix invid . itAttachment . _Just . scopePos .~ (pos -.- _crPos (_creatures w' IM.! cid)) _ -> w' - pos = fromMaybe (0,0) $ w ^? projectiles . ix ptid . ptPos + pos = fromMaybe (0,0) $ w ^? projectiles . ix pjid . pjPos retireRemoteBomb :: Int -> Int -> Int -> World -> World -retireRemoteBomb itid 0 ptid w +retireRemoteBomb itid 0 pjid w = set (pointToItem (_itemPositions w IM.! itid) . itAttachment . _Just . scopePos) (0,0) $ set (pointToItem (_itemPositions w IM.! itid) . itZoom) defaultItZoom $ set (pointToItem (_itemPositions w IM.! itid) . twFire) throwRemoteBomb - (w & projectiles %~ IM.delete ptid) -retireRemoteBomb itid t ptid w - = setScope w & projectiles . ix ptid . ptUpdate .~ retireRemoteBomb itid (t-1) ptid + (w & projectiles %~ IM.delete pjid) +retireRemoteBomb itid t pjid w + = setScope w & projectiles . ix pjid . pjUpdate .~ retireRemoteBomb itid (t-1) pjid where setScope w' = case _itemPositions w' IM.! itid of InInv cid invid -> w' & creatures . ix cid . crInv . ix invid . itAttachment . _Just . scopePos .~ (pos -.- _crPos (_creatures w' IM.! cid)) _ -> w' - pos = fromMaybe (0,0) $ w ^? projectiles . ix ptid . ptPos + pos = fromMaybe (0,0) $ w ^? projectiles . ix pjid . pjPos moveRemoteBomb :: Int -> Int -> Int -> World -> World moveRemoteBomb itid time pID w | time < -4 = setScope $ updatePicture - $ set (projectiles .ix pID.ptUpdate) (moveRemoteBomb itid (f time) pID) + $ set (projectiles .ix pID.pjUpdate) (moveRemoteBomb itid (f time) pID) w | time < 2 = case hitWl of @@ -1004,9 +1005,9 @@ moveRemoteBomb itid time pID w _ -> updatedWorld where updatedWorld - = updateV $ set (projectiles . ix pID . ptPos) finalPos + = updateV $ set (projectiles . ix pID . pjPos) finalPos $ updatePicture - $ set (projectiles .ix pID.ptUpdate) (moveRemoteBomb itid (time-1) pID) + $ set (projectiles .ix pID.pjUpdate) (moveRemoteBomb itid (time-1) pID) $ setScope w setScope w' = case _itemPositions w' IM.! itid of @@ -1016,20 +1017,20 @@ moveRemoteBomb itid time pID w & creatures . ix cid . crInv . ix invid . itZoom .~ (defaultItZoom {_itAimZoomMax = 0.5, _itAimZoomMin = 0.5}) _ -> w' - pt = _projectiles w IM.! pID - oldPos = _ptPos pt - newPos = _ptVel pt +.+ oldPos + pj = _projectiles w IM.! pID + oldPos = _pjPos pj + newPos = _pjVel pj +.+ oldPos -- this is hacky, should use a version of collidePointWalls' that collides -- circles and walls - invShift x = x -.- 5 *.* normalizeV (_ptVel pt) + invShift x = x -.- 5 *.* normalizeV (_pjVel pj) hitWl = collideCircWalls' oldPos newPos 4 $ wallsNearPoint newPos w finalPos = fromMaybe newPos (fmap (invShift . fst) hitWl) - setV v = set (projectiles .ix pID.ptVel) v + setV v = set (projectiles .ix pID.pjVel) v updateV = fromMaybe id (fmap (setV.snd) hitWl) - halfV = over (projectiles . ix pID . ptVel) (\v -> 0.5 *.* v) + halfV = over (projectiles . ix pID . pjVel) (\v -> 0.5 *.* v) f x | x < -369 = -10 | otherwise = x - 1 - updatePicture = set (projectiles . ix pID.ptPict) + updatePicture = set (projectiles . ix pID.pjPict) (onLayer PtLayer $ uncurry translate newPos $ remoteBombPic time) . lowLightDirected (withAlpha 0.1 red) newPos @@ -1270,60 +1271,35 @@ remoteBomb = defaultThrowable throwGrenade' :: (Point2 -> World -> World) -> Int -> Int -> World -> World throwGrenade' explosion fuseTime n w = setWp $ removePict $ over projectiles addG $ set randGen g w - where addG = IM.insert i - $ Shell { _ptPos = p - , _ptStartPos = p - , _ptVel = v - , _ptPict = onLayer PtLayer $ uncurry translate p $ grenadePic 0 - , _ptID = i - , _ptUpdate = moveGrenade fuseTime dir i - , _ptExplosion = explosion - } - j = _crInvSel $ _creatures w IM.! n - removePict = set (creatures . ix n . crInv . ix j . itEquipPict) $ \ _ _ -> blank - i = newProjectileKey w - (a, g) = randomR (-grenadeAccA,grenadeAccA::Float) (_randGen w) - (l, _) = randomR (1 - 2*grenadeAccL,1+grenadeAccL::Float) g - -- v = 0.02 * l / _cameraZoom w *.* rotateV (a+_cameraRot w) (limitRange $ _mousePos w) - v' = 1 / (fromIntegral fuseTime * _cameraZoom w) *.* rotateV (_cameraRot w) ( _mousePos w) - v | magV v' > 6 = 6 *.* normalizeV v' - | otherwise = v' - cr = _creatures w IM.! n - p' = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr,0) - p | circOnSomeWall p' 4 w = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr-4,0) - | otherwise = p' - dir = argV v - setWp :: World -> World - setWp w' = w' & creatures . ix n . crInv . ix j . itEffect .~ throwArmReset 20 + where + addG = IM.insert i $ Shell + { _pjPos = p + , _pjStartPos = p + , _pjVel = v + , _pjPict = onLayer PtLayer $ uncurry translate p $ grenadePic 0 + , _pjID = i + , _pjUpdate = moveGrenade fuseTime dir i + , _pjPayload = explosion + } + j = _crInvSel $ _creatures w IM.! n + removePict = set (creatures . ix n . crInv . ix j . itEquipPict) $ \ _ _ -> blank + i = newProjectileKey w + (a, g) = randomR (-grenadeAccA,grenadeAccA::Float) (_randGen w) + (l, _) = randomR (1 - 2*grenadeAccL,1+grenadeAccL::Float) g +-- - v = 0.02 * l / _cameraZoom w *.* rotateV (a+_cameraRot w) (limitRange $ _mousePos w) + v' = 1 / (fromIntegral fuseTime * _cameraZoom w) *.* rotateV (_cameraRot w) ( _mousePos w) + v | magV v' > 6 = 6 *.* normalizeV v' + | otherwise = v' + cr = _creatures w IM.! n + p' = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr,0) + p | circOnSomeWall p' 4 w = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr-4,0) + | otherwise = p' + dir = argV v + setWp :: World -> World + setWp w' = w' & creatures . ix n . crInv . ix j . itEffect .~ throwArmReset 20 throwGrenade :: Int -> Int -> World -> World throwGrenade = throwGrenade' makeExplosionAt --- setWp $ removePict $ over projectiles addG $ set randGen g w --- where addG = IM.insert i --- $ Shell { _ptPos = p --- , _ptStartPos = p --- , _ptVel = v --- , _ptPict = onLayer PtLayer $ uncurry translate p $ grenadePic 0 --- , _ptID = i --- , _ptUpdate = moveGrenade fuseTime dir i --- , _ptExplosion = makeExplosionAt --- } --- j = _crInvSel $ _creatures w IM.! n --- removePict = set (creatures . ix n . crInv . ix j . itEquipPict) $ \ _ _ -> blank --- i = newProjectileKey w --- (a, g) = randomR (-grenadeAccA,grenadeAccA::Float) (_randGen w) --- (l, _) = randomR (1 - 2*grenadeAccL,1+grenadeAccL::Float) g --- -- v = 0.02 * l / _cameraZoom w *.* rotateV (a+_cameraRot w) (limitRange $ _mousePos w) --- v' = 1 / (fromIntegral fuseTime * _cameraZoom w) *.* rotateV (_cameraRot w) ( _mousePos w) --- v | magV v' > 6 = 6 *.* normalizeV v' --- | otherwise = v' --- cr = _creatures w IM.! n --- p' = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr,0) --- p | circOnSomeWall p' 4 w = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr-4,0) --- | otherwise = p' --- dir = argV v --- setWp :: World -> World --- setWp w' = w' & creatures . ix n . crInv . ix j . itEffect .~ throwArmReset 20 throwArmReset :: Int -> ItEffect throwArmReset x = @@ -1352,45 +1328,46 @@ fireRemoteLauncher :: Int -> World -> World fireRemoteLauncher cid w = setLocation $ resetFire $ resetName $ soundOnce (fromIntegral launcherSound) $ over projectiles remRocket w - where - i = newKey $ _projectiles w - cr = _creatures w IM.! cid - dir = _crDir cr - pos = _crPos cr +.+ rotateV dir (_crRad cr + 1,0) - remRocket = IM.insert i $ Projectile { _ptPos = pos - , _ptStartPos = pos - , _ptVel = rotateV dir (1,0) - , _ptPict = blank - , _ptID = i - , _ptUpdate = moveRemoteShell 50 i cid itid dir - } - j = _crInvSel $ _creatures w IM.! cid - newitid = newKey $ _itemPositions w - maybeitid = w ^? creatures . ix cid . crInv . ix j . itID . _Just - resetFire = set (creatures . ix cid . crInv . ix j . wpFire) $ explodeRemoteRocket itid i - resetName = set (creatures . ix cid . crInv . ix j . itName) "REMOTEROCKET" - setLocation :: World -> World - setLocation w' = case maybeitid of - Nothing -> w' & creatures . ix cid . crInv . ix j . itID .~ Just newitid - & itemPositions %~ IM.insert newitid (InInv cid j) - _ -> w' - itid = fromMaybe newitid maybeitid + where + i = newKey $ _projectiles w + cr = _creatures w IM.! cid + dir = _crDir cr + pos = _crPos cr +.+ rotateV dir (_crRad cr + 1,0) + remRocket = IM.insert i $ Projectile + { _pjPos = pos + , _pjStartPos = pos + , _pjVel = rotateV dir (1,0) + , _pjPict = blank + , _pjID = i + , _pjUpdate = moveRemoteShell 50 i cid itid dir + } + j = _crInvSel $ _creatures w IM.! cid + newitid = newKey $ _itemPositions w + maybeitid = w ^? creatures . ix cid . crInv . ix j . itID . _Just + resetFire = set (creatures . ix cid . crInv . ix j . wpFire) $ explodeRemoteRocket itid i + resetName = set (creatures . ix cid . crInv . ix j . itName) "REMOTEROCKET" + setLocation :: World -> World + setLocation w' = case maybeitid of + Nothing -> w' & creatures . ix cid . crInv . ix j . itID .~ Just newitid + & itemPositions %~ IM.insert newitid (InInv cid j) + _ -> w' + itid = fromMaybe newitid maybeitid moveRemoteShell :: Int -> Int -> Int -> Int -> Float -> World -> World moveRemoteShell time i cid itid dir w | time > 40 = if circOnSomeWall oldPos 4 w then doExplosion w - else over (projectiles . ix i . ptPos) (+.+ vel) - $ set (projectiles . ix i . ptPict) piclow - $ set (projectiles . ix i . ptUpdate) + else over (projectiles . ix i . pjPos) (+.+ vel) + $ set (projectiles . ix i . pjPict) piclow + $ set (projectiles . ix i . pjUpdate) (moveRemoteShell (time-1) i cid itid newdir) $ setScope w | time >= 20 = case thingHit of Just p -> doExplosion w - Nothing -> over (projectiles . ix i . ptPos) (+.+ vel) - $ set (projectiles . ix i . ptPict) pic - $ set (projectiles . ix i . ptUpdate) + Nothing -> over (projectiles . ix i . pjPos) (+.+ vel) + $ set (projectiles . ix i . pjPict) pic + $ set (projectiles . ix i . pjUpdate) (moveRemoteShell (time-1) i cid itid newdir) $ setScope w @@ -1399,12 +1376,12 @@ moveRemoteShell time i cid itid dir w Just p -> doExplosion $ stopSoundFrom (ShellSound i) w - Nothing -> over (projectiles . ix i . ptPos) (+.+ vel) + Nothing -> over (projectiles . ix i . pjPos) (+.+ vel) $ set randGen g - $ set (projectiles . ix i . ptPict) pic - $ set (projectiles . ix i . ptUpdate) + $ set (projectiles . ix i . pjPict) pic + $ set (projectiles . ix i . pjUpdate) (moveRemoteShell (time-1) i cid itid newdir) - $ over (projectiles . ix i . ptVel) (\v -> accel +.+ frict *.* v) + $ over (projectiles . ix i . pjVel) (\v -> accel +.+ frict *.* v) $ soundFrom (ShellSound i) (fromIntegral smokeTrailSound) (1) 250 $ smokeGen $ makeFlameletTimed oldPos @@ -1415,108 +1392,112 @@ moveRemoteShell time i cid itid dir w Just p -> doExplosion $ stopSoundFrom (ShellSound i) w - Nothing -> over (projectiles . ix i . ptPos) (+.+ vel) - $ set (projectiles . ix i . ptPict) pic - $ set (projectiles . ix i . ptUpdate) + Nothing -> over (projectiles . ix i . pjPos) (+.+ vel) + $ set (projectiles . ix i . pjPict) pic + $ set (projectiles . ix i . pjUpdate) (moveRemoteShell (time-1) i cid itid newdir) $ setScope w | otherwise = doExplosion $ stopSoundFrom (ShellSound i) w - where pt = _projectiles w IM.! i - oldPos = _ptPos pt - vel = _ptVel pt - newPos = oldPos +.+ vel - newdir - | SDL.ButtonRight `S.member` (_mouseButtons w) - && w ^? creatures . ix cid . crInvSel == w ^? itemPositions . ix itid . itInvId - = _cameraRot w + (argV $ _mousePos w) - | otherwise = dir - accel = rotateV newdir (2,0) - (frict,g) = randomR (0.6,0.9) $ _randGen w - (sparkD,_) = randomR (-0.5,0.5) $ _randGen w - dir = argV $ vel - pic = onLayer PtLayer $ uncurry translate newPos - $ rotate (argV accel) $ remoteShellPic time - piclow = onLayerL [levLayer CrLayer - 2] - $ uncurry translate newPos $ rotate (argV accel) - $ remoteShellPic time - hitCr = fmap fst $ collideCircCrsPoint oldPos newPos 4 w - hitWl = fmap fst $ collideCircWalls' oldPos newPos 2 $ wallsNearPoint newPos w - thingHit = hitCr <|> hitWl + where + pj = _projectiles w IM.! i + oldPos = _pjPos pj + vel = _pjVel pj + newPos = oldPos +.+ vel + newdir + | SDL.ButtonRight `S.member` (_mouseButtons w) + && w ^? creatures . ix cid . crInvSel == w ^? itemPositions . ix itid . itInvId + = _cameraRot w + (argV $ _mousePos w) + | otherwise = dir + accel = rotateV newdir (2,0) + (frict,g) = randomR (0.6,0.9) $ _randGen w + (sparkD,_) = randomR (-0.5,0.5) $ _randGen w + dir = argV $ vel + pic = onLayer PtLayer $ uncurry translate newPos + $ rotate (argV accel) $ remoteShellPic time + piclow = onLayerL [levLayer CrLayer - 2] + $ uncurry translate newPos $ rotate (argV accel) + $ remoteShellPic time + hitCr = fmap fst $ collideCircCrsPoint oldPos newPos 4 w + hitWl = fmap fst $ collideCircWalls' oldPos newPos 2 $ wallsNearPoint newPos w + thingHit = hitCr <|> hitWl - r1 = _randGen w & evalState (randInCirc 10) - smokeGen = makeSmokeCloudAt (oldPos +.+ r1 +.+ 30 *.* (normalizeV (oldPos -.- newPos))) - doExplosion = explodeRemoteRocket itid i cid - setScope w' = case _itemPositions w' IM.! itid of - InInv cid invid - -> w' & creatures . ix cid . crInv . ix invid . itAttachment - . _Just . scopePos .~ (newPos -.- _crPos (_creatures w' IM.! cid)) - _ -> w' + r1 = _randGen w & evalState (randInCirc 10) + smokeGen = makeSmokeCloudAt (oldPos +.+ r1 +.+ 30 *.* (normalizeV (oldPos -.- newPos))) + doExplosion = explodeRemoteRocket itid i cid + setScope w' = case _itemPositions w' IM.! itid of + InInv cid invid + -> w' & creatures . ix cid . crInv . ix invid . itAttachment + . _Just . scopePos .~ (newPos -.- _crPos (_creatures w' IM.! cid)) + _ -> w' explodeRemoteRocket :: Int -> Int -> Int -> World -> World -explodeRemoteRocket itid ptid n w - = set (projectiles . ix ptid . ptUpdate) (retireRemoteRocket itid 30 ptid) - $ set (projectiles . ix ptid . ptPict) blank +explodeRemoteRocket itid pjid n w + = set (projectiles . ix pjid . pjUpdate) (retireRemoteRocket itid 30 pjid) + $ set (projectiles . ix pjid . pjPict) blank $ set (itPoint . wpFire) (flip const) $ resetName - $ makeExplosionAt (_ptPos (_projectiles w IM.! ptid)) w - where resetName = set (itPoint . itName) "REMOTELAUNCHER" - itPoint = pointToItem $ _itemPositions w IM.! itid + $ makeExplosionAt (_pjPos (_projectiles w IM.! pjid)) w + where + resetName = set (itPoint . itName) "REMOTELAUNCHER" + itPoint = pointToItem $ _itemPositions w IM.! itid throwRemoteBomb :: Int -> World -> World throwRemoteBomb n w = setLocation $ removePict $ resetFire $ resetName $ over projectiles addG w - where addG = IM.insert i - $ Projectile { _ptPos = p - , _ptStartPos = p - , _ptVel = v - , _ptPict = blank - , _ptID = i - , _ptUpdate = moveRemoteBomb itid 50 i - } - i = newProjectileKey w - -- fireDist = zoom *.* (rotateV (_cameraRot w) (_mousePos w) +.+ _cameraCenter w -.- yourPos) - d = argV $ _mousePos w - --(l, _) = randomR (1 - grenadeAccL,1+grenadeAccL) (_randGen w) - --(a, g) = randomR (-grenadeAccA,grenadeAccA) (_randGen w) - v' = 0.02 / _cameraZoom w *.* rotateV (_cameraRot w) ( _mousePos w) - v | magV v' > 6 = 6 *.* normalizeV v' - -- zoom = 1 / _cameraZoom w - j = _crInvSel $ _creatures w IM.! n - resetName = set (creatures . ix n . crInv . ix j . itName) "REMOTE" - removePict = set (creatures . ix n . crInv . ix j . itEquipPict) $ \ _ _ -> blank - resetFire = set (creatures . ix n . crInv . ix j . twFire) $ explodeRemoteBomb itid i - cr = _creatures w IM.! n - p' = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr,0) - p | circOnSomeWall p' 4 w = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr-4,0) - | otherwise = p' - maybeitid = w ^? creatures . ix n . crInv . ix j . itID . _Just - setLocation :: World -> World - setLocation w' = case maybeitid of - Nothing -> w' & creatures . ix n . crInv . ix j . itID .~ Just newitid - & itemPositions %~ IM.insert newitid (InInv n j) - _ -> w' - newitid = newKey $ _itemPositions w - itid = fromMaybe newitid maybeitid + where + addG = IM.insert i $ Projectile + { _pjPos = p + , _pjStartPos = p + , _pjVel = v + , _pjPict = blank + , _pjID = i + , _pjUpdate = moveRemoteBomb itid 50 i + } + i = newProjectileKey w + -- fireDist = zoom *.* (rotateV (_cameraRot w) (_mousePos w) +.+ _cameraCenter w -.- yourPos) + d = argV $ _mousePos w + --(l, _) = randomR (1 - grenadeAccL,1+grenadeAccL) (_randGen w) + --(a, g) = randomR (-grenadeAccA,grenadeAccA) (_randGen w) + v' = 0.02 / _cameraZoom w *.* rotateV (_cameraRot w) ( _mousePos w) + v | magV v' > 6 = 6 *.* normalizeV v' + -- zoom = 1 / _cameraZoom w + j = _crInvSel $ _creatures w IM.! n + resetName = set (creatures . ix n . crInv . ix j . itName) "REMOTE" + removePict = set (creatures . ix n . crInv . ix j . itEquipPict) $ \ _ _ -> blank + resetFire = set (creatures . ix n . crInv . ix j . twFire) $ explodeRemoteBomb itid i + cr = _creatures w IM.! n + p' = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr,0) + p | circOnSomeWall p' 4 w = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr-4,0) + | otherwise = p' + maybeitid = w ^? creatures . ix n . crInv . ix j . itID . _Just + setLocation :: World -> World + setLocation w' = case maybeitid of + Nothing -> w' & creatures . ix n . crInv . ix j . itID .~ Just newitid + & itemPositions %~ IM.insert newitid (InInv n j) + _ -> w' + newitid = newKey $ _itemPositions w + itid = fromMaybe newitid maybeitid explodeRemoteBomb :: Int -> Int -> Int -> World -> World -explodeRemoteBomb itid ptid n w - = set (projectiles . ix ptid . ptUpdate) (retireRemoteBomb itid 30 ptid) - $ set (projectiles . ix ptid . ptPict) blank +explodeRemoteBomb itid pjid n w + = set (projectiles . ix pjid . pjUpdate) (retireRemoteBomb itid 30 pjid) + $ set (projectiles . ix pjid . pjPict) blank $ set (creatures . ix n . crInv . ix j . twFire) (flip const) $ resetName $ resetPict -- $ resetScope - $ makeExplosionAt (_ptPos (_projectiles w IM.! ptid)) w - -- $ makeShrapnelBombAt (_ptPos (_projectiles w IM.! ptid)) w - where resetName = set (creatures . ix n . crInv . ix j . itName) "REMOTEBOMB" - resetPict = set (creatures . ix n . crInv . ix j . itEquipPict ) - (drawWeapon $ remoteBombUnarmedPic) --- resetScope = creatures . ix n . crInv . ix j . itScope . _Just . scopePos .~ (0,0) - j = _crInvSel $ _creatures w IM.! n + $ makeExplosionAt (_pjPos (_projectiles w IM.! pjid)) w + -- $ makeShrapnelBombAt (_pjPos (_projectiles w IM.! pjid)) w + where + resetName = set (creatures . ix n . crInv . ix j . itName) "REMOTEBOMB" + resetPict = set (creatures . ix n . crInv . ix j . itEquipPict ) + (drawWeapon $ remoteBombUnarmedPic) +-- resetScope = creatures . ix n . crInv . ix j . itScope . _Just . scopePos .~ (0,0) + j = _crInvSel $ _creatures w IM.! n remoteBombPic :: Int -> Picture remoteBombPic x = pictures [ color (dark $ dark orange) $ circleSolid 5 , rotate (0 - degToRad (fromIntegral x * 10 + 45)) $ color red $ arc 0 (pi/2) 5 @@ -1667,8 +1648,8 @@ moveInt toReload totalAmmo = (x, totalAmmo-x) updateTractor :: Int -> Int -> Int -> World -> World updateTractor colID time i w - | time > 0 = set (projectiles . ix i . ptUpdate) (updateTractor colID (time-1) i) - $ set (projectiles . ix i . ptPict) pic + | time > 0 = set (projectiles . ix i . pjUpdate) (updateTractor colID (time-1) i) + $ set (projectiles . ix i . pjPict) pic $ over creatures (IM.map tractCr) $ over floorItems (IM.map tractFlIt) w @@ -1693,10 +1674,10 @@ updateTractor colID time i w iP = _flItPos it m | dist iP p1 < 350 = 1 | otherwise = (410 - dist iP p1) / 60 - pt = _projectiles w IM.! i - q = _ptVel pt - p1 = _ptPos pt - p' = _ptStartPos pt + pj = _projectiles w IM.! i + q = _pjVel pj + p1 = _pjPos pj + p' = _pjStartPos pj p2 = fromMaybe p' $ fmap fst $ collidePointWalls p1 p' $ wallsNearPoint p' w p4 = vNormal p5 p5 = errorNormalizeV 12 $ p2 -.- p1 diff --git a/src/Dodge/Rendering.hs b/src/Dodge/Rendering.hs index 404d606b4..ddbe643cc 100644 --- a/src/Dodge/Rendering.hs +++ b/src/Dodge/Rendering.hs @@ -28,7 +28,7 @@ import qualified Data.Set as S worldPictures :: World -> Picture worldPictures w = pictures $ concat [ IM.elems $ _decorations w - , map _ptPict . IM.elems $ _projectiles w + , map _pjPict . IM.elems $ _projectiles w , map drawItem . IM.elems $ _floorItems w , map crDraw . IM.elems $ _creatures w , map clDraw . IM.elems $ _clouds w diff --git a/src/Dodge/Room/Data.hs b/src/Dodge/Room/Data.hs index 17aa51aeb..7bf5a3ed8 100644 --- a/src/Dodge/Room/Data.hs +++ b/src/Dodge/Room/Data.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StrictData #-} module Dodge.Room.Data where diff --git a/src/Dodge/Rooms.hs b/src/Dodge/Rooms.hs index a9ca27ae9..26f419535 100644 --- a/src/Dodge/Rooms.hs +++ b/src/Dodge/Rooms.hs @@ -148,12 +148,14 @@ roomC x y = Room , _rmPS = [windowLine (x/2,0) (x/2,y-60) ] --, _rmBound = rectNSWE y 0 0 x - , _rmBound = [] + , _rmBound = rectNSWE (y+5) (-5) (-5) (x+5) } - where lnks = [( (x-20, 0),pi) - ,( ( 20, 0),pi) - ,( ( 0, 20),pi/2) - ] + where + lnks = + [( (x-20, 0),pi) + ,( ( 20, 0),pi) + ,( ( 0, 20),pi/2) + ] makeRect :: Float -> Float -> [(Point2,Point2)] makeRect x y = [((0,0),(x,0)) diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 1779d8c6f..617d7b20a 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -68,7 +68,7 @@ updateSoundQueue = set soundQueue [] updateLightSources w = set tempLightSources (catMaybes tlss) w' where (w',tlss) = mapAccumR (\a b -> _tlsUpdate b a b) w $ _tempLightSources w -updateProjectiles w = IM.foldr' _ptUpdate w $ _projectiles w +updateProjectiles w = IM.foldr' _pjUpdate w $ _projectiles w updateParticles' :: World -> World updateParticles' w = set particles' (catMaybes ps) w' diff --git a/src/Dodge/WorldEvent/SpawnParticle.hs b/src/Dodge/WorldEvent/SpawnParticle.hs index 7de8c174e..dc900a111 100644 --- a/src/Dodge/WorldEvent/SpawnParticle.hs +++ b/src/Dodge/WorldEvent/SpawnParticle.hs @@ -194,19 +194,19 @@ cloudPoisonDamage c w = w & creatures %~ flip (foldr (IM.adjust doDam)) damagedC makeTeslaArcAt :: Int -> Point2 -> Float -> Projectile makeTeslaArcAt i pos dir = Projectile - { _ptPos = pos - , _ptStartPos = pos - , _ptVel = (0,0) - , _ptPict = onLayer PtLayer $ line [(0,0),(0,0)] - , _ptID = i - , _ptUpdate = moveTeslaArc pos dir i + { _pjPos = pos + , _pjStartPos = pos + , _pjVel = (0,0) + , _pjPict = onLayer PtLayer $ line [(0,0),(0,0)] + , _pjID = i + , _pjUpdate = moveTeslaArc pos dir i } moveTeslaArc :: Point2 -> Float -> Int -> World -> World moveTeslaArc p d i w = - set (projectiles . ix i . ptPict) pic - $ set (projectiles . ix i . ptUpdate) - (ptTimer 2 i) + set (projectiles . ix i . pjPict) pic + $ set (projectiles . ix i . pjUpdate) + (pjTimer 2 i) $ set randGen g $ createSpark 8 nc q2 (argV sv + d1) Nothing $ foldr damCrs w hitCrs From 502832b2b840303cdd55fc72a33697834a1d388a Mon Sep 17 00:00:00 2001 From: jgk Date: Mon, 29 Mar 2021 12:26:16 +0200 Subject: [PATCH 3/5] Partial fix to level generation --- src/Dodge/Layout.hs | 2 +- src/Dodge/LevelGen/StaticWalls.hs | 17 ++++++++--------- src/Geometry.hs | 1 - 3 files changed, 9 insertions(+), 11 deletions(-) diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 26e3a6174..a1461cd9e 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -68,7 +68,7 @@ wallsFromTree t = . divideWalls . assignKeys . foldr cutWalls [] -- $ map (map (g . roundPoint2)) - . map (map roundPoint2) +-- . map (map roundPoint2) $ (concatMap _rmPolys $ flatten t) where assignKeys = IM.fromList . zip [0..] . zipWith f [0..] diff --git a/src/Dodge/LevelGen/StaticWalls.hs b/src/Dodge/LevelGen/StaticWalls.hs index c31212278..192104f16 100644 --- a/src/Dodge/LevelGen/StaticWalls.hs +++ b/src/Dodge/LevelGen/StaticWalls.hs @@ -51,7 +51,7 @@ cutWalls' qs walls = nub . filter (not.wallIsZeroLength) . fuseWallsWith zs - . createPolyWalls rs + . addPolyWalls rs -- . removeWallsInPolygon ps -- . filter (not.wallIsZeroLength) -- . fuseWallsWith zs @@ -65,7 +65,7 @@ cutWalls' qs walls = -- split walls that intersect with the polygon into two -- (possibly three if the wall extends across the polygon) -- remove any created walls that are inside the polygon --- draw the required new walls along the polygon boundary +-- create the required new walls along the polygon boundary -- fuse wall endpoints that end up close to each or to polygon intersection points -- remove any walls that ended up zero length after fusing -- remove any duplicate walls @@ -77,7 +77,7 @@ cutWallsWithPoints :: [Point2] -> [WallP] -> ([Point2], [WallP] ) cutWallsWithPoints (p:ps) ws = foldr f ([],ws) (zip (p:ps) (ps++[p])) where f (p1,p2) (as,ws') = - ( as ++ cutWallsPoints p1 p2 ws' + ( nub $ as ++ cutWallsPoints p1 p2 ws' , concatMap (cutWall p1 p2) ws' ) @@ -86,20 +86,19 @@ cutWallsPoints :: Point2 -> Point2 -> [WallP] -> [Point2] --cutWallsPoints p1 p2 ws = mapMaybe (\(x:y:_) -> intersectExtendedSegSeg p1 p2 x y) cutWallsPoints p1 p2 ws = mapMaybe (uncurry $ myIntersectSegSeg p1 p2) ws --- given a segment and a wall, adds a cut point to the wall if it intersects the --- segment +-- given a segment and a wall, split the wall into two if it crosses the segment cutWall :: Point2 -> Point2 -> WallP -> [WallP] cutWall p1 p2 (x,y) = case myIntersectSegSeg p1 p2 x y of Nothing -> [(x,y)] Just cp -> [(x,cp),(cp,y)] -createPolyWalls :: [Point2] -> [WallP] -> [WallP] -createPolyWalls (q:qs) walls = foldr createPolyWall walls (zip (q:qs) (qs++[q])) +addPolyWalls :: [Point2] -> [WallP] -> [WallP] +addPolyWalls (q:qs) walls = foldr addPolyWall walls (zip (q:qs) (qs++[q])) -- adds a wall if there is not already a wall on the clockwise normal to this wall -- such that this existing wall faces towards the new wall -createPolyWall :: WallP -> [WallP] -> [WallP] -createPolyWall (p1,p2) walls = +addPolyWall :: WallP -> [WallP] -> [WallP] +addPolyWall (p1,p2) walls = case maybeW of Just (x,y) -> if isLHS x y p3 then walls else (p1,p2) : walls diff --git a/src/Geometry.hs b/src/Geometry.hs index af5147c2b..d4df0464b 100644 --- a/src/Geometry.hs +++ b/src/Geometry.hs @@ -101,7 +101,6 @@ safeNormalizeV !(0,0) = (0,0) safeNormalizeV !p = normalizeV p -- tests whether a point is on the LHS of a line --- this has been called somewhere with l1 == l2 isLHS :: Point2 -> Point2 -> Point2 -> Bool {-# INLINE isLHS #-} isLHS' :: (Float, Float) -> (Float, Float) -> Point2 -> Bool From a4afe05478d2ae058b42a54107188e8eee761082 Mon Sep 17 00:00:00 2001 From: jgk Date: Mon, 29 Mar 2021 13:36:03 +0200 Subject: [PATCH 4/5] Stop inanimate objects from opening walls --- src/Dodge/Creature/Inanimate.hs | 8 +++-- src/Dodge/Creature/LookupStatus.hs | 14 -------- src/Dodge/Creature/Property.hs | 20 ++++++++++++ src/Dodge/Data.hs | 34 +++++++++++--------- src/Dodge/Default.hs | 1 + src/Dodge/Item/Weapon/Bullet.hs | 6 ++-- src/Dodge/LevelGen/AutoDoor.hs | 51 ++++++++++++++++-------------- src/Geometry.hs | 1 + 8 files changed, 76 insertions(+), 59 deletions(-) delete mode 100644 src/Dodge/Creature/LookupStatus.hs create mode 100644 src/Dodge/Creature/Property.hs diff --git a/src/Dodge/Creature/Inanimate.hs b/src/Dodge/Creature/Inanimate.hs index d291025bf..058840b30 100644 --- a/src/Dodge/Creature/Inanimate.hs +++ b/src/Dodge/Creature/Inanimate.hs @@ -15,8 +15,10 @@ import Picture import qualified Data.IntMap.Strict as IM import Control.Lens +defaultInanimate = defaultCreature & crIsAnimate .~ False + lamp :: Creature -lamp = defaultCreature +lamp = defaultInanimate { _crUpdate = initialiseLamp , _crHP = 500 , _crPict = \ _ -> onLayer CrLayer $ color white $ circleSolid 10 @@ -40,7 +42,7 @@ updateLamp i = unrandUpdate handleLS internalUpdate barrel :: Creature -barrel = defaultCreature +barrel = defaultInanimate { _crUpdate = updateBarrel , _crHP = 500 , _crPict = \ _ -> onLayer CrLayer $ pictures @@ -56,7 +58,7 @@ barrel = defaultCreature } explosiveBarrel :: Creature -explosiveBarrel = defaultCreature +explosiveBarrel = defaultInanimate { _crUpdate = updateExpBarrel , _crHP = 400 , _crPict = \ _ -> onLayer CrLayer $ pictures [ color orange $ circleSolid 10 diff --git a/src/Dodge/Creature/LookupStatus.hs b/src/Dodge/Creature/LookupStatus.hs deleted file mode 100644 index f07579c11..000000000 --- a/src/Dodge/Creature/LookupStatus.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Dodge.Creature.LookupStatus - where -import Dodge.Data - -import Geometry - -import Control.Lens - -isArmouredFrom :: Point2 -> Creature -> Bool -isArmouredFrom p cr - = p /= _crPos cr - && any (\it -> it ^? itIdentity == Just FrontArmour) (_crInv cr) - && angleVV (unitVectorAtAngle $ _crDir cr) (p -.- _crPos cr) < pi/2 --- even though angleVV can generate NaN, the comparison seems to deal with it diff --git a/src/Dodge/Creature/Property.hs b/src/Dodge/Creature/Property.hs new file mode 100644 index 000000000..c3c1c0196 --- /dev/null +++ b/src/Dodge/Creature/Property.hs @@ -0,0 +1,20 @@ +module Dodge.Creature.Property + where +import Dodge.Data + +import Geometry + +import Control.Lens + +crIsArmouredFrom :: Point2 -> Creature -> Bool +crIsArmouredFrom p cr + = p /= _crPos cr + && any (\it -> it ^? itIdentity == Just FrontArmour) (_crInv cr) + && angleVV (unitVectorAtAngle $ _crDir cr) (p -.- _crPos cr) < pi/2 +-- even though angleVV can generate NaN, the comparison seems to deal with it + +crOnSeg :: Point2 -> Point2 -> Creature -> Bool +crOnSeg p1 p2 cr = circOnLine p1 p2 (_crPos cr) (_crRad cr) + +crNearSeg :: Float -> Point2 -> Point2 -> Creature -> Bool +crNearSeg d p1 p2 cr = circOnLine p1 p2 (_crPos cr) (_crRad cr + d) diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 39ba76d6f..d9e44bfb2 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -126,21 +126,25 @@ data TempLightSource = TLS } data Creature = Creature - { _crPos :: Point2 - , _crOldPos :: Point2 - , _crDir :: Float - , _crID :: Int - , _crPict :: Creature -> Picture - , _crUpdate :: World -> (World -> World,StdGen) -> Creature - -> ((World -> World,StdGen), Maybe Creature) - , _crRad :: Float - , _crMass :: Float - , _crHP :: Int - , _crMaxHP :: Int - , _crInv :: IM.IntMap Item - , _crInvSel :: Int - , _crState :: CreatureState - , _crCorpse :: Picture + { _crPos :: Point2 + , _crOldPos :: Point2 + , _crDir :: Float + , _crID :: Int + , _crPict :: Creature -> Picture + , _crUpdate + :: World + -> (World -> World,StdGen) + -> Creature + -> ((World -> World,StdGen), Maybe Creature) + , _crRad :: Float + , _crMass :: Float + , _crHP :: Int + , _crMaxHP :: Int + , _crInv :: IM.IntMap Item + , _crInvSel :: Int + , _crState :: CreatureState + , _crCorpse :: Picture + , _crIsAnimate :: Bool } data CreatureState = CrSt diff --git a/src/Dodge/Default.hs b/src/Dodge/Default.hs index 10b2ed9c8..ba9092d69 100644 --- a/src/Dodge/Default.hs +++ b/src/Dodge/Default.hs @@ -64,6 +64,7 @@ defaultCreature = Creature , _crInvSel = 0 , _crState = defaultState , _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ circleSolid 10 + , _crIsAnimate = True } defaultState = CrSt { _goals = [] , _stance = Stance {_carriage=Walking 0 0,_posture=AtEase} diff --git a/src/Dodge/Item/Weapon/Bullet.hs b/src/Dodge/Item/Weapon/Bullet.hs index 82b18ef2a..5e68943fc 100644 --- a/src/Dodge/Item/Weapon/Bullet.hs +++ b/src/Dodge/Item/Weapon/Bullet.hs @@ -6,7 +6,7 @@ import Dodge.WorldEvent import Dodge.SoundLogic import Dodge.RandomHelp -import Dodge.Creature.LookupStatus +import Dodge.Creature.Property import Geometry @@ -22,7 +22,7 @@ import Picture -- bullet effects bulHitCr' :: Particle' -> Point2 -> Creature -> World -> World bulHitCr' bt p cr w - | isArmouredFrom p cr + | crIsArmouredFrom p cr = createSpark 8 colID p1 (argV (p1 -.- p) + d1) Nothing . addDamageArmoured $ w | otherwise @@ -43,7 +43,7 @@ bulHitCr' bt p cr w bulBounceArmCr' :: Particle' -> Point2 -> Creature -> World -> World bulBounceArmCr' bt p cr w - | isArmouredFrom p cr + | crIsArmouredFrom p cr = addBouncer . addDamageArmoured $ w | otherwise = addDamage . hitSound . flashEff $ w diff --git a/src/Dodge/LevelGen/AutoDoor.hs b/src/Dodge/LevelGen/AutoDoor.hs index f5f27757d..c74bfd545 100644 --- a/src/Dodge/LevelGen/AutoDoor.hs +++ b/src/Dodge/LevelGen/AutoDoor.hs @@ -5,6 +5,8 @@ import Dodge.Data import Dodge.Base import Dodge.SoundLogic +import Dodge.Creature.Property + import Geometry import Picture @@ -24,7 +26,7 @@ autoDoorAt a b wls = IM.union wls $ IM.fromList $ zip is $ mkAutoDoor a b is is = [i..] mkAutoDoor :: Point2 -> Point2 -> [Int] -> [Wall] -mkAutoDoor pl pr xs = addSound $ zipWith3 (autoDoorPane [pl,pr]) +mkAutoDoor pl pr xs = addSound $ zipWith3 (autoDoorPane (pl,pr)) xs (lDoorClosed ++ rDoorClosed) (map shiftL lDoorClosed ++ map shiftR rDoorClosed) @@ -55,8 +57,8 @@ mkAutoDoor pl pr xs = addSound $ zipWith3 (autoDoorPane [pl,pr]) | otherwise = dm w where wp = (_wlLine $ _walls w IM.! (head xs)) !! 1 -autoDoorPane :: [Point2] -> Int -> [Point2] -> [Point2] -> Wall -autoDoorPane trigL n closedPos openPos = Door +autoDoorPane :: (Point2,Point2) -> Int -> [Point2] -> [Point2] -> Wall +autoDoorPane (trigx,trigy) n closedPos openPos = Door { _wlLine = closedPos , _wlID = n , _doorMech = dm @@ -66,24 +68,25 @@ autoDoorPane trigL n closedPos openPos = Door , _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 + where + a = closedPos !! 0 + b = closedPos !! 1 + dm w | any (crNearSeg 40 trigx trigy) $ IM.filter (_crIsAnimate) $ _creatures 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/Geometry.hs b/src/Geometry.hs index d4df0464b..666cfab39 100644 --- a/src/Geometry.hs +++ b/src/Geometry.hs @@ -150,6 +150,7 @@ circOnLine' !p1 !p2 !c !rad = isJustTrue (fmap (\p -> magV (p -.- c) < rad) y) isJustTrue (Just True) = True isJustTrue _ = False +-- this should probably be circOnSeg circOnLine :: Point2 -> Point2 -> Point2 -> Float -> Bool circOnLine !p1 !p2 !c !rad = magV (p1 -.- c) <= rad || magV (p2 -.- c) <= rad || isJustTrue (fmap (\p -> magV (p -.- c) < rad) y) From b709aad2a60b3b502aa846a33990a7b59a3264b5 Mon Sep 17 00:00:00 2001 From: jgk Date: Mon, 29 Mar 2021 16:22:25 +0200 Subject: [PATCH 5/5] Implement moving wall push and crush --- src/Dodge/Data.hs | 1 + src/Dodge/Default.hs | 21 +++++---- src/Dodge/Update.hs | 7 ++- src/Dodge/WallCreatureCollisions.hs | 72 ++++++++++++++++++----------- 4 files changed, 62 insertions(+), 39 deletions(-) diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index d9e44bfb2..fe2405e54 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -128,6 +128,7 @@ data TempLightSource = TLS data Creature = Creature { _crPos :: Point2 , _crOldPos :: Point2 + , _crVel :: Point2 , _crDir :: Float , _crID :: Int , _crPict :: Creature -> Picture diff --git a/src/Dodge/Default.hs b/src/Dodge/Default.hs index ba9092d69..d7da21066 100644 --- a/src/Dodge/Default.hs +++ b/src/Dodge/Default.hs @@ -50,19 +50,20 @@ defaultDoor = Door { _wlLine = [(0,0),(50,0)] } defaultCreature :: Creature defaultCreature = Creature - { _crPos = (0,0) + { _crPos = (0,0) , _crOldPos = (0,0) - , _crDir = 0 - , _crID = 1 - , _crPict = const $ onLayer CrLayer $ circleSolid 10 + , _crVel = (0,0) + , _crDir = 0 + , _crID = 1 + , _crPict = const $ onLayer CrLayer $ circleSolid 10 , _crUpdate = \ w f cr -> (f , Just cr) - , _crRad = 10 - , _crMass = 10 - , _crHP = 100 - , _crMaxHP = 150 - , _crInv = IM.empty + , _crRad = 10 + , _crMass = 10 + , _crHP = 100 + , _crMaxHP = 150 + , _crInv = IM.empty , _crInvSel = 0 - , _crState = defaultState + , _crState = defaultState , _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ circleSolid 10 , _crIsAnimate = True } diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 617d7b20a..6edfb7168 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -45,7 +45,7 @@ update w . wallEvents . set worldEvents id $ _worldEvents w1 w1 - where -- zoning w = set wallsZone (IM.foldr wallInZone IM.empty (_walls w)) + where -- zoning w = set wallsZone (IM.foldr wallInZone IM.empty (_walls w)) -- w -- wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize -- = insertIMInZone x y wlid wl @@ -76,7 +76,10 @@ updateParticles' w = set particles' (catMaybes ps) w' updateCreatures :: World -> World updateCreatures w = f $ set randGen newG $ set creatures (IM.mapMaybe id crs) w - where ((f,newG),crs) = IM.mapAccum (\g' cr -> _crUpdate cr w g' cr) (id,_randGen w) $ _creatures w + where + ((f,newG),crs) = IM.mapAccum (\g' cr -> _crUpdate cr w g' (setOldPos cr)) (id,_randGen w) + $ _creatures w + setOldPos cr = cr & crOldPos .~ _crPos cr wallEvents :: World -> World diff --git a/src/Dodge/WallCreatureCollisions.hs b/src/Dodge/WallCreatureCollisions.hs index 4624822aa..32bb96116 100644 --- a/src/Dodge/WallCreatureCollisions.hs +++ b/src/Dodge/WallCreatureCollisions.hs @@ -14,23 +14,18 @@ colCrsWalls :: World -> World colCrsWalls w = over creatures (fmap (colCrWall w)) w colCrWall :: World -> Creature -> Creature -colCrWall w c = pushOutFromWall w c - -pushOutFromWall :: World -> Creature -> Creature -pushOutFromWall w c - | p1 == p2 = c - | otherwise = over crPos ( - collideCorners rad p1 wallPoints - . - collideWalls rad p1 ls - . checkPushThroughs rad p1 ls - ) - c - where rad = _crRad c + wallBuffer - p1 = _crOldPos c - p2 = _crPos c - ls = IM.elems $ fmap _wlLine $ wallsNearPoint p2 w - wallPoints = nub $ concat ls +colCrWall w c + | p1 == p2 = pushOrCrush ls c + | otherwise = c & crPos %~ + collideCorners rad p1 wallPoints + . collideWalls rad p1 ls + . checkPushThroughs rad p1 ls + where + rad = _crRad c + wallBuffer + p1 = _crOldPos c + p2 = _crPos c + ls = IM.elems $ fmap _wlLine $ wallsNearPoint p2 w + wallPoints = nub $ concat ls -- colCrPushThrough :: World -> Creature -> Creature -- colCrPushThrough w cr = set crPos (checkPushThroughs rad p1 p2 ls) cr @@ -43,23 +38,40 @@ pushOutFromWall w c -- the amount to push creatures out from walls, extra to their radius wallBuffer = 3 --- the following tests whether a moving circle crosses a list of walls, and --- places the circle accordingly. --- It supposes that the circle will only interact with at most two walls. --- the reverse prevents the collision from happening again with the first wall, --- when two walls are collided with +-- the following tests whether or not a point is on a wall, and if so pushes it +-- out from the wall +-- If the resultant push out is itself on another wall, the original point is +-- returned collideWalls :: Float -> Point2 -> [[Point2]] -> Point2 -> Point2 collideWalls rad cp1 walls cp2 - = case (listToMaybe.mapMaybe (collideWall rad cp1 cp2)) walls of + = case (listToMaybe.mapMaybe (pushOutFromWall rad cp2)) walls of Nothing -> cp2 - Just cp3 -> case (listToMaybe.reverse.mapMaybe (collideWall rad cp1 cp3)) walls of + Just cp3 -> case (listToMaybe.reverse.mapMaybe (pushOutFromWall rad cp3)) walls of Nothing -> cp3 - Just cp4 -> cp4 + Just cp4 -> cp1 + +-- pushes a point out from a list of walls +-- if multiple new points occur, chooses the one closest to the orignal pointjk +pushOutFromWalls :: Float -> [[Point2]] -> Point2 -> Point2 +pushOutFromWalls rad walls p = + fromMaybe p + . listToMaybe + . sortBy (compare `on` dist p) + $ mapMaybe (pushOutFromWall rad p) + walls + +pushOrCrush :: [[Point2]] -> Creature -> Creature +pushOrCrush wls cr = case mapMaybe (pushOutFromWall (_crRad cr) cpos) wls of + [] -> cr + [p] -> cr & crPos .~ p + _ -> cr & crState . crDamage %~ ( (Blunt 50 cpos cpos cpos) :) + where + cpos = _crPos cr -- assumes that the wall is orientated -- assumes wall points are different -collideWall :: Float -> Point2 -> Point2 -> [Point2] -> Maybe (Point2) -collideWall rad cp1 cp2 (wp1:wp2:_) +pushOutFromWall :: Float -> Point2 -> [Point2] -> Maybe (Point2) +pushOutFromWall rad cp2 (wp1:wp2:_) | isOnWall = Just newP -- +.+ (1 *.* norm)) | otherwise = Nothing where norm = errorNormalizeV 61 $ vNormal (wp1 -.- wp2) @@ -70,6 +82,12 @@ collideWall rad cp1 cp2 (wp1:wp2:_) isJust Nothing = False isJust _ = True +pushOutFromCorners :: World -> Creature -> Creature +pushOutFromCorners w cr = cr & crPos .~ newPos + where + newPos = foldr (intersectCirclePoint (_crRad cr)) (_crPos cr) ls + ls = nub . concat . IM.elems $ fmap _wlLine $ wallsNearPoint (_crPos cr) w + collideCorners :: Float -> Point2 -> [Point2] -> Point2 -> Point2 collideCorners rad p1 ps p2 = foldr (intersectCirclePoint rad) p2 ps