From 3b417c4966d3f26ea4300b94e54ef1a65af9ce20 Mon Sep 17 00:00:00 2001 From: jgk Date: Sun, 4 Apr 2021 16:26:06 +0200 Subject: [PATCH] Add haddocks and/or cleanup --- src/Dodge/Base.hs | 10 +- src/Dodge/Creature/Property.hs | 4 +- src/Dodge/Item/Weapon.hs | 4 +- src/Dodge/Render/Picture.hs | 2 +- src/Dodge/WallCreatureCollisions.hs | 2 +- src/Dodge/WorldEvent.hs | 2 +- src/Dodge/WorldEvent/Flash.hs | 2 +- src/Dodge/WorldEvent/ThingsHit.hs | 4 +- src/Geometry.hs | 254 +++++++++++++++++----------- test/Spec.hs | 6 +- 10 files changed, 174 insertions(+), 116 deletions(-) diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index 2b9144773..4f75a6cab 100644 --- a/src/Dodge/Base.hs +++ b/src/Dodge/Base.hs @@ -180,7 +180,7 @@ wallOnLine p1 p2 ws wallsOnCirc :: Point2 -> Float -> IM.IntMap Wall -> [Wall] wallsOnCirc p r wls = IM.elems $ IM.filter f wls - where f wl = circOnLine (_wlLine wl !! 0) (_wlLine wl !! 1) p r + where f wl = circOnSeg (_wlLine wl !! 0) (_wlLine wl !! 1) p r wallsNearPoint :: Point2 -> World -> IM.IntMap Wall wallsNearPoint p w = IM.unions [f b $ f a $ _wallsZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]] @@ -653,11 +653,11 @@ collidePointCrsWithoutPoint cid p1 p2 w = fmap f $ listToMaybe $ sortBy (csndsnd f (cID,(p,_)) = (p,cID) circOnSomeWall :: Point2 -> Float -> World -> Bool -circOnSomeWall p rad w = any (\(x:y:_) -> circOnLine x y p rad) +circOnSomeWall p rad w = any (\(x:y:_) -> circOnSeg x y p rad) $ fmap _wlLine $ IM.elems $ wallsNearPoint p w crsNearLine :: Float -> [Point2] -> World -> Bool -crsNearLine d (p1:p2:_) w = any (\c -> circOnLine p1 p2 (_crPos c) (d + _crRad c)) +crsNearLine d (p1:p2:_) w = any (\c -> circOnSeg p1 p2 (_crPos c) (d + _crRad c)) $ IM.filter (\cr -> _crMass cr > 4) $ _creatures w crsNearPoint :: Float -> Point2 -> World -> Bool @@ -665,12 +665,12 @@ crsNearPoint d p w = any (\c -> dist (_crPos c) p < (d + _crRad c)) (_creatures crsOnLine :: Point2 -> Point2 -> World -> [Creature] crsOnLine p1 p2 w = IM.elems - $ IM.filter (\cr -> circOnLine p1 p2 (_crPos cr) (_crRad cr)) + $ IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr)) $ _creatures w crsOnThickLine :: Float -> Point2 -> Point2 -> World -> [Creature] crsOnThickLine thickness p1 p2 w = IM.elems - $ IM.filter (\cr -> circOnLine p1 p2 (_crPos cr) (_crRad cr + thickness)) + $ IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr + thickness)) $ _creatures w nearestCrInRad :: Point2 -> Float -> World -> Maybe Creature diff --git a/src/Dodge/Creature/Property.hs b/src/Dodge/Creature/Property.hs index c3c1c0196..a85e70050 100644 --- a/src/Dodge/Creature/Property.hs +++ b/src/Dodge/Creature/Property.hs @@ -14,7 +14,7 @@ crIsArmouredFrom p cr -- 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) +crOnSeg p1 p2 cr = circOnSeg 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) +crNearSeg d p1 p2 cr = circOnSeg p1 p2 (_crPos cr) (_crRad cr + d) diff --git a/src/Dodge/Item/Weapon.hs b/src/Dodge/Item/Weapon.hs index 3127a4955..f75dde56f 100644 --- a/src/Dodge/Item/Weapon.hs +++ b/src/Dodge/Item/Weapon.hs @@ -1656,7 +1656,7 @@ updateTractor colID time i w $ over floorItems (IM.map tractFlIt) w | otherwise = over projectiles (IM.delete i) w - where tractCr cr | circOnLine p1 p2 cP 10 + where tractCr cr | circOnSeg p1 p2 cP 10 = over crPos (\p -> p -.- m *.* ((0.3/ x) *.* q +.+ (f y *.* p4)) ) cr @@ -1666,7 +1666,7 @@ updateTractor colID time i w cP = _crPos cr m | dist cP p1 < 350 = 1 | otherwise = (400 - dist cP p1) / 50 - tractFlIt it | circOnLine p1 p2 iP 10 + tractFlIt it | circOnSeg p1 p2 iP 10 = over flItPos (\p -> p -.- m *.* ( (0.3/ x) *.* q +.+ (f y *.* p4)) ) it diff --git a/src/Dodge/Render/Picture.hs b/src/Dodge/Render/Picture.hs index e6c2ad832..a1f400d96 100644 --- a/src/Dodge/Render/Picture.hs +++ b/src/Dodge/Render/Picture.hs @@ -176,7 +176,7 @@ drawFFShadow w ff fCol = color (_ffColor ff) col = _ffColor ff ypShift = yp -.- _cameraCenter w - youOnFF = circOnLine' x' y' ypShift (_crRad $ you w) + youOnFF = circOnSeg x' y' ypShift (_crRad $ you w) pane j = color (withAlpha 0.1 col) $ polygon $ [ x diff --git a/src/Dodge/WallCreatureCollisions.hs b/src/Dodge/WallCreatureCollisions.hs index d5685de40..6b2515f14 100644 --- a/src/Dodge/WallCreatureCollisions.hs +++ b/src/Dodge/WallCreatureCollisions.hs @@ -77,7 +77,7 @@ pushOutFromWall rad cp2 (wp1:wp2:_) wp1' = (rad *.* norm) +.+ wp1 wp2' = (rad *.* norm) +.+ wp2 newP = errorClosestPointOnLine 5 wp1' wp2' cp2 - isOnWall = circOnLine' wp1 wp2 cp2 rad + isOnWall = circOnSegNoEndpoints wp1 wp2 cp2 rad isJust Nothing = False isJust _ = True diff --git a/src/Dodge/WorldEvent.hs b/src/Dodge/WorldEvent.hs index a09ee41e0..8fc255760 100644 --- a/src/Dodge/WorldEvent.hs +++ b/src/Dodge/WorldEvent.hs @@ -111,7 +111,7 @@ createBarrelSpark time colid pos dir maycid w = over worldEvents damCrsOnLine :: Int -> Point2 -> Point2 -> World -> World damCrsOnLine dam p1 p2 = over creatures (IM.map damIfOnLine) - where damIfOnLine cr | circOnLine p1 p2 (_crPos cr) (_crRad cr) + where damIfOnLine cr | circOnSeg p1 p2 (_crPos cr) (_crRad cr) = over crHP (\hp -> hp - dam) cr | otherwise = cr diff --git a/src/Dodge/WorldEvent/Flash.hs b/src/Dodge/WorldEvent/Flash.hs index 26171d70c..92a20a694 100644 --- a/src/Dodge/WorldEvent/Flash.hs +++ b/src/Dodge/WorldEvent/Flash.hs @@ -61,7 +61,7 @@ lowLightPic :: Float -> Float -> Color -> (Point2, Point2) -> World -> Picture lowLightPic len wdth col (a,b) w = case thingsHit a b w of ((p, E3x2 wall):_) - -> setCol . lineOfThickness wdth $ [alongLineBy len p wa, alongLineBy len p wb] + -> setCol . lineOfThickness wdth $ [alongSegBy len p wa, alongSegBy len p wb] where x = len *.* (normalizeV $ wa -.- wb) (wa:wb:_) = _wlLine wall ((p, E3x1 cr):_) diff --git a/src/Dodge/WorldEvent/ThingsHit.hs b/src/Dodge/WorldEvent/ThingsHit.hs index 3360f0b25..9077ec253 100644 --- a/src/Dodge/WorldEvent/ThingsHit.hs +++ b/src/Dodge/WorldEvent/ThingsHit.hs @@ -15,7 +15,7 @@ thingsHit sp ep w | sp == ep = [] | otherwise = sortBy (compare `on` dist sp . fst) (crs ++ walls ++ ffs) where - hitCrs = IM.elems $ IM.filter (\cr -> circOnLine sp ep (_crPos cr) (_crRad cr)) + hitCrs = IM.elems $ IM.filter (\cr -> circOnSeg sp ep (_crPos cr) (_crRad cr)) $ _creatures w -- $ creaturesAlongLine sp ep w crPs = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs @@ -53,7 +53,7 @@ thingsHitLongLine sp ep w | otherwise = sortBy (compare `on` dist sp . fst) (crs ++ walls ++ ffs) where crs = zip crPs (map E3x1 hitCrs) - hitCrs = IM.elems $ IM.filter (\cr -> circOnLine sp ep (_crPos cr) (_crRad cr)) + hitCrs = IM.elems $ IM.filter (\cr -> circOnSeg sp ep (_crPos cr) (_crRad cr)) $ _creatures w -- $ creaturesAlongLine sp ep w crPs = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs diff --git a/src/Geometry.hs b/src/Geometry.hs index 630a19921..1f2e10cdf 100644 --- a/src/Geometry.hs +++ b/src/Geometry.hs @@ -1,4 +1,13 @@ {-# LANGUAGE BangPatterns #-} +{-| +Module : Geometry +Description : Geometry helpers + +This module provides geometry functions that manipulate pairs of floats. +Conventions: +Seg refers to a segment, typically defined by two points, and will typically not extend beyond either of these points. +Line refers to a line defined by two points, and extends beyond the two points. +-} module Geometry ( module Geometry , module Geometry.Data @@ -17,46 +26,61 @@ import Data.List import Data.Maybe import Control.Applicative --- TODO add bang patterns -alongLineBy :: Float -> Point2 -> Point2 -> Point2 -alongLineBy !x !a !b = a +.+ y *.* normalizeV (b -.- a) +-- | Return a point a distance away from a first point towards a second point. +-- Does not go past the second point. +alongSegBy :: Float -> Point2 -> Point2 -> Point2 +alongSegBy !x !a !b = a +.+ y *.* normalizeV (b -.- a) where y = min x $ dist a b - -closestPointOnLine :: Point2 -> Point2 -> Point2 -> Point2 +-- | Given a line and a point return the point on the line closest to the +-- point. +closestPointOnLine + :: Point2 -- ^ First line point. + -> Point2 -- ^ Second line point. + -> Point2 -- ^ Point not on line. + -> Point2 {-# INLINE closestPointOnLine #-} -closestPointOnLine !a !b !p = a +.+ u *.* (b -.- a) +closestPointOnLine !a !b !p = a +.+ u *.* (b -.- a) where u = closestPointOnLineParam a b p -closestPointOnLineParam :: Point2 -> Point2 -> Point2 -> Float +-- | Given a line and a point return a value corresponding to how far along the +-- line the point is. +closestPointOnLineParam + :: Point2 -- ^ First line point. + -> Point2 -- ^ Second line point. + -> Point2 -- ^ Point not on line. + -> Float {-# INLINE closestPointOnLineParam #-} 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 +-- | Draw 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) ] +-- | Draw a rectangle based on maximal N S E W values. rectNSEW :: Float -> Float -> Float -> Float -> [Point2] rectNSEW !n !s !e !w = rectNESW n e s w +-- | Draw a rectangle based on maximal N S W E values. rectNSWE :: Float -> Float -> Float -> Float -> [Point2] 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 +-- | Test whether a point is in a polygon or on the polygon border. +-- 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]) - +-- | Test whether a point is strictly inside a polygon. +-- Supposes the points in the polygon are listed in anticlockwise order. pointInPolygon :: Point2 -> [Point2] -> Bool pointInPolygon !p [] = False pointInPolygon !p (x:xs) = all (\l -> uncurry (errorIsLHS 1) l p) $ zip (x:xs) (xs ++ [x]) +-- | Debug version of 'pointInPolygon'. errorPointInPolygon :: Int -> Point2 -> [Point2] -> Bool errorPointInPolygon !i !p xs | length xs == 1 = error "one point polygon" @@ -64,43 +88,53 @@ errorPointInPolygon !i !p xs | nub xs == xs = pointInPolygon p xs | otherwise = error $ "errorPointInPolygon "++ show i +-- | Debug version of 'normalizeV'. errorNormalizeV :: Int -> Point2 -> Point2 errorNormalizeV !i !(0,0) = error $ "problem with function: errorNormalizeV "++show i errorNormalizeV !i !p = normalizeV p +-- | Debug version of 'angleVV'. 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' +-- | Debug version of 'isLHS'. errorIsLHS :: Int -> Point2 -> Point2 -> Point2 -> Bool errorIsLHS !i !x !y | x == y = error $ "problem with function: errorIsLHS " ++show i | otherwise = isLHS x y +-- | Debug version of 'closestPointOnLine' errorClosestPointOnLine :: Int -> Point2 -> Point2 -> Point2 -> Point2 errorClosestPointOnLine !i !x !y | x == y = error $ "problem with function: errorClosestPointOnLine " ++show i | otherwise = closestPointOnLine x y +-- | Debug version of 'closestPointOnLineParam' errorClosestPointOnLineParam :: Int -> Point2 -> Point2 -> Point2 -> Float errorClosestPointOnLineParam !i !x! y! z | x == y = dist x z | otherwise = closestPointOnLineParam x y z +-- | Normalize a vector to be unit length. +-- For (0,0) return (0,0). safeNormalizeV :: Point2 -> Point2 safeNormalizeV !(0,0) = (0,0) safeNormalizeV !p = normalizeV p --- tests whether a point is on the LHS of a line -isLHS :: Point2 -> Point2 -> Point2 -> Bool +-- | Test whether a point is on the LHS of a line. +-- Returns False if the line is of zero length. +isLHS + :: Point2 -- ^ First line point. + -> Point2 -- ^ Second line point. + -> Point2 -- ^ Point not on line. + -> 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 !(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 @@ -109,9 +143,18 @@ isLHS !(x,y) !(x',y') !(x'',y'') b1 = x'' - x b2 = y'' - y -isRHS :: Point2 -> Point2 -> Point2 -> Bool +-- | Test whether a point is on the LHS of a line. +-- Returns False if the line is of zero length. +isRHS + :: Point2 -- ^ First line point. + -> Point2 -- ^ Second line point. + -> Point2 -- ^ Point not on line. + -> 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 @@ -120,54 +163,69 @@ isRHS !(x,y) !(x',y') !(x'',y'') b1 = x'' - x b2 = y'' - y --- reorders points to be anticlockwise around their center +-- | Reorder 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 +-- | Return distance between two points. dist :: Point2 -> Point2 -> Float {-# INLINE dist #-} dist !p1 !p2 = magV (p2 -.- p1) - +-- | Return midpoint between two points. pHalf :: Point2 -> Point2 -> Point2 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) +-- | Test whether a circle is on a segment by intersecting a new normal segment through the +-- center of the circle with the segment itself. +-- Returns False if the circle center is beyond the enpoints of the +-- segment. +circOnSegNoEndpoints :: Point2 -> Point2 -> Point2 -> Float -> Bool +{-# INLINE circOnSegNoEndpoints #-} +circOnSegNoEndpoints !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 --- this should probably be circOnSeg -circOnLine :: Point2 -> Point2 -> Point2 -> Float -> Bool -{-# INLINE circOnLine #-} -circOnLine !p1 !p2 !c !rad = magV (p1 -.- c) <= rad || magV (p2 -.- c) <= rad +-- | Test whether a circle is on a segment by intersecting a normal and testing +-- the distance to the endpoints of the segment. +circOnSeg :: Point2 -> Point2 -> Point2 -> Float -> Bool +{-# INLINE circOnSeg #-} +circOnSeg !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 +-- | Find the difference between two Nums. difference :: (Ord a, Num a) => a -> a -> a difference x y | x > y = x - y | otherwise = y - x +-- | Given vector line direction and a vector movement, +-- reflects the movement accoring to the line. reflectIn :: Point2 -> Point2 -> Point2 reflectIn line vec = let angle = 2 * angleBetween line vec in rotateV angle vec +-- | Find angle between two points. +-- Not normalised, ranges from -2*pi to 2*pi. angleBetween :: Point2 -> Point2 -> Float angleBetween v1 v2 = argV v1 - argV v2 +-- | Return a list containing two copies of a pair. doublePair :: (a,a) -> [(a,a)] doublePair (x,y) = [(x,y),(y,x)] +-- | Test whether two polygons intersect by testing the intersection of each +-- consecutive pair of points. polysIntersect :: [Point2] -> [Point2] -> Bool polysIntersect (p:ps) (q:qs) = any isJust $ (\(a,b) (c,d) -> myIntersectSegSeg a b c d) <$> pairs1 <*> pairs2 @@ -178,25 +236,33 @@ polysIntersect (p:ps) (q:qs) polysIntersect [] _ = False polysIntersect _ [] = False +-- | Test whether any polygons from a first list intersect with any polygons from +-- a second list. anyPolyssIntersect :: [[Point2]] -> [[Point2]] -> Bool anyPolyssIntersect x y = or $ polysIntersect <$> x <*> y +-- | Return n equidistant points on a circle with a radius of 600. nRays :: Int -> [Point2] nRays n = take n $ iterate (rotateV (2*pi/fromIntegral n)) (600,0) +-- | Return n equidistant points on a circle with a radius of x. 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 +-- | Test whether an angle is to the left of another angle, according to the +-- smallest change in rotation between them. isLeftOfA :: Float -> Float -> Bool isLeftOfA angle1 angle2 = (angle1 - angle2 < pi && angle1 > angle2) || (angle2 - angle1 > pi && angle2 > angle1) +-- | Test whether a vector is to the left of another, according to the smallest +-- change of rotation between them. isLeftOf :: Point2 -> Point2 -> Bool isLeftOf x y = isLeftOfA (argV x) (argV y) --- diffAngles has an issue... +-- | Find the difference between two angles. +-- Possibly not correct... diffAngles :: Float -> Float -> Float diffAngles x y | diff > pi = diffAngles (x - 2*pi) y @@ -209,10 +275,10 @@ diffAngles x y differenceAngles = diffAngles angleDifference = diffAngles --- given a triangle where we know the length of a first side, +-- | Given a triangle where we know the length of a first side, -- the length of a second side, and the angle between the first side and the --- third side, finds the length of the third side --- not this doesn't necessarily find ALL solutions, asin is a map not a function +-- third side, finds the length of the third side. +-- Note this doesn't necessarily find ALL solutions, asin is a map not a function. ssaTri :: Float -> Float -> Float -> Float ssaTri ab bc a | sin a == 0 = 0 @@ -222,12 +288,10 @@ ssaTri ab bc a 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: --- the point which lies between pa and pc' on a line from b of length bc --- note that there are likely two such points, this seems to return the point --- closer to pc' - +-- | Given two points of a triangle and a third point, return +-- the point which lies between pa and pc' on a line from pb of length bc. +-- Note that there are likely two such points, this should return the point +-- closer to pc'. ssaTriPoint :: Point2 -> Point2 -> Point2 -> Float -> Point2 ssaTriPoint pa pb pc' bc = let ab = magV (pa -.- pb) @@ -235,13 +299,15 @@ ssaTriPoint pa pb pc' bc ac = ssaTri ab bc a in pa +.+ (ac *.* errorNormalizeV 47 (pc' -.- pa)) --- the above SHOULD return a Maybe Point... +-- | Safe version of 'ssaTriPoint'. ssaTriPoint' :: Point2 -> Point2 -> Point2 -> Float -> Maybe Point2 ssaTriPoint' pa pb pc' bc | dist pb (closestPointOnSeg pa pc' pb) >= bc = Nothing | otherwise = 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 @@ -250,42 +316,42 @@ ssaTriPointCorrect pa pb pc' bc p = ssaTriPoint pa pb pc' bc param = closestPointOnLineParam pa pc' p - +-- | Given a segment and external point, find the closest point on the segment. closestPointOnSeg :: Point2 -> Point2 -> Point2 -> Point2 closestPointOnSeg segP1 segP2 p | errorClosestPointOnLineParam 3 segP1 segP2 p <= 0 = segP1 | errorClosestPointOnLineParam 4 segP1 segP2 p >= 1 = segP2 | otherwise = errorClosestPointOnLine 2 segP1 segP2 p +-- | Return Just a point if it is inside a circle, Nothing otherwise. pointInCircle :: Point2 -> Float -> Point2 -> Maybe Point2 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 ---throught the circle : HOPEFULLY THE CORRECT OF THE TWO! - +-- | Determines if a moving point intersects with a circle, +-- if so, returns a point on circle that intersects with the line passing +-- throught the circle : HOPEFULLY THE CORRECT OF THE TWO! collidePointCirc :: Point2 -> Point2 -> Float -> Point2 -> Maybe Point2 collidePointCirc p1 p2 rad c = ssaTriPoint' p2 c p1 rad --- changes the point to a measure of the distance +-- | As 'collidePointCirc', but changes the point to a measure of the distance. collidePointCirc' :: Point2 -> Point2 -> Float -> Point2 -> Maybe Float collidePointCirc' p1 p2 rad c = fmap (\x -> magV (x -.- p1)) (collidePointCirc p1 p2 rad c) ---returns both the point and the measure of the distance +-- | As 'collidePointCirc', but returns both the point and the measure of the distance. collidePointCirc'' :: Point2 -> Point2 -> Float -> Point2 -> Maybe (Point2,Float) 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 --- the base is the line between the first two points +-- | 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 @@ -296,7 +362,8 @@ heron x y z s = (a+b+c)/2 area = sqrt(s*(s-a)*(s-b)*(s-c)) in 2*area/a --- multiplies reflection in normal by factor + +-- | Multiplies reflection in normal by factor. reflectInParam :: Float -> Point2 -> Point2 -> Point2 reflectInParam x line vec = let angle = 2 * angleBetween line vec @@ -304,16 +371,17 @@ reflectInParam x line 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) -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 +--isOnSeg :: Point2 -> Point2 -> Point2 -> Bool +--isOnSeg l1 l2 p = +-- errorClosestPointOnLineParam 10 l1 (l1 +.+ vNormal (l2 -.- l1)) p == 0 +-- && errorClosestPointOnLineParam 11 l1 l2 p <= 1 +-- && errorClosestPointOnLineParam 12 l1 l2 p >= 0 +-- | Divide a segment into a list of points with a maximal distance between +-- them. -- 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] @@ -327,6 +395,7 @@ divideLine x a b = numPoints = max 1 $ ceiling $ d / x ns = [0 .. numPoints] +-- | As 'divideLine', but must return an odd number of points. divideLineOddNumPoints :: Float -> Point2 -> Point2 -> [Point2] --divideLine x a b = map (\i -> a +.+ (i / (fromIntegral numPoints)) *.* (b -.- a)) divideLineOddNumPoints x a b = take 5000 @@ -339,29 +408,8 @@ divideLineOddNumPoints x a b = take 5000 | otherwise = numPoints' + 1 ns = [0 .. numPoints] --- pulled the following from the haskell wiki --- it seems to produce an infinite loop sometimes --- fuck that, don't trust random code on the internet -bresenham :: (Int,Int) -> (Int,Int) -> [(Int,Int)] -{-# INLINE bresenham #-} -bresenham pa@(xa,ya) pb@(xb,yb) = map maySwitch . unfoldr go $ (x1,y1,0) - where - steep = abs (yb - ya) > abs (xb - xa) - maySwitch = if steep then (\(x,y) -> (y,x)) else id - [(x1,y1),(x2,y2)] = sort [maySwitch pa, maySwitch pb] - deltax = x2 - x1 - deltay = abs (y2 - y1) - ystep = if y1 < y2 then 1 else -1 - go (xTemp, yTemp, error) - | xTemp > x2 = Nothing - | otherwise = Just ((xTemp, yTemp), (xTemp + 1, newY, newError)) - where - tempError = error + deltay - (newY, newError) = - if (2*tempError) >= deltax - then (yTemp+ystep,tempError-deltax) - else (yTemp,tempError) - +-- | Given two pairs of Ints, returns a list of pairs of Ints that form +-- a digital line between them. digitalLine :: (Int,Int) -> (Int,Int) -> [(Int,Int)] digitalLine (x1,y1) (x2,y2) | abs (x1-x2) > abs (y1-y2) = [ (x,( (y1-y2) * x + x1*y2 - x2*y1) `rdiv` (x1-x2) ) @@ -371,34 +419,44 @@ digitalLine (x1,y1) (x2,y2) where rdiv a b = round $ fromIntegral a / fromIntegral b +-- | Given two Ints, creates the list of Ints between these. intervalList :: Int -> Int -> [Int] intervalList x y | y >= x = [x .. y] | otherwise = reverse [y..x] +-- | Create points on the circumference of a circle with maximal distance +-- between them. divideCircle :: Float -> Point2 -> Float -> [Point2] -divideCircle x cen rad = map (cen +.+) $ nPointsOnCirc n rad +divideCircle x cen rad = map (cen +.+) $ nRaysRad n rad where n = ceiling $ rad * 2 * pi / x -nPointsOnCirc :: Int -> Float -> [Point2] -nPointsOnCirc n rad = take n $ iterate (rotateV (2*pi/fromIntegral n)) (rad,0) +--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 :: 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]) +-- | Given a list of points, returns pairs of points linking the points into a +-- loop. makeLoopPairs :: [Point2] -> [(Point2,Point2)] makeLoopPairs [] = error "tried to make loop with empty list of points" makeLoopPairs [x] = error "tried to make loop with singleton list of points" makeLoopPairs (x:xs) = zip (x:xs) (xs ++ [x]) --- note the pair is ordered --- doesn't work for obtuse angles -pointIsInCone :: Point2 -> (Point2,Point2) -> Point2 -> Bool +-- | Test whether a point is in a cone. +-- Note the pair is ordered. +-- Doesn't work for obtuse angles. +pointIsInCone + :: Point2 -- ^ Cone point. + -> (Point2,Point2) -- ^ Points delimiting the left and right boundaries of the cone. + -> Point2 -- ^ Point to test. + -> Bool pointIsInCone c (rightp,leftp) p = isLHS c rightp p && isLHS leftp c p diff --git a/test/Spec.hs b/test/Spec.hs index e6231f44e..dded26738 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -30,9 +30,9 @@ polygonStrictlyConvex ps = True --prop_looping :: [Point2] -> [WallP] -> Bool prop_looping = forAllShrink genTris shrinkTris $ \tris -> - (all (not . (\[a,b,c] -> isOnLine a b c - || isOnLine a c b - || isOnLine b c a + (all (not . (\[a,b,c] -> isOnSeg a b c + || isOnSeg a c b + || isOnSeg b c a ) ) tris) ==> (isLooping' $ foldr cutWalls' [] tris)