Initial implementation of bezier bullet

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
 

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'
+        bbul = aCurveBulAt (Just cid) white startp controlp targetp 
-            {_ptPict' = onLayerL [levLayer PtLayer ] $ bezierQuad white white 5 5 startp controlp targetp
+                                (threeEff' bulHitCr' bulHitWall' bulHitFF') 5
-            ,_ptUpdate' = \w p -> case i of 0 -> (w, Nothing)
+
-                                            n -> (w, Just $ bbul (i-1))
-            }
-            
 fireRemoteLauncher :: Int -> World -> World
 fireRemoteLauncher cid w = setLocation $ resetFire $ resetName 
                                 $ soundOnce (fromIntegral launcherSound)

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)

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))]

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)

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) )