Correctly intersect lines and circles

This commit is contained in:
2021-12-15 11:16:56 +00:00
parent 9333d9497e
commit c5a211afce
4 changed files with 15 additions and 18 deletions
+3 -3
View File
@@ -166,15 +166,15 @@ aLaser it cr = particles .:~ makeLaserAt phasev pos dir
makeLaserAt :: Float -> Point2 -> Float -> Particle makeLaserAt :: Float -> Point2 -> Float -> Particle
makeLaserAt phasev pos dir = Particle makeLaserAt phasev pos dir = Particle
{ _ptDraw = const blank { _ptDraw = const blank
, _ptUpdate = moveLaser phasev pos dir , _ptUpdate = mvLaser phasev pos dir
} }
moveLaser :: Float -- ^ Phase velocity, controls deflection through windows mvLaser :: Float -- ^ Phase velocity, controls deflection through windows
-> Point2 -> Point2
-> Float -> Float
-> World -> World
-> Particle -> Particle
-> (World, Maybe Particle) -> (World, Maybe Particle)
moveLaser phasev pos dir w pt mvLaser phasev pos dir w pt
= ( damThingHitWith (Lasering 19) pos xp thHit w = ( damThingHitWith (Lasering 19) pos xp thHit w
, Just pt {_ptDraw = const pic ,_ptUpdate = ptSimpleTime 0 } , Just pt {_ptDraw = const pic ,_ptUpdate = ptSimpleTime 0 }
) )
+5 -1
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE TupleSections #-}
{- | {- |
Find which objects lie upon a line. Find which objects lie upon a line.
-} -}
@@ -121,7 +122,10 @@ thingsHitLongLine sp ep w
| sp == ep = [] | sp == ep = []
| otherwise = sortOn (dist sp . fst) (crs ++ wls) | otherwise = sortOn (dist sp . fst) (crs ++ wls)
where where
crs = zip crPs (map Left hitCrs) crs = mapMaybe
(\cr -> (,Left cr) <$> listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp ep))
. IM.elems $ _creatures w
--crs = zip crPs (map Left hitCrs)
hitCrs = IM.elems hitCrs = IM.elems
. IM.filter (\cr -> circOnSeg sp ep (_crPos cr) (_crRad cr)) . IM.filter (\cr -> circOnSeg sp ep (_crPos cr) (_crRad cr))
$ _creatures w $ _creatures w
-13
View File
@@ -194,16 +194,6 @@ ssaTriPoint' pa pb pc' bc
= Nothing = Nothing
| otherwise | otherwise
= Just $ ssaTriPoint pa pb pc' bc = Just $ ssaTriPoint pa pb pc' bc
-- | A potential correction of 'ssaTriPoint'.
-- This should be tested and benchmarked.
--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
-- | Return Just a point if it is inside a circle, Nothing otherwise. -- | Return Just a point if it is inside a circle, Nothing otherwise.
pointInCircle :: Point2 -> Float -> Point2 -> Maybe Point2 pointInCircle :: Point2 -> Float -> Point2 -> Maybe Point2
pointInCircle p r c pointInCircle p r c
@@ -223,9 +213,6 @@ collidePointCirc' p1 p2 rad c = fmap (\x -> magV (x -.- p1))
collidePointCirc'' :: Point2 -> Point2 -> Float -> Point2 -> Maybe (Point2,Float) collidePointCirc'' :: Point2 -> Point2 -> Float -> Point2 -> Maybe (Point2,Float)
collidePointCirc'' p1 p2 rad c = (,) <$> collidePointCirc p1 p2 rad c collidePointCirc'' p1 p2 rad c = (,) <$> collidePointCirc p1 p2 rad c
<*> collidePointCirc' p1 p2 rad c <*> collidePointCirc' p1 p2 rad c
-- | As 'collidePointCirc', but uses the supposedly correct version of ssaTriPoint.
--collidePointCircCorrect :: Point2 -> Point2 -> Float -> Point2 -> Maybe Point2
--collidePointCircCorrect p1 p2 rad c = ssaTriPointCorrect p2 c p1 rad
-- | Finds the height of a triangle using herons formula. -- | Finds the height of a triangle using herons formula.
-- The base is the line between the first two points. -- The base is the line between the first two points.
heron :: Point2 -> Point2 -> Point2 -> Float heron :: Point2 -> Point2 -> Point2 -> Float
+7 -1
View File
@@ -251,10 +251,16 @@ orthogonalPointOnSeg a b p
| otherwise = Just $ a +.+ param *.* (normalizeV $ b -.- a) | otherwise = Just $ a +.+ param *.* (normalizeV $ b -.- a)
where where
param = closestPointOnLineParam a b p param = closestPointOnLineParam a b p
inSegArea :: Point2 -> Point2 -> Point2 -> Bool
inSegArea a b c = param >= 0 && param <= dotV (b -.- a) (b -.- a)
where
param = dotV (b -.- a) (c -.- a)
intersectCircSeg :: Point2 -> Float -> Point2 -> Point2 -> [Point2] intersectCircSeg :: Point2 -> Float -> Point2 -> Point2 -> [Point2]
intersectCircSeg c r a b intersectCircSeg c r a b
| y < 0 = [] | y < 0 = []
| otherwise = nub $ filter ( (< dist a b) . dist a ) [ d -.- v, d +.+ c ] | otherwise = nub $ filter (inSegArea a b) [ d -.- v, d +.+ c ]
where where
d = closestPointOnLine a b c d = closestPointOnLine a b c
x = dist d c x = dist d c