diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index 59c2fd465..259ba9fef 100644 --- a/src/Dodge/Base.hs +++ b/src/Dodge/Base.hs @@ -35,6 +35,11 @@ midPadL :: Int -> a -> [a] -> [a] -> [a] midPadL i x xs ys = take j (xs ++ repeat x) ++ ys where j = i - length ys +takeUntil :: (a -> Bool) -> [a] -> [a] +takeUntil f ps = case span f ps of + (xs,[]) -> xs + (xs,(y:_)) -> xs ++ [y] + you :: World -> Creature you w = _creatures w IM.! _yourID w diff --git a/src/Dodge/Item/Weapon.hs b/src/Dodge/Item/Weapon.hs index 9f42d7449..679882139 100644 --- a/src/Dodge/Item/Weapon.hs +++ b/src/Dodge/Item/Weapon.hs @@ -1425,14 +1425,11 @@ bezierControl targetp cid w = resetGun $ shootWithSound 0 (mkBezierBul startp co resetGun = set (creatures . ix cid . crInv . ix j . wpFire) $ bezierTarget mkBezierBul :: Point2 -> Point2 -> Point2 -> Int -> World -> World -mkBezierBul startp controlp targetp cid w = over particles' (bbul 30 :) w +mkBezierBul startp controlp targetp cid w = over particles' (bbul :) w where - bbul i = Particle' - {_ptPict' = onLayerL [levLayer PtLayer ] $ bezierQuad white white 5 5 startp controlp targetp - ,_ptUpdate' = \w p -> case i of 0 -> (w, Nothing) - n -> (w, Just $ bbul (i-1)) - } - + bbul = aCurveBulAt (Just cid) white startp controlp targetp + (threeEff' bulHitCr' bulHitWall' bulHitFF') 5 + fireRemoteLauncher :: Int -> World -> World fireRemoteLauncher cid w = setLocation $ resetFire $ resetName $ soundOnce (fromIntegral launcherSound) diff --git a/src/Dodge/Item/Weapon/Bullet.hs b/src/Dodge/Item/Weapon/Bullet.hs index e063a7586..4e6fe439b 100644 --- a/src/Dodge/Item/Weapon/Bullet.hs +++ b/src/Dodge/Item/Weapon/Bullet.hs @@ -231,6 +231,22 @@ aGenBulAt' maycid col pos vel hiteff width = Bul' , _btTrail' = [pos] , _btPassThrough' = maycid , _btWidth' = width - , _btTimer' = 90 + , _btTimer' = 100 , _btHitEffect' = hiteff } + +aCurveBulAt :: Maybe Int -> Color -> Point2 -> Point2 -> Point2 -> HitEffect' -> Float -> Particle' +aCurveBulAt maycid col pos control targ hiteff width = Bul' + { _ptPict' = blank + , _ptUpdate' = mvBulletTrajectory f + , _btVel' = (0,0) + , _btColor' = col + , _btTrail' = [pos] + , _btPassThrough' = maycid + , _btWidth' = width + , _btTimer' = 100 + , _btHitEffect' = hiteff + } + where f i = g $ (100 - fromIntegral i) / 10 + g x = map (bf . (+ x)) [0,0.01..0.09] + bf = bQuadToF (pos,control,targ) diff --git a/src/Dodge/WorldActions.hs b/src/Dodge/WorldActions.hs index d224a715c..0a313758e 100644 --- a/src/Dodge/WorldActions.hs +++ b/src/Dodge/WorldActions.hs @@ -1,4 +1,10 @@ -module Dodge.WorldActions where +module Dodge.WorldActions + ( module Dodge.WorldActions + , module Dodge.WorldActions.Bullet + ) + where + +import Dodge.WorldActions.Bullet import Dodge.Data import Dodge.Base @@ -425,93 +431,8 @@ threeEff' crEff wlEff ffEff pt thing w = case thing of (p,E3x2 wl) -> wlEff pt p wl w (p,E3x3 ff) -> ffEff pt p ff w -mvGenBullet' :: World -> Particle' -> (World, Maybe Particle') -mvGenBullet' w bt - | t <= 0 = (w, Nothing) - | t < 4 = (w, Just $ set btPassThrough' Nothing - $ set btTrail' (p:p:ps) - $ set ptPict' (bulLine col wth (p:p:ps)) - $ set btTimer' (t-1) bt - ) - | otherwise = case thingsHitExceptCr mcr p (p +.+ vel) w of - [] -> (w, Just $ set btPassThrough' Nothing - $ set btTrail' (p +.+ vel :p:ps) - $ set ptPict' (bulLine col wth (p +.+ vel:p:ps)) - $ set btTimer' (t-1) bt - ) - ((hitp,thing):_) - -> ( hiteff bt (hitp,thing) w - , Just $ set btPassThrough' Nothing - $ set btTrail' (hitp:p:ps) - $ set ptPict' (bulLine col wth (hitp:p:ps)) - $ set btTimer' 3 bt - ) - where mcr = _btPassThrough' bt - col = _btColor' bt - (p:ps) = _btTrail' bt - vel = _btVel' bt - hiteff = _btHitEffect' bt - wth = _btWidth' bt - t = _btTimer' bt -bulLine c w = setLayer 1 . bulLinea c w -bulLinea :: Color -> Float -> [Point2] -> Picture -bulLinea _ _ [] = blank -bulLinea _ _ (x:[]) = blank -bulLinea col width (a:b:[]) -- (a:b:[]) - = onLayer HPtLayer $ pictures $ reverse - [polygonCol $ zip (wedgeGeom width b a) $ [white,withAlpha 0 white,withAlpha 0 white] - ,polygonCol $ zip (lineGeom (width+1.5) a b) $ [col,col,withAlpha 0 col,withAlpha 0 col] - ] -bulLinea col width (a:b:c:[]) -- (a:b:[]) - = onLayer HPtLayer $ pictures $ reverse - [polygonCol $ zip (wedgeGeom width b a) $ repeat white - ,polygonCol $ zip (wedgeGeom width b c) $ [white,white,withAlpha 0 white] - ,polygonCol $ zip (lineGeom (width+1.5) a c) $ [col,col,withAlpha 0 col,withAlpha 0 col] - ] -bulLinea col width (a:b:_:c:[]) -- (a:b:[]) - = onLayer HPtLayer $ pictures $ reverse - [polygonCol $ zip (wedgeGeom width b a) $ repeat white - ,polygonCol $ zip (wedgeGeom width b c) $ [white,white,withAlpha 0 white] - ,polygonCol $ zip (lineGeom (width+1.5) a c) $ [col,col,withAlpha 0 col,withAlpha 0 col] - ] -bulLinea col width (a:b:_:_:c:_) -- (a:b:[]) - = onLayer HPtLayer $ pictures $ reverse - [polygonCol $ zip (wedgeGeom width b a) $ repeat white - ,polygonCol $ zip (wedgeGeom width b c) $ [white,white,withAlpha 0 white] - ,polygonCol $ zip (lineGeom (width+1.5) a c) $ [col,col,withAlpha 0 col,withAlpha 0 col] - ] --- [color (withAlpha 0.5 col) $ lineOfThickness (width+1.5) [a,b] --- ,color white $ wedgeOfThickness width a b ---bulLine col width (a:b:c:_) --- = onLayer HPtLayer $ pictures --- [color (withAlpha 0.5 col) $ lineOfThickness (width+1.5) [a,c] --- ,color white $ wedgeOfThickness width a c - -thingsHitExceptCr :: Maybe Int -> Point2 -> Point2 -> World - -> [(Point2, (Either3 Creature Wall ForceField))] -thingsHitExceptCr Nothing sp ep = thingsHit sp ep -thingsHitExceptCr (Just cid) sp ep = filter crNotCid . thingsHit sp ep - where crNotCid (_,(E3x1 cr)) = _crID cr /= cid - crNotCid _ = True - -thingsHit :: Point2 -> Point2 -> World -> [(Point2, (Either3 Creature Wall ForceField))] -thingsHit sp ep w = sortBy (compare `on` dist sp . fst) (crs ++ walls ++ ffs) - where hitCrs = IM.elems $ IM.filter (\cr -> circOnLine sp ep (_crPos cr) (_crRad cr)) - $ creaturesAlongLine sp ep w - crPs = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs - crs = zip crPs (map E3x1 hitCrs) - -- hitWls = wallsOnLine sp ep (f y $ f x $ _wallsZone w) - hitWls = wallsOnLine sp ep (IM.unions [f b $ f a $ _wallsZone w | a<-[x-1,x,x+1] - , b<-[y-1,y,y+1]]) - (x,y) = zoneOfPoint (0.5 *.* (sp +.+ ep)) - f i m = case IM.lookup i m of Just val -> val - _ -> IM.empty - walls = zip (map (fromJust . hitPoint) hitWls) (map E3x2 hitWls) - hitPoint w = intersectSegSeg' sp ep (_wlLine w !! 0) (_wlLine w !! 1) - hitFFs = mapMaybe (collidePointFF sp ep (_randGen w)) (IM.elems $ _forceFields w) - ffs = map (\(p,(_,i)) -> (p, E3x3 $ _forceFields w IM.! i)) hitFFs thingsHitExceptCrLongLine :: Maybe Int -> Point2 -> Point2 -> World -> [(Point2, (Either3 Creature Wall ForceField))] diff --git a/src/Geometry.hs b/src/Geometry.hs index 3f49af6ef..4b1fc1a78 100644 --- a/src/Geometry.hs +++ b/src/Geometry.hs @@ -2,9 +2,15 @@ module Geometry ( module Geometry , module Geometry.Data + , module Geometry.Intersect + , module Geometry.Bezier + , module Geometry.Vector ) where import Geometry.Data +import Geometry.Intersect +import Geometry.Bezier +import Geometry.Vector import Data.Function import Data.List @@ -12,81 +18,6 @@ import Data.Maybe import Control.Applicative -zeroZ :: Point2 -> Point3 -{-# INLINE zeroZ #-} -zeroZ (x,y) = (x,y,0) - -infixl 6 +.+, -.- -infixl 7 *.* - -(+.+) :: Point2 -> Point2 -> Point2 -{-# INLINE (+.+) #-} -(x1, y1) +.+ (x2, y2) = - let - !x = x1 + x2 - !y = y1 + y2 - in (x, y) - -(-.-) :: Point2 -> Point2 -> Point2 -{-# INLINE (-.-) #-} -(x1, y1) -.- (x2, y2) = - let - !x = x1 - x2 - !y = y1 - y2 - in (x, y) - -(*.*) :: Float -> Point2 -> Point2 -{-# INLINE (*.*) #-} -a *.* (x2, y2) = - let - !x = a * x2 - !y = a * y2 - in (x, y) - -infixl 6 +.+.+, -.-.- -infixl 7 *.*.* - -(+.+.+) :: Point3 -> Point3 -> Point3 -{-# INLINE (+.+.+) #-} -(x1, y1, z1) +.+.+ (x2, y2, z2) = - let - !x = x1 + x2 - !y = y1 + y2 - !z = z1 + z2 - in (x, y, z) - -(-.-.-) :: Point3 -> Point3 -> Point3 -{-# INLINE (-.-.-) #-} -(x1, y1, z1) -.-.- (x2, y2, z2) = - let - !x = x1 - x2 - !y = y1 - y2 - !z = z1 - z2 - in (x, y, z) - -(*.*.*) :: Point3 -> Point3 -> Point3 -{-# INLINE (*.*.*) #-} -(x1, y1, z1) *.*.* (x2, y2, z2) = - let - !x = x1 * x2 - !y = y1 * y2 - !z = z1 * z2 - in (x, y, z) - -normalizeV :: Point2 -> Point2 -{-# INLINE normalizeV #-} -normalizeV p = (1 / magV p) *.* p - -angleVV :: Point2 -> Point2 -> Float -{-# INLINE angleVV #-} -angleVV a b = let ma = magV a - mb = magV b - d = a `dotV` b - in acos $ d / (ma * mb) - -dotV :: Point2 -> Point2 -> Float -{-# INLINE dotV #-} -dotV (x,y) (z,w) = x*z + y*w closestPointOnLine :: Point2 -> Point2 -> Point2 -> Point2 {-# INLINE closestPointOnLine #-} @@ -99,46 +30,7 @@ closestPointOnLineParam :: Point2 -> Point2 -> Point2 -> Float closestPointOnLineParam a b p = (p -.- a) `dotV` (b -.- a) / (b -.- a) `dotV` (b -.- a) -argV :: Point2 -> Float -{-# INLINE argV #-} -argV (x,y) = normalizeAngle $ atan2 y x -detV :: Point2 -> Point2 -> Float -{-# INLINE detV #-} -detV (x1, y1) (x2, y2) - = x1 * y2 - y1 * x2 - --- | Angle in radians, anticlockwise from +ve x-axis. -unitVectorAtAngle :: Float -> Point2 -{-# INLINE unitVectorAtAngle #-} -unitVectorAtAngle r - = (cos r, sin r) - --- | Rotate a vector by an angle (in radians). +ve angle is counter-clockwise. -rotateV :: Float -> Point2 -> Point2 -rotateV r (x, y) - = ( x * cos r - y * sin r - , x * sin r + y * cos r) -{-# INLINE rotateV #-} - --- | Convert degrees to radians -degToRad :: Float -> Float -degToRad d = d * pi / 180 -{-# INLINE degToRad #-} - - --- | Convert radians to degrees -radToDeg :: Float -> Float -radToDeg r = r * 180 / pi -{-# INLINE radToDeg #-} - - --- | Normalize an angle to be between 0 and 2*pi radians -normalizeAngle :: Float -> Float -normalizeAngle f = f - 2 * pi * floor' (f / (2 * pi)) - where floor' :: Float -> Float - floor' x = fromIntegral (floor x :: Int) -{-# INLINE normalizeAngle #-} -- the following helper draws a rectangle based on maximal N E S W values rectNESW :: Float -> Float -> Float -> Float -> [Point2] @@ -225,79 +117,14 @@ orderPolygon [] = [] orderPolygon ps = sortBy (compare `on` \p -> argV (p -.- cen)) ps where cen = 1/ fromIntegral (length ps) *.* foldr1 (+.+) ps -vNormal :: Point2 -> Point2 -{-# INLINE vNormal #-} -vNormal (x,y) = (y,-x) - -vInverse :: Point2 -> Point2 -vInverse (x,y) = (-x,-y) - dist :: Point2 -> Point2 -> Float {-# INLINE dist #-} dist p1 p2 = magV (p2 -.- p1) -normV :: Point2 -> Point2 -{-# INLINE normV #-} -normV (0,0) = (0,0) -normV p = (1/magV p ) *.* p - -magV :: Point2 -> Float -{-# INLINE magV #-} -magV (x,y) = sqrt $ x^2 + y^2 pHalf :: Point2 -> Point2 -> Point2 pHalf a b = 0.5 *.* (a +.+ b) -linGrad :: (Eq a,Fractional a) => (a,a) -> (a,a) -> Maybe a -linGrad (x,y) (a,b) | x-a == 0 = Nothing - | otherwise = Just $ (y-b)/(x-a) - -axisInt :: (Eq a,Fractional a) => (a,a) -> (a,a) -> Maybe a -axisInt p (a,b) = pure b ^-^ (pure a ^*^ linGrad p (a,b)) - where (^-^) = liftA2 (-) - (^*^) = liftA2 (*) - --- intersectSegSeg is sometimes broken-- the following fixes at least some of --- the cases --- it is, however, slow -myIntersectSegSeg a@(ax,ay) b@(bx,by) c@(cx,cy) d@(dx,dy) = case ratIntersectLineLine a b c d of - Nothing -> Nothing - Just (x,y) -> if inbetween x && inbetween' y - then Just (x,y) - else Nothing - where inbetween x = ((ax <= x && x <= bx) || (bx <= x && x <= ax)) && - ((cx <= x && x <= dx) || (dx <= x && x <= cx)) - inbetween' y = ((ay <= y && y <= by) || (by <= y && y <= ay)) && - ((cy <= y && y <= dy) || (dy <= y && y <= cy)) - -crossV :: Point2 -> Point2 -> Float -crossV (ax,ay) (bx,by) = ax*by - ay*bx - -myIntersectLineLine :: (Eq a,Fractional a) => (a,a) -> (a,a) -> (a,a) -> (a,a) -> Maybe (a,a) -myIntersectLineLine a@(ax,ay) b c@(cx,cy) d - | linGrad a b == Nothing = fmap ((,) ax) $ axisInt (c *-* (ax,0)) (d *-* (ax,0)) - | linGrad c d == Nothing = fmap ((,) cx) $ axisInt (a *-* (cx,0)) (b *-* (cx,0)) - | otherwise - = case linGrad a b ^-^ linGrad c d of - Just 0 -> Nothing - _ -> liftA2 (,) newx - ((linGrad a b ^*^ newx) ^+^ axisInt a b) - where (^-^) = liftA2 (-) - (^+^) = liftA2 (+) - (^/^) = liftA2 (/) - (^*^) = liftA2 (*) - newx = (axisInt c d ^-^ axisInt a b) ^/^ (linGrad a b ^-^ linGrad c d) - (*-*) (ax,ay) (bx,by) = (ax-bx,ay-by) - -ratIntersectLineLine :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 -ratIntersectLineLine a b c d = fmap toNumPoint2 $ myIntersectLineLine (toRatPoint2 a) (toRatPoint2 b) (toRatPoint2 c) (toRatPoint2 d) - where toRatPoint2 (x,y) = (toRational x, toRational y) - toNumPoint2 (x,y) = (fromRational x, fromRational y) - f = toRatPoint2 . roundPoint2 - -roundPoint2 :: Point2 -> Point2 -roundPoint2 (x,y) = (fromIntegral $ round x,fromIntegral $ round y) - 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)) @@ -502,78 +329,3 @@ 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]) ---intersectSegLineFrom :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 ---intersectSegLineFrom a b c d --- = case intersectSegLine a b c d of --- Just p | closestPointOnLineParam c d p >= 0 -> Just p --- | otherwise -> Nothing --- Nothing -> Nothing - -intersectSegSeg' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 -{-# INLINE intersectSegSeg' #-} -intersectSegSeg' (x1,y1) (x2,y2) (x3,y3) (x4,y4) --- | t' < 0 || u' < 0 || t' > den || u' > den || den == 0 --- = Nothing - | den == 0 = Nothing - | den > 0 && (t' < 0 || u' < 0 || t' > den || u' > den) - = Nothing - | den < 0 && (t' > 0 || u' > 0 || t' < den || u' < den) - = Nothing --- | den > 0 && (t' < 0 || t' > den) --- = Nothing --- | den < 0 && (t' > 0 || t' < 0-den) --- = Nothing - | otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den) - where - den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4) - t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) - u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3) - -intersectSegLineFrom' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 -{-# INLINE intersectSegLineFrom' #-} -intersectSegLineFrom' (x1,y1) (x2,y2) (x3,y3) (x4,y4) --- | t' < 0 || u' < 0 || t' > den || u' > den || den == 0 --- = Nothing - | den == 0 = Nothing - | den > 0 && ( t' < 0 || u' < 0 || t' > den ) - = Nothing - | den < 0 && ( t' > 0 || u' > 0 || t' < den ) - = Nothing --- | den > 0 && (t' < 0 || t' > den) --- = Nothing --- | den < 0 && (t' > 0 || t' < 0-den) --- = Nothing - | otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den) - where - den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4) - t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) - u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3) - -intersectSegLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 -{-# INLINE intersectSegLine' #-} -intersectSegLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4) --- | t' < 0 || u' < 0 || t' > den || u' > den || den == 0 --- = Nothing - | den == 0 = Nothing - | den > 0 && (t' < 0 || t' > den) - = Nothing - | den < 0 && (t' > 0 || t' < den) - = Nothing --- | den > 0 && (t' < 0 || t' > den) --- = Nothing --- | den < 0 && (t' > 0 || t' < 0-den) --- = Nothing - | otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den) - where - den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4) - t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) - u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3) - -intersectLineLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 -{-# INLINE intersectLineLine' #-} -intersectLineLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4) - | den == 0 = Nothing - | otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den) - where - den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4) - t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) diff --git a/src/Picture.hs b/src/Picture.hs index 3c88c5082..d4c148bb2 100644 --- a/src/Picture.hs +++ b/src/Picture.hs @@ -71,7 +71,10 @@ polygonCol = PolygonCol 0 -- note that much of work computing the width of the bezier curve is done here bezierQuad :: Color -> Color -> Float -> Float -> Point2 -> Point2 -> Point2 -> Picture -bezierQuad cola colc ra rc a b c = BezierQuad 0 [-- ( (0,0) , cola, (0,0), (0,0) ) +bezierQuad cola colc ra rc a b c + | a == b && b == c = blank + | a == b || b == c = bezierQuad cola colc ra rc a (0.5 *.* (a +.+ c)) c + | otherwise = BezierQuad 0 [-- ( (0,0) , cola, (0,0), (0,0) ) (aIn, cola, (fa aIn,fc aIn) , (1,0) ) ,(aIn, cola, (fa aIn,fc aIn) , (1,0) ) ,(cIn, colc, (fa cIn,fc cIn) , (0,1) )