justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Initial implementation of bezier bullet

Browse Source
This commit is contained in:
justin
2021-03-15 13:11:01 +01:00
parent 5ce9b4487b
commit a5e0dc65da
6 changed files with 43 additions and 349 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Geometry.hs
+6 -254
View File
@@ -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)