From b7b196c2d8245b5678debd4cd7ebb0e803f45dfd Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Fri, 14 Oct 2022 01:10:29 +0000 Subject: [PATCH 001/206] move from normalizePLine2WithErr to normalize. --- Graphics/Slicer/Math/Lossy.hs | 8 +++---- Graphics/Slicer/Math/PGA.hs | 45 +++++++++++++++++++---------------- tests/Math/PGA.hs | 18 +++++++------- 3 files changed, 37 insertions(+), 34 deletions(-) diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index 81a69ab75..68da11511 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -49,7 +49,7 @@ import Graphics.Slicer.Definitions (ℝ) import Graphics.Slicer.Math.Definitions (LineSeg, Point2) -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2, PLine2, PPoint2(PPoint2), ProjectivePoint2, angleBetweenWithErr, canonicalizePPoint2WithErr, distanceBetweenPPointsWithErr, distanceBetweenNPLine2sWithErr, distanceCPPointToNPLineWithErr, distancePPointToPLineWithErr, eToCPPoint2WithErr, eToPLine2WithErr, eToPPoint2WithErr, getFirstArcWithErr, getInsideArcWithErr, join2CPPoint2WithErr, join2PPoint2WithErr, makeCPPoint2WithErr, normalizePLine2WithErr, pLineFromEndpointsWithErr, pPointBetweenPPointsWithErr, pPointOnPerpWithErr, translatePLine2WithErr) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2, PLine2, PPoint2(PPoint2), ProjectiveLine2, ProjectivePoint2, angleBetweenWithErr, canonicalizePPoint2WithErr, distanceBetweenPPointsWithErr, distanceBetweenNPLine2sWithErr, distanceCPPointToNPLineWithErr, distancePPointToPLineWithErr, eToCPPoint2WithErr, eToPLine2WithErr, eToPPoint2WithErr, getFirstArcWithErr, getInsideArcWithErr, join2CPPoint2WithErr, join2PPoint2WithErr, makeCPPoint2WithErr, normalize, pLineFromEndpointsWithErr, pPointBetweenPPointsWithErr, pPointOnPerpWithErr, translatePLine2WithErr) angleBetween :: NPLine2 -> NPLine2 -> ℝ angleBetween nPLine1 nPLine2 = fst $ angleBetweenWithErr nPLine1 nPLine2 @@ -78,7 +78,7 @@ eToCPPoint2 point = fst $ eToCPPoint2WithErr point -- | Create a normalized projective line from a euclidian line segment. eToNPLine2 :: LineSeg -> NPLine2 -eToNPLine2 l1 = normalizePLine2 $ fst $ eToPLine2WithErr l1 +eToNPLine2 l1 = fst $ normalize $ fst $ eToPLine2WithErr l1 -- | Create an un-normalized projective line from a euclidian line segment. eToPLine2 :: LineSeg -> PLine2 @@ -114,8 +114,8 @@ makePPoint2 :: ℝ -> ℝ -> PPoint2 makePPoint2 x y = (\(CPPoint2 p) -> PPoint2 p) $ fst $ makeCPPoint2WithErr x y -- | Normalize a PLine2. -normalizePLine2 :: PLine2 -> NPLine2 -normalizePLine2 pl = fst $ normalizePLine2WithErr pl +normalizePLine2 :: (ProjectiveLine2 a) => a -> NPLine2 +normalizePLine2 pl = fst $ normalize pl -- | Create a projective line from a pair of euclidian points. pLineFromEndpoints :: Point2 -> Point2 -> PLine2 diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 495720e05..8a098f424 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -24,15 +24,16 @@ -- | The purpose of this file is to hold projective geometric algebraic arithmatic. It defines a 2D PGA with mixed linear components. module Graphics.Slicer.Math.PGA( + Arcable(hasArc, outOf, ulpOfOut, outUlpMag), + CPPoint2(CPPoint2), Intersection(HitStartPoint, HitEndPoint, NoIntersection), NPLine2(NPLine2), PIntersection (PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), PLine2(PLine2), - PPoint2(PPoint2), - CPPoint2(CPPoint2), - Arcable(hasArc, outOf, ulpOfOut, outUlpMag), Pointable(canPoint, pPointOf, ePointOf), + PPoint2(PPoint2), PPoint2PosErr(PPoint2PosErr), + ProjectiveLine2, ProjectivePoint2, angleBetweenWithErr, combineConsecutiveLineSegs, @@ -53,7 +54,7 @@ module Graphics.Slicer.Math.PGA( join2PPoint2WithErr, join2CPPoint2WithErr, makeCPPoint2WithErr, - normalizePLine2WithErr, + normalize, outputIntersectsLineSeg, pLineFromEndpointsWithErr, pLineIntersectionWithErr, @@ -382,8 +383,8 @@ outputIntersectsLineSeg source (l1, UlpSum l1Err) ulpScale :: ℝ ulpScale = realToFrac $ ulpMultiplier * realToFrac travelUlpMul * abs (realToFrac angle + angleErr) (angle, UlpSum angleErr) = angleBetweenWithErr npl1 npl2 - (npl1, UlpSum npl1Err) = normalizePLine2WithErr pl1 - (npl2, UlpSum npl2Err) = normalizePLine2WithErr pl2 + (npl1, UlpSum npl1Err) = normalize pl1 + (npl2, UlpSum npl2Err) = normalize pl2 (pl2, UlpSum pl2Err) = eToPLine2WithErr l1 -- the multiplier to account for distance between our Pointable, and where it intersects. travelUlpMul @@ -413,16 +414,16 @@ intersectsWithErr (Left l1@(rawL1,_)) (Right pl1@(rawPL1,_)) = ulpScale :: ℝ ulpScale = realToFrac $ ulpMultiplier * (abs (realToFrac angle) + angleErr) (angle, UlpSum angleErr) = angleBetweenWithErr npl1 npl2 - (npl1, _) = normalizePLine2WithErr rawPL1 - (npl2, _) = normalizePLine2WithErr pl2 + (npl1, _) = normalize rawPL1 + (npl2, _) = normalize pl2 (pl2, _) = eToPLine2WithErr rawL1 intersectsWithErr (Right pl1@(rawPL1,_)) (Left l1@(rawL1,_)) = pLineIntersectsLineSeg pl1 l1 ulpScale where ulpScale :: ℝ ulpScale = realToFrac $ ulpMultiplier * (abs (realToFrac angle) + angleErr) (angle, UlpSum angleErr) = angleBetweenWithErr npl1 npl2 - (npl1, _) = normalizePLine2WithErr rawPL1 - (npl2, _) = normalizePLine2WithErr pl2 + (npl1, _) = normalize rawPL1 + (npl2, _) = normalize pl2 (pl2, _) = eToPLine2WithErr rawL1 -- | Check if/where a line segment and a PLine intersect. @@ -500,8 +501,8 @@ lineSegIntersectsLineSeg (l1, UlpSum l1Err) (l2, UlpSum ulpL2) | otherwise = pl1Err + pl2Err + l1Err + ulpL2 + (rawIntersectErr * ulpScale) ulpScale = 120 + ulpMultiplier * (realToFrac angle+angleErr) * (realToFrac angle+angleErr) (angle, UlpSum angleErr) = angleBetweenWithErr npl1 npl2 - (npl1, _) = normalizePLine2WithErr pl1 - (npl2, _) = normalizePLine2WithErr pl2 + (npl1, _) = normalize pl1 + (npl2, _) = normalize pl2 dumpULPs = "pl1Err: " <> show pl1Err <> "\npl2Err: " <> show pl2Err <> "\nl1Err: " <> show l1Err <> "\nrawIntersectErr: " <> show rawIntersectErr <> "\n" hasIntersection = hasRawIntersection && onSegment l1 rawIntersection ulpStartSum1 ulpEndSum1 && onSegment l2 rawIntersection ulpStartSum2 ulpEndSum2 hasRawIntersection = valOf 0 foundVal /= 0 @@ -571,13 +572,13 @@ getFirstArcWithErr p1 p2 p3 | otherwise = (insideArc, UlpSum $ side1Err + side2Err + insideArcErr) where (insideArc, UlpSum insideArcErr) = getInsideArcWithErr (PLine2 side1) (PLine2 side2) - (NPLine2 side1, UlpSum side1NormErr) = normalizePLine2WithErr side1Raw + (NPLine2 side1, UlpSum side1NormErr) = normalize side1Raw (side1Raw, UlpSum side1RawErr) = pLineFromEndpointsWithErr p1 p2 side1Err = side1NormErr+side1RawErr - (NPLine2 side2, UlpSum side2NormErr) = normalizePLine2WithErr side2Raw + (NPLine2 side2, UlpSum side2NormErr) = normalize side2Raw (side2Raw, UlpSum side2RawErr) = pLineFromEndpointsWithErr p2 p3 side2Err = side2NormErr+side2RawErr - (NPLine2 quadRes, UlpSum quadResErr) = normalizePLine2WithErr quad + (NPLine2 quadRes, UlpSum quadResErr) = normalize quad (quad, UlpSum quadErr) = pLineFromEndpointsWithErr p2 $ scalePoint 0.5 $ addPoints p1 p3 {- scaleSide ps1 ps2 t v @@ -954,12 +955,14 @@ canonicalizeIntersectionWithErr pl1 pl2 -- | Normalize a PLine2. normalizePLine2WithErr :: (ProjectiveLine2 a) => a -> (NPLine2, UlpSum) -normalizePLine2WithErr line = (res, ulpTotal) - where - res = NPLine2 $ fst $ divVecScalarWithErr vec normOfMyPLine - (normOfMyPLine, UlpSum normErr) = normOfPLine2WithErr line - ulpTotal = UlpSum $ normErr + resErr - (UlpSum resErr) = ulpOfPLine2 res +normalizePLine2WithErr line = (res, resErr) + where + (res, resErr) = case norm of + 1.0 -> (NPLine2 vec, mempty) + _ -> (NPLine2 $ scaledVec, ulpTotal) + (scaledVec, _) = divVecScalarWithErr vec norm + (norm, normErr) = normOfPLine2WithErr line + ulpTotal = normErr <> ulpOfPLine2 res vec = vecOfL line -- | find the norm of a given PLine2 diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index 9cd279214..7d6c60d2f 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -59,7 +59,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(GEZero, GEPlu import Graphics.Slicer.Math.Lossy (angleBetween, canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenNPLine2s, distancePPointToPLine, eToCPPoint2, eToPLine2, eToPPoint2, getFirstArc, join2PPoint2, makeCPPoint2, makePPoint2, normalizePLine2, pPointOnPerp) -- Our 2D Projective Geometric Algebra library. -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PPoint2PosErr(PPoint2PosErr), canonicalizePPoint2WithErr, pPointBetweenPPointsWithErr, distanceBetweenPPointsWithErr, distanceCPPointToNPLineWithErr, join2CPPoint2WithErr, pLineIntersectionWithErr, translatePLine2WithErr, translateRotatePPoint2, angleBetweenWithErr, flipPLine2, makeCPPoint2WithErr, normalizePLine2WithErr, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, pLineFromEndpointsWithErr, distancePPointToPLineWithErr, pPointOnPerpWithErr, outOf, pPointOf, ulpOfOut, outputIntersectsLineSeg, pPointBetweenPPointsWithErr) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PPoint2PosErr(PPoint2PosErr), canonicalizePPoint2WithErr, pPointBetweenPPointsWithErr, distanceBetweenPPointsWithErr, distanceCPPointToNPLineWithErr, join2CPPoint2WithErr, pLineIntersectionWithErr, translatePLine2WithErr, translateRotatePPoint2, angleBetweenWithErr, flipPLine2, makeCPPoint2WithErr, normalize, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, pLineFromEndpointsWithErr, distancePPointToPLineWithErr, pPointOnPerpWithErr, outOf, pPointOf, ulpOfOut, outputIntersectsLineSeg, pPointBetweenPPointsWithErr) -- Our Contour library. import Graphics.Slicer.Math.Contour (contourContainsContour, getContours, pointsOfContour, numPointsOfContour, justOneContourFrom, lineSegsOfContour, makeLineSegContour, makePointContour, insideIsLeft, innerContourPoint, firstPointPairOfContour, firstLineSegOfContour) @@ -404,11 +404,11 @@ prop_perpAt90Degrees x y rawX2 y2 rawD (bisectorEndRaw, UlpSum bisectorEndRawErr) = pPointOnPerpWithErr pline4 (PPoint2 rawBisectorStart) d (bisectorEnd, UlpSum bisectorEndErr) = canonicalizePPoint2WithErr bisectorEndRaw (pline3, UlpSum pline3Err) = join2CPPoint2WithErr (CPPoint2 rawBisectorStart) bisectorEnd - (normedPLine3, UlpSum norm3Err) = normalizePLine2WithErr pline3 + (normedPLine3, UlpSum norm3Err) = normalize pline3 (sourceStart, PPoint2PosErr sourceStartErr) = makeCPPoint2WithErr x y (sourceEnd, PPoint2PosErr sourceEndErr) = makeCPPoint2WithErr x2 y2 (pline4, UlpSum pline4Err) = join2CPPoint2WithErr sourceStart sourceEnd - (normedPLine4, UlpSum norm4Err) = normalizePLine2WithErr pline4 + (normedPLine4, UlpSum norm4Err) = normalize pline4 errTotal3 = angle2Err + norm3Err + pline3Err + pline4Err + norm4Err + bisectorStartErr + bisectorEndRawErr + bisectorEndErr + sourceStartErr + sourceEndErr errTotal4 = angle2Err + norm3Err + pline3Err + pline4Err + norm4Err + bisectorStartErr + bisectorEndRawErr + bisectorEndErr + sourceStartErr + sourceEndErr x2 :: ℝ @@ -463,8 +463,8 @@ prop_PerpTranslateID x y dx dy rawT <> "resErr: " <> show resErr <> "\n" where res = distanceBetweenNPLine2s resNPLine origNPLine - (resNPLine, UlpSum resNErr) = normalizePLine2WithErr resPLine - (origNPLine, UlpSum origNErr) = normalizePLine2WithErr origPLine + (resNPLine, UlpSum resNErr) = normalize resPLine + (origNPLine, UlpSum origNErr) = normalize origPLine (resPLine, UlpSum resPLineErr) = translatePLine2WithErr translatedPLine (-t) (translatedPLine, UlpSum translatedPLineErr) = translatePLine2WithErr origPLine t (origPLine, UlpSum origPLineErr) = randomPLineWithErr x y dx dy @@ -513,7 +513,7 @@ prop_QuadBisectorCrosses rawX1 rawY1 rawX2 rawY2 intersect4 = outputIntersectsLineSeg eNode (lineSeg2, lineSeg2Err) -- note that our bisector always intersects the origin. (bisector, UlpSum bisectorUlp) = pLineFromEndpointsWithErr (Point2 (0,0)) (Point2 (x3,y3)) - (NPLine2 bisector1, UlpSum bisector1Ulp) = normalizePLine2WithErr bisector + (NPLine2 bisector1, UlpSum bisector1Ulp) = normalize bisector bisector1Err = bisectorUlp + bisector1Ulp bisector2 = getFirstArc (Point2 (x1,y1)) (Point2 (0,0)) (Point2 (x2,y2)) eNode = makeENode (Point2 (x1,y1)) (Point2 (0,0)) (Point2 (x2,y2)) @@ -567,7 +567,7 @@ prop_QuadBisectorCrossesMultiple rawX1 rawY1 rawX2 rawY2 rawTimes intersect3 = outputIntersectsLineSeg eNode (lineSeg1, lineSeg1Err) intersect4 = outputIntersectsLineSeg eNode (lineSeg2, lineSeg2Err) -- note that our bisector always intersects the origin. - (NPLine2 bisector1, UlpSum bisector1Ulp) = normalizePLine2WithErr bisector + (NPLine2 bisector1, UlpSum bisector1Ulp) = normalize bisector (bisector, UlpSum bisectorUlp) = pLineFromEndpointsWithErr (Point2 (0,0)) (Point2 (x3,y3)) bisector1Err = bisectorUlp + bisector1Ulp eNode = makeENode (Point2 (x1,y1)) (Point2 (0,0)) (Point2 (x2,y2)) @@ -1235,7 +1235,7 @@ prop_PLineWithinErrRange1 x1 y1 rawX2 rawY2 (distance2, UlpSum distance2Err) = distanceCPPointToNPLineWithErr pPoint2 nPLine (pPoint1, PPoint2PosErr ulpSumP1) = makeCPPoint2WithErr x1 y1 (pPoint2, PPoint2PosErr ulpSumP2) = makeCPPoint2WithErr x2 y2 - (nPLine, UlpSum nPLineErr) = normalizePLine2WithErr pLine + (nPLine, UlpSum nPLineErr) = normalize pLine (pLine, UlpSum ulpPLine) = pLineFromEndpointsWithErr (Point2 (x1,y1)) (Point2 (x2,y2)) ulpTotal1 = ulpSumP1 + ulpPLine + distance1Err + nPLineErr ulpTotal2 = ulpSumP2 + ulpPLine + distance2Err + nPLineErr @@ -1272,7 +1272,7 @@ prop_PLineWithinErrRange2 x1 y1 rawX2 rawY2 (CPPoint2 pPoint1, PPoint2PosErr ulpSumP1) = makeCPPoint2WithErr x1 y1 (CPPoint2 pPoint2, PPoint2PosErr ulpSumP2) = makeCPPoint2WithErr x2 y2 (pLine1, UlpSum ulpPLine) = join2CPPoint2WithErr (CPPoint2 pPoint1) (CPPoint2 pPoint2) - (NPLine2 lvec, UlpSum normErr) = normalizePLine2WithErr pLine1 + (NPLine2 lvec, UlpSum normErr) = normalize pLine1 ulpTotal1 = ulpSumP1 + ulpPLine + distance1Err ulpTotal2 = ulpSumP2 + ulpPLine + distance2Err -- make sure we do not try to create a 0 length line segment. From 2c13c6ad34450bf404e8ce1024249bac7af0e119 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Fri, 14 Oct 2022 11:00:58 +0000 Subject: [PATCH 002/206] add short circuits to skip computation, and the error of computation, when the square norm is calculated to be 1.0. --- Graphics/Slicer/Math/PGA.hs | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 8a098f424..3d5facbc7 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -958,22 +958,26 @@ normalizePLine2WithErr :: (ProjectiveLine2 a) => a -> (NPLine2, UlpSum) normalizePLine2WithErr line = (res, resErr) where (res, resErr) = case norm of - 1.0 -> (NPLine2 vec, mempty) + 1.0 -> (NPLine2 vec, normErr) _ -> (NPLine2 $ scaledVec, ulpTotal) (scaledVec, _) = divVecScalarWithErr vec norm (norm, normErr) = normOfPLine2WithErr line ulpTotal = normErr <> ulpOfPLine2 res vec = vecOfL line --- | find the norm of a given PLine2 +-- | find the norm of a given ProjectiveLine. normOfPLine2WithErr :: (ProjectiveLine2 a) => a -> (ℝ, UlpSum) -normOfPLine2WithErr pline = (res, ulpTotal) +normOfPLine2WithErr pline = (res, resErr) where - res = sqrt sqNormOfPLine2 - (sqNormOfPLine2, UlpSum sqNormErr) = sqNormOfPLine2WithErr pline - ulpTotal = UlpSum $ abs (realToFrac $ doubleUlp res) + sqNormErr + (res, resErr) = case sqNormOfPLine2 of + 1.0 -> (1.0, sqNormErr) + _ -> (sqrt sqNormOfPLine2, ulpTotal) + (sqNormOfPLine2, sqNormErr) = sqNormOfPLine2WithErr pline + rawRes = sqrt sqNormOfPLine2 + -- FIXME: these are two types of error. track them separately in PLine2Err? + ulpTotal = UlpSum (abs $ realToFrac $ doubleUlp rawRes) <> sqNormErr --- | find the squared norm of a given PLine2 +-- | find the squared norm of a given ProjectiveLine sqNormOfPLine2WithErr :: (ProjectiveLine2 a) => a -> (ℝ, UlpSum) sqNormOfPLine2WithErr line = (res, ulpTotal) where From 506ce319ddefcc75a094717ad23f6676181e9436 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Fri, 14 Oct 2022 11:09:01 +0000 Subject: [PATCH 003/206] add short circuits to skip computation, and the error of computation, when the square norm is calculated to be 1.0. --- Graphics/Slicer/Math/PGA.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 3d5facbc7..ea005bd7f 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -679,6 +679,8 @@ data PLine2Err = PLine2Err [ErrVal] -- NormErr UlpSum + -- SqNormErr + UlpSum -- Translation Error. always in GEZero 1. UlpSum -- JoinErr From 586d7afca47adcf78c855b870e83cfff1516046c Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Fri, 14 Oct 2022 15:38:27 +0000 Subject: [PATCH 004/206] expand PLine2Err usage, and correct some lost precision in the normalization of lines. --- Graphics/Slicer/Math/PGA.hs | 77 ++++++++++--------- tests/golden/C7-Cell1-NodeTree.ganja.js | 53 ------------- tests/golden/square-Faces-Default.ganja.js | 40 ++++++---- .../golden/square-Straight_Skeleton.ganja.js | 18 +++-- 4 files changed, 79 insertions(+), 109 deletions(-) delete mode 100644 tests/golden/C7-Cell1-NodeTree.ganja.js diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index ea005bd7f..74fc331f2 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -70,7 +70,7 @@ module Graphics.Slicer.Math.PGA( ulpOfPLine2 ) where -import Prelude (Bool, Eq((==),(/=)), Show(show), Ord, ($), (*), (-), (>=), (&&), (<$>), mempty, otherwise, signum, (>), (<=), (+), sqrt, negate, (/), (||), (<), (<>), abs, error, sin, cos, realToFrac, fst, sum, (.), realToFrac) +import Prelude (Bool, Eq((==),(/=)), Semigroup((<>)), Show(show), Ord, ($), (*), (-), (>=), (&&), (<$>), mempty, otherwise, signum, (>), (<=), (+), sqrt, negate, (/), (||), (<), abs, error, sin, cos, realToFrac, fst, sum, (.)) import GHC.Generics (Generic) @@ -96,7 +96,7 @@ import Graphics.Slicer.Definitions (ℝ) import Graphics.Slicer.Math.Definitions (Point2(Point2), LineSeg(LineSeg), addPoints, scalePoint, startPoint, endPoint, distance) -import Graphics.Slicer.Math.GeometricAlgebra (ErrVal, GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎣+), (⎤+), (⨅), (⨅+), (∧), (•), addValWithoutErr, addVecPairWithErr, addVecPairWithoutErr, divVecScalarWithErr, getVal, mulScalarVecWithErr, scalarPart, sumErrVals, ulpVal, valOf, vectorPart) +import Graphics.Slicer.Math.GeometricAlgebra (ErrVal, GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎣+), (⎤+), (⨅), (⨅+), (∧), (•), addErr, addValWithoutErr, addVecPairWithErr, addVecPairWithoutErr, divVecScalarWithErr, getVal, mulScalarVecWithErr, scalarPart, sumErrVals, ulpVal, valOf, vectorPart) import Graphics.Slicer.Math.Line (combineLineSegs) @@ -203,13 +203,13 @@ distanceCPPointToNPLineWithErr point line | valOf 0 foundVal == 0 = error "attempted to get the distance of an ideal point." | otherwise = (res, ulpTotal) where - (res, resErr) = normOfPLine2WithErr newPLine + (res, _) = normOfPLine2WithErr newPLine (newPLine, newPLineErr) = join2CPPoint2WithErr point linePoint (perpLine, (plMulErr,plAddErr))= lvec ⨅+ npvec (PLine2 lvec) = forcePLine2Basis (PLine2 nplvec) (CPPoint2 npvec) = forceCPPoint2Basis point (linePoint, lpErr) = fromJust $ canonicalizeIntersectionWithErr (PLine2 lvec) (PLine2 perpLine) - ulpTotal = sumErrVals plMulErr <> sumErrVals plAddErr <> resErr <> newPLineErr <> lpErr + ulpTotal = sumErrVals plMulErr <> sumErrVals plAddErr {- <> resErr -} <> newPLineErr <> lpErr foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(CPPoint2 (GVec vals)) -> vals) point (NPLine2 nplvec,_) = normalize line @@ -234,9 +234,9 @@ pPointsOnSameSideOfPLine point1 point2 line distanceBetweenPPointsWithErr :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> (ℝ, UlpSum) distanceBetweenPPointsWithErr point1 point2 = (res, ulpTotal) where - (res, UlpSum resErr) = normOfPLine2WithErr newPLine - (newPLine, UlpSum newPLineErr) = join2CPPoint2WithErr cpoint1 cpoint2 - ulpTotal = UlpSum $ resErr + newPLineErr + (res, _) = normOfPLine2WithErr newPLine + (newPLine, newPLineUlp) = join2CPPoint2WithErr cpoint1 cpoint2 + ulpTotal = newPLineUlp -- resErr -- <> PLine2Err _ _ _ _ _ newPLineUlp (cpoint1, _) = canonicalize point1 (cpoint2, _) = canonicalize point2 @@ -304,13 +304,13 @@ pPointOnPerpWithErr line rppoint d = (PPoint2 res, -- | Translate a line a given distance along it's perpendicular bisector. -- Abuses the property that translation of a line is expressed on the GEZero component. translateProjectiveLine2WithErr :: GVec -> ℝ -> (GVec, PLine2Err) -translateProjectiveLine2WithErr lineVec d = (res, PLine2Err resErr mempty nErr tErr mempty) +translateProjectiveLine2WithErr lineVec d = (res, nErr <> PLine2Err resUlp mempty mempty mempty tUlp mempty) where - (res, resErr) = addVecPairWithErr m lineVec + (res, resUlp) = addVecPairWithErr m lineVec m = GVec [GVal tAdd (singleton (GEZero 1))] -- the amount to add to the GEZero 1 component. tAdd = d * n - tErr = UlpSum $ abs $ realToFrac $ doubleUlp tAdd + tUlp = UlpSum $ abs $ realToFrac $ doubleUlp tAdd (n, nErr) = normOfPLine2WithErr (PLine2 lineVec) -- | Translate a point a given distance away from where it is, rotating it a given amount clockwise (in radians) around it's original location, with 0 degrees being aligned to the X axis. @@ -661,14 +661,14 @@ instance ProjectiveLine2 NPLine2 where normalize a = (a, mempty) flipPLine2 (NPLine2 a) = NPLine2 $ flipGVec a forcePLine2Basis (NPLine2 a) = NPLine2 $ forceProjectiveLine2Basis a - translatePLine2WithErr (NPLine2 a) d = (\(b,(PLine2Err _ _ _ t _)) -> (NPLine2 b,t)) $ translateProjectiveLine2WithErr a d + translatePLine2WithErr (NPLine2 a) d = (\(b,(PLine2Err _ _ _ _ t _)) -> (NPLine2 b,t)) $ translateProjectiveLine2WithErr a d vecOfL (NPLine2 a) = a instance ProjectiveLine2 PLine2 where - normalize a = normalizePLine2WithErr a + normalize a = (\(b,(PLine2Err _ _ c d _ _)) -> (b,c <> d)) $ normalizePLine2WithErr a flipPLine2 (PLine2 a) = PLine2 $ flipGVec a forcePLine2Basis (PLine2 a) = PLine2 $ forceProjectiveLine2Basis a - translatePLine2WithErr (PLine2 a) d = (\(b,(PLine2Err _ _ _ t _)) -> (PLine2 b,t)) $ translateProjectiveLine2WithErr a d + translatePLine2WithErr (PLine2 a) d = (\(b,(PLine2Err _ _ _ _ t _)) -> (PLine2 b,t)) $ translateProjectiveLine2WithErr a d vecOfL (PLine2 a) = a -- | the two types of error of a projective line. @@ -683,18 +683,27 @@ data PLine2Err = PLine2Err UlpSum -- Translation Error. always in GEZero 1. UlpSum - -- JoinErr + -- Join Error. when a PLine2 is constructed via join. ([ErrVal], [ErrVal]) deriving (Eq, Show) +instance Semigroup PLine2Err where + (<>) (PLine2Err a1 b1 c1 d1 e1 (f1,g1)) (PLine2Err a2 b2 c2 d2 e2 (f2,g2)) = + PLine2Err (foldl' addErr a1 a2) + (foldl' addErr b1 b2) + (c1 <> c2) + (d1 <> d2) + (e1 <> e2) + (foldl' addErr f1 f2,foldl' addErr g1 g2) + -- | The join operator in 2D PGA, which is implemented as the meet operator operating in the dual space. (∨+) :: GVec -> GVec -> (GVec, UlpSum) (∨+) a b = (vec , ulpSum) where vec = dual2DGVec $ res - ulpSum = sumErrVals mulErr <> sumErrVals addErr - (res, (addErr, mulErr)) = dual2DGVec a ⎤+ dual2DGVec b + ulpSum = sumErrVals unlikeMulErr <> sumErrVals unlikeAddErr + (res, (unlikeAddErr, unlikeMulErr)) = dual2DGVec a ⎤+ dual2DGVec b infixl 9 ∨+ -- | a typed join function. join two points, returning a line. @@ -702,10 +711,10 @@ join2PPoint2WithErr :: PPoint2 -> PPoint2 -> (PLine2, UlpSum) join2PPoint2WithErr pp1 pp2 = (res, errTotal) where - (res,UlpSum resErr) = join2CPPoint2WithErr cp1 cp2 - (cp1, UlpSum pv1Err) = canonicalizePPoint2WithErr pp1 - (cp2, UlpSum pv2Err) = canonicalizePPoint2WithErr pp2 - errTotal = UlpSum $ resErr + pv1Err + pv2Err + (res, resErr) = join2CPPoint2WithErr cp1 cp2 + (cp1, pv1Err) = canonicalizePPoint2WithErr pp1 + (cp2, pv2Err) = canonicalizePPoint2WithErr pp2 + errTotal = resErr <> pv1Err <> pv2Err -- | a typed join function. join two points, returning a line. join2CPPoint2WithErr :: CPPoint2 -> CPPoint2 -> (PLine2, UlpSum) @@ -721,8 +730,8 @@ meet2PLine2WithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PPoin meet2PLine2WithErr line1 line2 = (PPoint2 res, ulpSum) where - ulpSum = sumErrVals mulErr <> sumErrVals addErr - (res, (addErr, mulErr)) = pv1 ⎤+ pv2 + ulpSum = sumErrVals unlikeMulErr <> sumErrVals unlikeAddErr + (res, (unlikeMulErr, unlikeAddErr)) = pv1 ⎤+ pv2 (PLine2 pv1) = forcePLine2Basis $ PLine2 plr1 (PLine2 pv2) = forcePLine2Basis $ PLine2 plr2 (NPLine2 plr1,_) = normalize line1 @@ -956,30 +965,28 @@ canonicalizeIntersectionWithErr pl1 pl2 foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(PPoint2 (GVec vals)) -> vals) pp1 -- | Normalize a PLine2. -normalizePLine2WithErr :: (ProjectiveLine2 a) => a -> (NPLine2, UlpSum) +normalizePLine2WithErr :: (ProjectiveLine2 a) => a -> (NPLine2, PLine2Err) normalizePLine2WithErr line = (res, resErr) where (res, resErr) = case norm of - 1.0 -> (NPLine2 vec, normErr) - _ -> (NPLine2 $ scaledVec, ulpTotal) - (scaledVec, _) = divVecScalarWithErr vec norm + 1.0 -> (NPLine2 vec , normErr) + _ -> (NPLine2 scaledVec, normErr <> PLine2Err mempty scaledVecErrs mempty mempty mempty mempty) + (scaledVec, scaledVecErrs) = divVecScalarWithErr vec norm (norm, normErr) = normOfPLine2WithErr line - ulpTotal = normErr <> ulpOfPLine2 res vec = vecOfL line --- | find the norm of a given ProjectiveLine. -normOfPLine2WithErr :: (ProjectiveLine2 a) => a -> (ℝ, UlpSum) +-- | find the norm of a given Projective Line. +normOfPLine2WithErr :: (ProjectiveLine2 a) => a -> (ℝ, PLine2Err) normOfPLine2WithErr pline = (res, resErr) where (res, resErr) = case sqNormOfPLine2 of - 1.0 -> (1.0, sqNormErr) - _ -> (sqrt sqNormOfPLine2, ulpTotal) - (sqNormOfPLine2, sqNormErr) = sqNormOfPLine2WithErr pline + 1.0 -> (1.0 , PLine2Err mempty mempty mempty sqNormUlp mempty mempty) + _ -> (sqrt sqNormOfPLine2, PLine2Err mempty mempty rawResUlp sqNormUlp mempty mempty) + (sqNormOfPLine2, sqNormUlp) = sqNormOfPLine2WithErr pline rawRes = sqrt sqNormOfPLine2 - -- FIXME: these are two types of error. track them separately in PLine2Err? - ulpTotal = UlpSum (abs $ realToFrac $ doubleUlp rawRes) <> sqNormErr + rawResUlp = UlpSum (abs $ realToFrac $ doubleUlp rawRes) --- | find the squared norm of a given ProjectiveLine +-- | find the squared norm of a given Projective Line. sqNormOfPLine2WithErr :: (ProjectiveLine2 a) => a -> (ℝ, UlpSum) sqNormOfPLine2WithErr line = (res, ulpTotal) where diff --git a/tests/golden/C7-Cell1-NodeTree.ganja.js b/tests/golden/C7-Cell1-NodeTree.ganja.js deleted file mode 100644 index 5c4802445..000000000 --- a/tests/golden/C7-Cell1-NodeTree.ganja.js +++ /dev/null @@ -1,53 +0,0 @@ -Algebra(2,0,1,()=>{ - var line = (a,b,c)=>a*1e1 + b*1e2 + c*1e0; - var point = (x,y)=>!(1e0 + x*1e1 + y*1e2); - var aaa = point(0.0,-1.0); - var aab = point(1.0,-1.0); - var aba = point(1.0,-1.0); - var abb = point(1.0,1.0); - var aca = point(1.0,1.0); - var acb = point(0.5,1.0); - var ada = point(0.5,1.0); - var adb = point(0.5,0.0); - var aea = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var aeb = -0.7071067811865475e1-0.7071067811865475e2+1.0606601717798212e0; - var aec = -1.0e1+0.0e2+0.75e0; - var afa = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var afb = -1.0e1+0.0e2+0.75e0; - var afc = -0.3826834323650899e1+0.9238795325112867e2+0.9799222236572825e0; - document.body.appendChild(this.graph([ - 0x882288, - [aaa,aab], - 0x00AA88, - aaa, "aaa", - aab, "aab", - 0x882288, - [aba,abb], - 0x00AA88, - aba, "aba", - abb, "abb", - 0x882288, - [aca,acb], - 0x00AA88, - aca, "aca", - acb, "acb", - 0x882288, - [ada,adb], - 0x00AA88, - ada, "ada", - adb, "adb", - aea, "aea", - aeb, "aeb", - aec, "aec", - afa, "afa", - afb, "afb", - afc, "afc", - ],{ - grid: true, - labels: true, - lineWidth: 3, - pointRadius: 1, - fontSize: 1, - scale: 1, -})); -}); diff --git a/tests/golden/square-Faces-Default.ganja.js b/tests/golden/square-Faces-Default.ganja.js index c420da455..66bd957c3 100644 --- a/tests/golden/square-Faces-Default.ganja.js +++ b/tests/golden/square-Faces-Default.ganja.js @@ -1,22 +1,26 @@ Algebra(2,0,1,()=>{ var line = (a,b,c)=>a*1e1 + b*1e2 + c*1e0; var point = (x,y)=>!(1e0 + x*1e1 + y*1e2); - var aaa = point(1.0,-1.0); - var aab = point(1.0,1.0); - var aba = point(1.0,1.0); - var abb = point(-1.0,1.0); - var aca = point(-1.0,1.0); - var acb = point(-1.0,-1.0); - var ada = point(-1.0,-1.0); - var adb = point(1.0,-1.0); - var ae = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var af = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var ag = -0.7071067811865475e1-0.7071067811865475e2+0.0e0; - var ah = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var ai = 0.7071067811865475e1-0.7071067811865475e2+0.0e0; - var aj = -0.7071067811865475e1-0.7071067811865475e2+0.0e0; - var ak = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var al = 0.7071067811865475e1-0.7071067811865475e2+0.0e0; + var aaa = point(-1.0,1.0); + var aab = point(-1.0,-1.0); + var aba = point(-1.0,-1.0); + var abb = point(1.0,-1.0); + var aca = point(1.0,-1.0); + var acb = point(1.0,1.0); + var ada = point(1.0,1.0); + var adb = point(-1.0,1.0); + var ae = 0.7071067811865475e1-0.7071067811865475e2+0.0e0; + var af = 1.0e1+0.0e2+0.0e0; + var ag = -1.0e1+0.0e2+0.0e0; + var ah = -0.7071067811865475e1-0.7071067811865475e2+0.0e0; + var ai = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; + var aj = 0.7071067811865475e1-0.7071067811865475e2+0.0e0; + var ak = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; + var al = -1.0e1+0.0e2+0.0e0; + var am = 1.0e1+0.0e2+0.0e0; + var an = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; + var ao = -0.7071067811865475e1-0.7071067811865475e2+0.0e0; + var ap = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], @@ -46,6 +50,10 @@ Algebra(2,0,1,()=>{ aj, "aj", ak, "ak", al, "al", + am, "am", + an, "an", + ao, "ao", + ap, "ap", ],{ grid: true, labels: true, diff --git a/tests/golden/square-Straight_Skeleton.ganja.js b/tests/golden/square-Straight_Skeleton.ganja.js index 2d188922b..dc3fbc87f 100644 --- a/tests/golden/square-Straight_Skeleton.ganja.js +++ b/tests/golden/square-Straight_Skeleton.ganja.js @@ -9,10 +9,14 @@ Algebra(2,0,1,()=>{ var acb = point(-1.0,1.0); var ada = point(-1.0,1.0); var adb = point(-1.0,-1.0); - var aea = 0.7071067811865475e1-0.7071067811865475e2+0.0e0; - var aeb = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var aec = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var aed = -0.7071067811865475e1-0.7071067811865475e2+0.0e0; + var aea = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; + var aeb = -0.7071067811865475e1-0.7071067811865475e2+0.0e0; + var aec = -1.0e1+0.0e2+0.0e0; + var afa = 0.7071067811865475e1-0.7071067811865475e2+0.0e0; + var afb = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; + var afc = 1.0e1+0.0e2+0.0e0; + var aga = 1.0e1+0.0e2+0.0e0; + var agb = -1.0e1+0.0e2+0.0e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], @@ -37,7 +41,11 @@ Algebra(2,0,1,()=>{ aea, "aea", aeb, "aeb", aec, "aec", - aed, "aed", + afa, "afa", + afb, "afb", + afc, "afc", + aga, "aga", + agb, "agb", ],{ grid: true, labels: true, From 346873f88a3ed3148ce92b2f160b93dade313b2d Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Fri, 14 Oct 2022 16:00:16 +0000 Subject: [PATCH 005/206] use canonicalize instead of canonicalizePPoint2WithErr directly. --- Graphics/Slicer/Math/Lossy.hs | 4 ++-- Graphics/Slicer/Math/PGA.hs | 16 ++++++++-------- tests/Math/PGA.hs | 12 ++++++------ 3 files changed, 16 insertions(+), 16 deletions(-) diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index 68da11511..773d2c894 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -49,14 +49,14 @@ import Graphics.Slicer.Definitions (ℝ) import Graphics.Slicer.Math.Definitions (LineSeg, Point2) -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2, PLine2, PPoint2(PPoint2), ProjectiveLine2, ProjectivePoint2, angleBetweenWithErr, canonicalizePPoint2WithErr, distanceBetweenPPointsWithErr, distanceBetweenNPLine2sWithErr, distanceCPPointToNPLineWithErr, distancePPointToPLineWithErr, eToCPPoint2WithErr, eToPLine2WithErr, eToPPoint2WithErr, getFirstArcWithErr, getInsideArcWithErr, join2CPPoint2WithErr, join2PPoint2WithErr, makeCPPoint2WithErr, normalize, pLineFromEndpointsWithErr, pPointBetweenPPointsWithErr, pPointOnPerpWithErr, translatePLine2WithErr) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2, PLine2, PPoint2(PPoint2), ProjectiveLine2, ProjectivePoint2, angleBetweenWithErr, canonicalize, distanceBetweenPPointsWithErr, distanceBetweenNPLine2sWithErr, distanceCPPointToNPLineWithErr, distancePPointToPLineWithErr, eToCPPoint2WithErr, eToPLine2WithErr, eToPPoint2WithErr, getFirstArcWithErr, getInsideArcWithErr, join2CPPoint2WithErr, join2PPoint2WithErr, makeCPPoint2WithErr, normalize, pLineFromEndpointsWithErr, pPointBetweenPPointsWithErr, pPointOnPerpWithErr, translatePLine2WithErr) angleBetween :: NPLine2 -> NPLine2 -> ℝ angleBetween nPLine1 nPLine2 = fst $ angleBetweenWithErr nPLine1 nPLine2 -- | canonicalize a euclidian point. canonicalizePPoint2 :: PPoint2 -> CPPoint2 -canonicalizePPoint2 point = fst $ canonicalizePPoint2WithErr point +canonicalizePPoint2 point = fst $ canonicalize point distanceBetweenPPoints :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> ℝ distanceBetweenPPoints point1 point2 = fst $ distanceBetweenPPointsWithErr point1 point2 diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 74fc331f2..2115eaf9d 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -37,7 +37,7 @@ module Graphics.Slicer.Math.PGA( ProjectivePoint2, angleBetweenWithErr, combineConsecutiveLineSegs, - canonicalizePPoint2WithErr, + canonicalize, cPToEPoint2, distanceBetweenPPointsWithErr, distanceBetweenNPLine2sWithErr, @@ -399,7 +399,7 @@ outputIntersectsLineSeg source (l1, UlpSum l1Err) <> show source <> "\n" (rawIntersection, UlpSum rawIntersectionErr) = fromJust canonicalizedIntersection canonicalizedIntersection = canonicalizeIntersectionWithErr pl1 pl2 - (canonicalizedSource, UlpSum canonicalizedSourceErr) = canonicalizePPoint2WithErr $ pPointOf source + (canonicalizedSource, UlpSum canonicalizedSourceErr) = canonicalize $ pPointOf source (intersectionDistance, UlpSum intersectionDistanceErr) = distanceBetweenPPointsWithErr canonicalizedSource rawIntersection -- | A type alias, for cases where either input is acceptable. @@ -458,7 +458,7 @@ pLineIntersectsLineSeg (pl1, UlpSum pl1Err) (l1, UlpSum l1Err) ulpScale hasRawIntersection = valOf 0 foundVal /= 0 foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(PPoint2 (GVec vals)) -> vals) rawIntersect -- FIXME: remove the canonicalization from this function, moving it to the callers. - (rawIntersection, UlpSum rawIntersectionErr) = canonicalizePPoint2WithErr rawIntersect + (rawIntersection, UlpSum rawIntersectionErr) = canonicalize rawIntersect (rawIntersect, UlpSum rawIntersectErr) = pLineIntersectionWithErr pl1 pl2 (pl2, UlpSum pl2Err) = eToPLine2WithErr l1 @@ -508,7 +508,7 @@ lineSegIntersectsLineSeg (l1, UlpSum l1Err) (l2, UlpSum ulpL2) hasRawIntersection = valOf 0 foundVal /= 0 foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(PPoint2 (GVec vals)) -> vals) rawIntersect -- FIXME: remove the canonicalization from this function, moving it to the callers. - (rawIntersection, UlpSum rawIntersectionErr) = canonicalizePPoint2WithErr rawIntersect + (rawIntersection, UlpSum rawIntersectionErr) = canonicalize rawIntersect (rawIntersect, UlpSum rawIntersectErr) = pLineIntersectionWithErr pl1 pl2 -- | Given the result of intersectionPoint, find out whether this intersection point is on the given segment, or not. @@ -712,8 +712,8 @@ join2PPoint2WithErr pp1 pp2 = (res, errTotal) where (res, resErr) = join2CPPoint2WithErr cp1 cp2 - (cp1, pv1Err) = canonicalizePPoint2WithErr pp1 - (cp2, pv2Err) = canonicalizePPoint2WithErr pp2 + (cp1, pv1Err) = canonicalize pp1 + (cp2, pv2Err) = canonicalize pp2 errTotal = resErr <> pv1Err <> pv2Err -- | a typed join function. join two points, returning a line. @@ -783,7 +783,7 @@ pPointToPoint2 point@(PPoint2 (GVec rawVals)) | e12Val == 1 = Just $ Point2 (xVal, yVal) | otherwise = Just $ Point2 (xVal, yVal) where - (CPPoint2 (GVec vals)) = fst $ canonicalizePPoint2WithErr point + (CPPoint2 (GVec vals)) = fst $ canonicalize point xVal = negate $ valOf 0 $ getVal [GEZero 1, GEPlus 2] vals yVal = valOf 0 $ getVal [GEZero 1, GEPlus 1] vals e12Val = valOf 0 (getVal [GEPlus 1, GEPlus 2] rawVals) @@ -959,7 +959,7 @@ canonicalizeIntersectionWithErr pl1 pl2 | isNothing foundVal = Nothing | otherwise = Just (cpp1, ulpTotal) where - (cpp1, UlpSum canonicalizationErr) = canonicalizePPoint2WithErr pp1 + (cpp1, UlpSum canonicalizationErr) = canonicalize pp1 (pp1, UlpSum intersectionErr) = pLineIntersectionWithErr pl1 pl2 ulpTotal = UlpSum $ intersectionErr + canonicalizationErr foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(PPoint2 (GVec vals)) -> vals) pp1 diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index 7d6c60d2f..476cb85e6 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -59,7 +59,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(GEZero, GEPlu import Graphics.Slicer.Math.Lossy (angleBetween, canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenNPLine2s, distancePPointToPLine, eToCPPoint2, eToPLine2, eToPPoint2, getFirstArc, join2PPoint2, makeCPPoint2, makePPoint2, normalizePLine2, pPointOnPerp) -- Our 2D Projective Geometric Algebra library. -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PPoint2PosErr(PPoint2PosErr), canonicalizePPoint2WithErr, pPointBetweenPPointsWithErr, distanceBetweenPPointsWithErr, distanceCPPointToNPLineWithErr, join2CPPoint2WithErr, pLineIntersectionWithErr, translatePLine2WithErr, translateRotatePPoint2, angleBetweenWithErr, flipPLine2, makeCPPoint2WithErr, normalize, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, pLineFromEndpointsWithErr, distancePPointToPLineWithErr, pPointOnPerpWithErr, outOf, pPointOf, ulpOfOut, outputIntersectsLineSeg, pPointBetweenPPointsWithErr) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PPoint2PosErr(PPoint2PosErr), canonicalize, pPointBetweenPPointsWithErr, distanceBetweenPPointsWithErr, distanceCPPointToNPLineWithErr, join2CPPoint2WithErr, pLineIntersectionWithErr, translatePLine2WithErr, translateRotatePPoint2, angleBetweenWithErr, flipPLine2, makeCPPoint2WithErr, normalize, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, pLineFromEndpointsWithErr, distancePPointToPLineWithErr, pPointOnPerpWithErr, outOf, pPointOf, ulpOfOut, outputIntersectsLineSeg, pPointBetweenPPointsWithErr) -- Our Contour library. import Graphics.Slicer.Math.Contour (contourContainsContour, getContours, pointsOfContour, numPointsOfContour, justOneContourFrom, lineSegsOfContour, makeLineSegContour, makePointContour, insideIsLeft, innerContourPoint, firstPointPairOfContour, firstLineSegOfContour) @@ -402,7 +402,7 @@ prop_perpAt90Degrees x y rawX2 y2 rawD (angle2, UlpSum angle2Err) = angleBetweenWithErr normedPLine3 normedPLine4 (PPoint2 rawBisectorStart, UlpSum bisectorStartErr) = pPointBetweenPPointsWithErr sourceStart sourceEnd 0.5 0.5 (bisectorEndRaw, UlpSum bisectorEndRawErr) = pPointOnPerpWithErr pline4 (PPoint2 rawBisectorStart) d - (bisectorEnd, UlpSum bisectorEndErr) = canonicalizePPoint2WithErr bisectorEndRaw + (bisectorEnd, UlpSum bisectorEndErr) = canonicalize bisectorEndRaw (pline3, UlpSum pline3Err) = join2CPPoint2WithErr (CPPoint2 rawBisectorStart) bisectorEnd (normedPLine3, UlpSum norm3Err) = normalize pline3 (sourceStart, PPoint2PosErr sourceStartErr) = makeCPPoint2WithErr x y @@ -1340,7 +1340,7 @@ prop_eNodeTowardIntersection1 :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> Pos prop_eNodeTowardIntersection1 x y d1 rawR1 d2 rawR2 = l1TowardIntersection --> True where l1TowardIntersection = towardIntersection (eToPPoint2 $ startPoint l1) pl1 eNodePoint - (eNodePoint, _) = canonicalizePPoint2WithErr $ pPointOf eNode + (eNodePoint, _) = canonicalize $ pPointOf eNode l1 = getFirstLineSeg eNode pl1 = eToPLine2 l1 eNode = randomENode x y d1 rawR1 d2 rawR2 @@ -1349,7 +1349,7 @@ prop_eNodeAwayFromIntersection2 :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> P prop_eNodeAwayFromIntersection2 x y d1 rawR1 d2 rawR2 = l2TowardIntersection --> False where l2TowardIntersection = towardIntersection (eToPPoint2 $ endPoint l2) pl2 eNodePoint - (eNodePoint, _) = canonicalizePPoint2WithErr $ pPointOf eNode + (eNodePoint, _) = canonicalize $ pPointOf eNode l2 = getLastLineSeg eNode pl2 = eToPLine2 l2 eNode = randomENode x y d1 rawR1 d2 rawR2 @@ -1376,7 +1376,7 @@ prop_PLinesIntersectAtOrigin rawX y rawX2 rawY2 where (originPPoint2, PPoint2PosErr originErr) = makeCPPoint2WithErr 0 0 (foundDistance, UlpSum distanceErr) = distanceBetweenPPointsWithErr originPPoint2 intersectionCPPoint2 - (intersectionCPPoint2, UlpSum canonicalizationErr) = canonicalizePPoint2WithErr intersectionPPoint2 + (intersectionCPPoint2, UlpSum canonicalizationErr) = canonicalize intersectionPPoint2 (intersectionPPoint2, UlpSum intersectionErr) = pLineIntersectionWithErr randomPLine1 randomPLine2 (randomPLine1, UlpSum pline1Err) = randomPLineThroughOrigin x y (randomPLine2, UlpSum pline2Err) = randomPLineThroughOrigin x2 y2 @@ -1404,7 +1404,7 @@ prop_PLinesIntersectAtPoint rawX y rawX2 rawY2 targetX targetY where (targetPPoint2, PPoint2PosErr targetErr) = makeCPPoint2WithErr (coerce targetX) (coerce targetY) (foundDistance, UlpSum distanceErr) = distanceBetweenPPointsWithErr targetPPoint2 intersectionCPPoint2 - (intersectionCPPoint2, UlpSum canonicalizationErr) = canonicalizePPoint2WithErr intersectionPPoint2 + (intersectionCPPoint2, UlpSum canonicalizationErr) = canonicalize intersectionPPoint2 (intersectionPPoint2, UlpSum intersectionErr) = pLineIntersectionWithErr randomPLine1 randomPLine2 (randomPLine1, UlpSum pline1Err) = randomPLineWithErr x y targetX targetY (randomPLine2, UlpSum pline2Err) = randomPLineWithErr x2 y2 targetX targetY From f28e6e31fcd7562f398d3836662f75b557c5d37a Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Fri, 14 Oct 2022 17:12:57 +0000 Subject: [PATCH 006/206] introduce PPoint2Err, and use it for canonicalization. --- Graphics/Slicer/Math/PGA.hs | 68 +++++++++++++++++++++++++++---------- Graphics/Slicer/Orphans.hs | 10 ++++-- 2 files changed, 58 insertions(+), 20 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 2115eaf9d..8f8659fb6 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -70,7 +70,7 @@ module Graphics.Slicer.Math.PGA( ulpOfPLine2 ) where -import Prelude (Bool, Eq((==),(/=)), Semigroup((<>)), Show(show), Ord, ($), (*), (-), (>=), (&&), (<$>), mempty, otherwise, signum, (>), (<=), (+), sqrt, negate, (/), (||), (<), abs, error, sin, cos, realToFrac, fst, sum, (.)) +import Prelude (Bool, Eq((==),(/=)), Monoid(mempty), Semigroup((<>)), Show(show), Ord, ($), (*), (-), (>=), (&&), (<$>), otherwise, signum, (>), (<=), (+), sqrt, negate, (/), (||), (<), abs, error, sin, cos, realToFrac, fst, sum, (.)) import GHC.Generics (Generic) @@ -96,7 +96,7 @@ import Graphics.Slicer.Definitions (ℝ) import Graphics.Slicer.Math.Definitions (Point2(Point2), LineSeg(LineSeg), addPoints, scalePoint, startPoint, endPoint, distance) -import Graphics.Slicer.Math.GeometricAlgebra (ErrVal, GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎣+), (⎤+), (⨅), (⨅+), (∧), (•), addErr, addValWithoutErr, addVecPairWithErr, addVecPairWithoutErr, divVecScalarWithErr, getVal, mulScalarVecWithErr, scalarPart, sumErrVals, ulpVal, valOf, vectorPart) +import Graphics.Slicer.Math.GeometricAlgebra (ErrVal, GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎣+), (⎤+), (⨅), (⨅+), (∧), (•), addErr, addValWithoutErr, addVecPairWithErr, addVecPairWithoutErr, divVecScalarWithErr, eValOf, getVal, mulScalarVecWithErr, scalarPart, sumErrVals, ulpVal, valOf, vectorPart) import Graphics.Slicer.Math.Line (combineLineSegs) @@ -616,6 +616,39 @@ newtype PPoint2 = PPoint2 GVec newtype CPPoint2 = CPPoint2 GVec deriving (Eq, Generic, NFData, Show) +-- | the error accumulated when calculating a projective point. +data PPoint2Err = + PPoint2Err + -- MeetErr. max error amounts while meeting two PLines to find this point. divided into add err, and multiply err. + ([ErrVal], [ErrVal]) + -- CanonicalizeErr. error caused by the divide used during canonicalization of a point. + [ErrVal] + -- AddErr. error created when adding two points to create a third point. + [ErrVal] + -- WeighedStartErr. error created when scaling one of the two input points used to create this point. + [ErrVal] + -- WeighedStopErr. error created when scaling one of the two input points used to create this point. + [ErrVal] + -- angle between the two input lines, when we generate this point via intersecting two lines. + ℝ + -- angleUnlikeErr - the error of the unlike operation that generates the angle in the previous field. + ([ErrVal], [ErrVal]) + deriving (Eq, Show) + +instance Semigroup PPoint2Err where + (<>) (PPoint2Err (a1,b1) c1 d1 e1 f1 g1 (h1,i1)) (PPoint2Err (a2,b2) c2 d2 e2 f2 g2 (h2,i2)) = + PPoint2Err + (foldl' addErr a1 a2, foldl' addErr b1 b2) + (foldl' addErr c1 c2) + (foldl' addErr d1 d2) + (foldl' addErr e1 e2) + (foldl' addErr f1 f2) + (g1 <> g2) + (foldl' addErr h1 h2, foldl' addErr i1 i2) + +instance Monoid PPoint2Err where + mempty = PPoint2Err mempty mempty mempty mempty mempty mempty mempty + -- | Can this node be resolved into a point in 2d space? class Pointable a where canPoint :: a -> Bool @@ -635,7 +668,7 @@ class ProjectivePoint2 a where vecOfP :: a -> GVec instance ProjectivePoint2 PPoint2 where - canonicalize p = canonicalizePPoint2WithErr p + canonicalize p = (\(a, PPoint2Err _ c8izeErrs _ _ _ _ _) -> (a,sumPPointErrs c8izeErrs)) $ canonicalizePPoint2WithErr p vecOfP (PPoint2 a) = a instance ProjectivePoint2 CPPoint2 where @@ -896,13 +929,6 @@ ulpOfPLine2 line = UlpSum $ sum $ abs . realToFrac . doubleUlp . (\(GVal r _) -> ulpOfLineSeg :: LineSeg -> UlpSum ulpOfLineSeg (LineSeg (Point2 (x1,y1)) (Point2 (x2,y2))) = UlpSum $ sum $ abs . realToFrac . doubleUlp <$> [x1, y1, x2, y2] --- | Get the sum of the error involved in storing the values in a given PPoint2. -ulpOfCPPoint2 :: CPPoint2 -> UlpSum -ulpOfCPPoint2 (CPPoint2 (GVec vals)) = UlpSum $ sum $ abs . realToFrac . doubleUlp . (\(GVal r _) -> r) <$> catMaybes - [getVal [GEZero 1, GEPlus 1] vals - ,getVal [GEZero 1, GEPlus 2] vals - ,getVal [GEPlus 1, GEPlus 2] vals] - --------------------------------------------------------------------- ---- Utillity functions that use sqrt(), or divVecScalarWithErr. ---- --------------------------------------------------------------------- @@ -929,12 +955,12 @@ idealNormPPoint2WithErr ppoint@(PPoint2 (GVec rawVals)) -- | canonicalize a euclidian point. -- Note: Normalization of euclidian points in PGA is really just canonicalization. -- Note: For precision, we go through some work to not bother dividing the GP1,GP2 component with itsself, and just substitute in the answer, as exactly 1. -canonicalizePPoint2WithErr :: PPoint2 -> (CPPoint2, UlpSum) -canonicalizePPoint2WithErr point@(PPoint2 (GVec rawVals)) +canonicalizePPoint2WithErr :: (ProjectivePoint2 a, Show a) => a -> (CPPoint2, PPoint2Err) +canonicalizePPoint2WithErr point | isNothing foundVal = error $ "tried to canonicalize an ideal point: " <> show point <> "\n" -- Handle the ID case. - | valOf 1 foundVal == 1 = ((\(PPoint2 v) -> CPPoint2 v) point, ulpSum) - | otherwise = (res, ulpSum) + | valOf 1 foundVal == 1 = (CPPoint2 $ GVec rawVals, mempty) + | otherwise = (res, PPoint2Err mempty scaledErrs mempty mempty mempty mempty mempty) where res = CPPoint2 $ GVec $ foldl' addValWithoutErr [] $ ( if isNothing (getVal [GEZero 1, GEPlus 1] scaledVals) @@ -946,11 +972,11 @@ canonicalizePPoint2WithErr point@(PPoint2 (GVec rawVals)) else [GVal (valOf 0 $ getVal [GEZero 1, GEPlus 2] scaledVals) (fromList [GEZero 1, GEPlus 2])] ) <> [GVal 1 (fromList [GEPlus 1, GEPlus 2])] - newVec = GVec $ addValWithoutErr [GVal (valOf 0 $ getVal [GEZero 1, GEPlus 1] rawVals) (fromList [GEZero 1, GEPlus 1])] - (GVal (valOf 0 $ getVal [GEZero 1, GEPlus 2] rawVals) (fromList [GEZero 1, GEPlus 2])) - (GVec scaledVals, _) = divVecScalarWithErr newVec $ valOf 1 foundVal + newVec = GVec [GVal (valOf 0 $ getVal [GEZero 1, GEPlus 1] rawVals) (fromList [GEZero 1, GEPlus 1]) + ,GVal (valOf 0 $ getVal [GEZero 1, GEPlus 2] rawVals) (fromList [GEZero 1, GEPlus 2])] + (GVec scaledVals, scaledErrs) = divVecScalarWithErr newVec $ valOf 1 foundVal + (GVec rawVals) = vecOfP point foundVal = getVal [GEPlus 1, GEPlus 2] rawVals - ulpSum = ulpOfCPPoint2 res -- | Canonicalize the intersection resulting from two PLines. -- NOTE: Returns nothing when the PLines are (anti)parallel. @@ -998,3 +1024,9 @@ sqNormOfPLine2WithErr line = (res, ulpTotal) + abs (realToFrac $ doubleUlp $ b*b) + abs (realToFrac $ doubleUlp res) (GVec vals) = vecOfL line + +-- | Get the sum of a set of error values, when dealing with error applied to a Projective Point. +sumPPointErrs :: [ErrVal] -> UlpSum +sumPPointErrs errs = eValOf mempty (getVal [GEZero 1, GEPlus 1] errs) + <> eValOf mempty (getVal [GEZero 1, GEPlus 2] errs) + <> eValOf mempty (getVal [GEPlus 1, GEPlus 2] errs) diff --git a/Graphics/Slicer/Orphans.hs b/Graphics/Slicer/Orphans.hs index c2904ab53..bf13170c9 100644 --- a/Graphics/Slicer/Orphans.hs +++ b/Graphics/Slicer/Orphans.hs @@ -25,10 +25,10 @@ module Graphics.Slicer.Orphans () where import Control.DeepSeq (NFData (rnf)) -import Graphics.Slicer.Definitions (Fastℕ) +import Graphics.Slicer.Definitions (Fastℕ,ℝ) import Slist.Size (Size (Infinity, Size)) import Slist.Type (Slist (Slist)) -import Prelude (seq) +import Prelude (Monoid(mempty), Semigroup((<>)), seq, (+)) instance NFData a => NFData (Slist a) where rnf (Slist vals n) = rnf vals `seq` rnf n @@ -40,3 +40,9 @@ instance NFData Size where -- | FIXME: move this to the proper place in ImplicitCAD. instance NFData Fastℕ where rnf a = seq a () + +instance Semigroup ℝ where + (<>) a b = a + b + +instance Monoid ℝ where + mempty = 0 From 5d48b744aedbeec925a39c15d37bcb6c65d52ce6 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Fri, 14 Oct 2022 19:48:41 +0000 Subject: [PATCH 007/206] move idealNormOfPPoint2 to idealNormOfP in the typeclass. --- Graphics/Slicer/Math/PGA.hs | 38 +++++++++++++++++++++---------------- 1 file changed, 22 insertions(+), 16 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 8f8659fb6..383a98621 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -84,7 +84,7 @@ import Data.List (foldl') import Data.List.Ordered (sort, foldt) -import Data.Maybe (Maybe(Just, Nothing), maybeToList, catMaybes, fromJust, isNothing, maybeToList) +import Data.Maybe (Maybe(Just, Nothing), catMaybes, fromJust, fromMaybe, isNothing, maybeToList) import Data.Set (Set, singleton, fromList, elems) @@ -665,14 +665,19 @@ class Arcable a where class ProjectivePoint2 a where canonicalize :: a -> (CPPoint2, UlpSum) + pPtoEP :: a -> (Point2, UlpSum) + idealNormOfP :: a -> (ℝ, UlpSum) vecOfP :: a -> GVec instance ProjectivePoint2 PPoint2 where canonicalize p = (\(a, PPoint2Err _ c8izeErrs _ _ _ _ _) -> (a,sumPPointErrs c8izeErrs)) $ canonicalizePPoint2WithErr p + idealNormOfP a = idealNormPPoint2WithErr a + pPtoEP a = fromMaybe (error "created an infinite point when trying to convert from a Projective point to a euclidian one.") $ pPointToPoint2 a vecOfP (PPoint2 a) = a instance ProjectivePoint2 CPPoint2 where canonicalize p = (p, mempty) + idealNormOfP a = idealNormPPoint2WithErr a vecOfP (CPPoint2 a) = a -- | A projective line in 2D space. @@ -795,31 +800,31 @@ makeCPPoint2WithErr x y = (pPoint pToEPoint2 :: PPoint2 -> Point2 pToEPoint2 ppoint | isNothing res = error "created an infinite point when trying to convert from a PPoint2 to a Point2" - | otherwise = fromJust res + | otherwise = fst $ fromJust res where res = pPointToPoint2 ppoint -- | Create a euclidian point from a projective point. cPToEPoint2 :: CPPoint2 -> Point2 cPToEPoint2 (CPPoint2 rawPoint) - | isNothing res = error "created an infinite point when trying to convert from a PPoint2 to a Point2" - | otherwise = fromJust res + | isNothing res = error "created an infinite point when trying to convert from a Projective point to a euclidian one." + | otherwise = fst $ fromJust res where res = pPointToPoint2 $ PPoint2 rawPoint -- | Maybe create a euclidian point from a projective point. --- FIXME: does negate cause a precision loss? -- FIXME: canonicalization certainly does... -pPointToPoint2 :: PPoint2 -> Maybe Point2 -pPointToPoint2 point@(PPoint2 (GVec rawVals)) +pPointToPoint2 :: (ProjectivePoint2 a) => a -> Maybe (Point2, UlpSum) +pPointToPoint2 ppoint | e12Val == 0 = Nothing - | e12Val == 1 = Just $ Point2 (xVal, yVal) - | otherwise = Just $ Point2 (xVal, yVal) + | e12Val == 1 = Just (Point2 (xVal, yVal), cpErr) + | otherwise = Just (Point2 (xVal, yVal), cpErr) where - (CPPoint2 (GVec vals)) = fst $ canonicalize point + (CPPoint2 (GVec vals), cpErr) = canonicalize ppoint xVal = negate $ valOf 0 $ getVal [GEZero 1, GEPlus 2] vals yVal = valOf 0 $ getVal [GEZero 1, GEPlus 1] vals e12Val = valOf 0 (getVal [GEPlus 1, GEPlus 2] rawVals) + (GVec rawVals) = vecOfP ppoint -- | Reverse a vector. Really, take every value in it, and recompute it in the reverse order of the vectors (so instead of e0∧e1, e1∧e0). which has the effect of negating bi and tri-vectors. reverseGVec :: GVec -> GVec @@ -934,8 +939,8 @@ ulpOfLineSeg (LineSeg (Point2 (x1,y1)) (Point2 (x2,y2))) = UlpSum $ sum $ abs . --------------------------------------------------------------------- -- | find the idealized norm of a projective point (ideal or not). -idealNormPPoint2WithErr :: PPoint2 -> (ℝ, UlpSum) -idealNormPPoint2WithErr ppoint@(PPoint2 (GVec rawVals)) +idealNormPPoint2WithErr :: (ProjectivePoint2 a) => a -> (ℝ, UlpSum) +idealNormPPoint2WithErr ppoint | preRes == 0 = (0, mempty) | otherwise = (res, ulpTotal) where @@ -949,8 +954,9 @@ idealNormPPoint2WithErr ppoint@(PPoint2 (GVec rawVals)) (x,y) | e12Val == 0 = ( negate $ valOf 0 $ getVal [GEZero 1, GEPlus 2] rawVals , valOf 0 $ getVal [GEZero 1, GEPlus 1] rawVals) - | otherwise = (\(Point2 (x1,y1)) -> (x1,y1)) $ pToEPoint2 ppoint + | otherwise = (\(Point2 (x1,y1),_) -> (x1,y1)) $ pPtoEP ppoint e12Val = valOf 0 (getVal [GEPlus 1, GEPlus 2] rawVals) + (GVec rawVals) = vecOfP ppoint -- | canonicalize a euclidian point. -- Note: Normalization of euclidian points in PGA is really just canonicalization. @@ -985,9 +991,9 @@ canonicalizeIntersectionWithErr pl1 pl2 | isNothing foundVal = Nothing | otherwise = Just (cpp1, ulpTotal) where - (cpp1, UlpSum canonicalizationErr) = canonicalize pp1 - (pp1, UlpSum intersectionErr) = pLineIntersectionWithErr pl1 pl2 - ulpTotal = UlpSum $ intersectionErr + canonicalizationErr + (cpp1, canonicalizationErr) = canonicalize pp1 + (pp1, intersectionErr) = pLineIntersectionWithErr pl1 pl2 + ulpTotal = intersectionErr <> canonicalizationErr foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(PPoint2 (GVec vals)) -> vals) pp1 -- | Normalize a PLine2. From 6bde31388baf13d3eebe1b283dae3c405e5b46e7 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Fri, 14 Oct 2022 21:34:01 +0000 Subject: [PATCH 008/206] rename pPToEP to pToEP, use idealNormOfP more, and eliminate pToEPoint2 from PGA.hs --- Graphics/Slicer/Math/Contour.hs | 4 ++-- Graphics/Slicer/Math/Ganja.hs | 4 ++-- Graphics/Slicer/Math/Lossy.hs | 6 +++++- Graphics/Slicer/Math/PGA.hs | 21 +++++++------------- Graphics/Slicer/Math/Skeleton/Definitions.hs | 4 ++-- 5 files changed, 18 insertions(+), 21 deletions(-) diff --git a/Graphics/Slicer/Math/Contour.hs b/Graphics/Slicer/Math/Contour.hs index 3280462ad..2841211d6 100644 --- a/Graphics/Slicer/Math/Contour.hs +++ b/Graphics/Slicer/Math/Contour.hs @@ -50,9 +50,9 @@ import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum)) import Graphics.Slicer.Math.Intersections (contourIntersectionCount, noIntersection) -import Graphics.Slicer.Math.Lossy (eToPPoint2, join2PPoint2, pPointBetweenPPoints) +import Graphics.Slicer.Math.Lossy (eToPPoint2, join2PPoint2, pPointBetweenPPoints, pToEPoint2) -import Graphics.Slicer.Math.PGA (PPoint2, pLineFromEndpointsWithErr, pLineIsLeft, pPointOnPerpWithErr, pToEPoint2) +import Graphics.Slicer.Math.PGA (PPoint2, pLineFromEndpointsWithErr, pLineIsLeft, pPointOnPerpWithErr) -- Unapologetically ripped from ImplicitCAD. -- Added the ability to look at line segments backwards. diff --git a/Graphics/Slicer/Math/Ganja.hs b/Graphics/Slicer/Math/Ganja.hs index 5e4ac94fe..a8ed68a72 100644 --- a/Graphics/Slicer/Math/Ganja.hs +++ b/Graphics/Slicer/Math/Ganja.hs @@ -112,9 +112,9 @@ import Graphics.Slicer.Math.Definitions (Contour, Point2(Point2), LineSeg, endPo import Graphics.Slicer.Math.GeometricAlgebra (GNum(GEPlus, GEZero), GVec(GVec), getVal, valOf, UlpSum) -import Graphics.Slicer.Math.Lossy (eToPLine2, eToPPoint2, join2PPoint2, normalizePLine2, pPointBetweenPPoints) +import Graphics.Slicer.Math.Lossy (eToPLine2, eToPPoint2, join2PPoint2, normalizePLine2, pPointBetweenPPoints, pToEPoint2) -import Graphics.Slicer.Math.PGA (PPoint2(PPoint2), PLine2(PLine2), flipPLine2, pToEPoint2, translateRotatePPoint2, pLineFromEndpointsWithErr, ulpOfLineSeg, outOf, pPointOf, NPLine2(NPLine2)) +import Graphics.Slicer.Math.PGA (PPoint2(PPoint2), PLine2(PLine2), flipPLine2, translateRotatePPoint2, pLineFromEndpointsWithErr, ulpOfLineSeg, outOf, pPointOf, NPLine2(NPLine2)) import Graphics.Slicer.Math.Skeleton.Concave (makeENode, getOutsideArc) diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index 773d2c894..cbda27f19 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -39,6 +39,7 @@ module Graphics.Slicer.Math.Lossy ( pLineFromEndpoints, pPointBetweenPPoints, pPointOnPerp, + pToEPoint2, translatePLine2 ) where @@ -49,7 +50,7 @@ import Graphics.Slicer.Definitions (ℝ) import Graphics.Slicer.Math.Definitions (LineSeg, Point2) -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2, PLine2, PPoint2(PPoint2), ProjectiveLine2, ProjectivePoint2, angleBetweenWithErr, canonicalize, distanceBetweenPPointsWithErr, distanceBetweenNPLine2sWithErr, distanceCPPointToNPLineWithErr, distancePPointToPLineWithErr, eToCPPoint2WithErr, eToPLine2WithErr, eToPPoint2WithErr, getFirstArcWithErr, getInsideArcWithErr, join2CPPoint2WithErr, join2PPoint2WithErr, makeCPPoint2WithErr, normalize, pLineFromEndpointsWithErr, pPointBetweenPPointsWithErr, pPointOnPerpWithErr, translatePLine2WithErr) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2, PLine2, PPoint2(PPoint2), ProjectiveLine2, ProjectivePoint2, angleBetweenWithErr, canonicalize, distanceBetweenPPointsWithErr, distanceBetweenNPLine2sWithErr, distanceCPPointToNPLineWithErr, distancePPointToPLineWithErr, eToCPPoint2WithErr, eToPLine2WithErr, eToPPoint2WithErr, getFirstArcWithErr, getInsideArcWithErr, join2CPPoint2WithErr, join2PPoint2WithErr, makeCPPoint2WithErr, normalize, pLineFromEndpointsWithErr, pPointBetweenPPointsWithErr, pPointOnPerpWithErr, pToEP, translatePLine2WithErr) angleBetween :: NPLine2 -> NPLine2 -> ℝ angleBetween nPLine1 nPLine2 = fst $ angleBetweenWithErr nPLine1 nPLine2 @@ -121,6 +122,9 @@ normalizePLine2 pl = fst $ normalize pl pLineFromEndpoints :: Point2 -> Point2 -> PLine2 pLineFromEndpoints point1 point2 = fst $ pLineFromEndpointsWithErr point1 point2 +pToEPoint2 :: (ProjectivePoint2 a) => a -> Point2 +pToEPoint2 pp = fst $ pToEP pp + -- | Find a point somewhere along the line between the two points given. -- requires two weights. the ratio of these weights determines the position of the found points, E.G: (2/3,1/3) is 1/3 the way FROM the stopPoint, and 2/3 the way FROM the startPoint. weights can sum to anything. pPointBetweenPPoints :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> ℝ -> ℝ -> PPoint2 diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 383a98621..2c81e17f0 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -62,7 +62,7 @@ module Graphics.Slicer.Math.PGA( pPointBetweenPPointsWithErr, pPointOnPerpWithErr, pPointsOnSameSideOfPLine, - pToEPoint2, + pToEP, plinesIntersectIn, translatePLine2WithErr, translateRotatePPoint2, @@ -128,7 +128,7 @@ plinesIntersectIn pl1 pl2 | oppositeDirection pl1 pl2 = PAntiParallel | otherwise = IntersectsIn res (resUlp, intersectUlp, npl1Ulp, npl2Ulp, iaErr, mempty) where - (idealNorm, idnErr) = idealNormPPoint2WithErr intersectPoint + (idealNorm, idnErr) = idealNormOfP intersectPoint (_, iaErr) = angleBetweenWithErr pl1 pl2 -- FIXME: how much do the potential normalization errors have an effect on the resultant angle? (intersectPoint, intersectUlp) = pLineIntersectionWithErr pl1 pl2 @@ -244,7 +244,7 @@ distanceBetweenPPointsWithErr point1 point2 = (res, ulpTotal) distanceBetweenNPLine2sWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, UlpSum) distanceBetweenNPLine2sWithErr line1 line2 = (ideal, resUlpSum) where - (ideal, idealUlpSum) = idealNormPPoint2WithErr $ PPoint2 likeRes + (ideal, idealUlpSum) = idealNormOfP $ PPoint2 likeRes resUlpSum = idealUlpSum <> sumErrVals likeMulErr <> sumErrVals likeAddErr (likeRes, (likeMulErr, likeAddErr)) = p1 ⎣+ p2 p1 = vecOfL $ forcePLine2Basis npl1 @@ -665,19 +665,20 @@ class Arcable a where class ProjectivePoint2 a where canonicalize :: a -> (CPPoint2, UlpSum) - pPtoEP :: a -> (Point2, UlpSum) + pToEP :: a -> (Point2, UlpSum) idealNormOfP :: a -> (ℝ, UlpSum) vecOfP :: a -> GVec instance ProjectivePoint2 PPoint2 where canonicalize p = (\(a, PPoint2Err _ c8izeErrs _ _ _ _ _) -> (a,sumPPointErrs c8izeErrs)) $ canonicalizePPoint2WithErr p idealNormOfP a = idealNormPPoint2WithErr a - pPtoEP a = fromMaybe (error "created an infinite point when trying to convert from a Projective point to a euclidian one.") $ pPointToPoint2 a + pToEP a = fromMaybe (error "created an infinite point when trying to convert from a Projective point to a euclidian one.") $ pPointToPoint2 a vecOfP (PPoint2 a) = a instance ProjectivePoint2 CPPoint2 where canonicalize p = (p, mempty) idealNormOfP a = idealNormPPoint2WithErr a + pToEP a = fromMaybe (error "created an infinite point when trying to convert from a Projective point to a euclidian one.") $ pPointToPoint2 a vecOfP (CPPoint2 a) = a -- | A projective line in 2D space. @@ -796,14 +797,6 @@ makeCPPoint2WithErr x y = (pPoint pPoint = CPPoint2 $ GVec $ foldl' addValWithoutErr [GVal 1 (fromList [GEPlus 1, GEPlus 2])] [ GVal (negate x) (fromList [GEZero 1, GEPlus 2]), GVal y (fromList [GEZero 1, GEPlus 1]) ] posErr = PPoint2PosErr $ abs (realToFrac $ doubleUlp $ negate x) -- + abs (realToFrac $ doubleUlp y) --- | Create a euclidian point from a projective point. -pToEPoint2 :: PPoint2 -> Point2 -pToEPoint2 ppoint - | isNothing res = error "created an infinite point when trying to convert from a PPoint2 to a Point2" - | otherwise = fst $ fromJust res - where - res = pPointToPoint2 ppoint - -- | Create a euclidian point from a projective point. cPToEPoint2 :: CPPoint2 -> Point2 cPToEPoint2 (CPPoint2 rawPoint) @@ -954,7 +947,7 @@ idealNormPPoint2WithErr ppoint (x,y) | e12Val == 0 = ( negate $ valOf 0 $ getVal [GEZero 1, GEPlus 2] rawVals , valOf 0 $ getVal [GEZero 1, GEPlus 1] rawVals) - | otherwise = (\(Point2 (x1,y1),_) -> (x1,y1)) $ pPtoEP ppoint + | otherwise = (\(Point2 (x1,y1),_) -> (x1,y1)) $ pToEP ppoint e12Val = valOf 0 (getVal [GEPlus 1, GEPlus 2] rawVals) (GVec rawVals) = vecOfP ppoint diff --git a/Graphics/Slicer/Math/Skeleton/Definitions.hs b/Graphics/Slicer/Math/Skeleton/Definitions.hs index 3f9f28acd..08a932929 100644 --- a/Graphics/Slicer/Math/Skeleton/Definitions.hs +++ b/Graphics/Slicer/Math/Skeleton/Definitions.hs @@ -53,9 +53,9 @@ import Slist.Type (Slist(Slist)) import Graphics.Implicit.Definitions (ℝ) -import Graphics.Slicer.Math.Lossy (eToPLine2, eToPPoint2, canonicalizePPoint2) +import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, eToPLine2, eToPPoint2, pToEPoint2) -import Graphics.Slicer.Math.PGA (pToEPoint2, plinesIntersectIn, PIntersection(IntersectsIn), flipPLine2, PLine2(PLine2), pLineIsLeft, distanceBetweenPPointsWithErr, Pointable(canPoint, pPointOf, ePointOf), Arcable(hasArc, outOf, ulpOfOut, outUlpMag), CPPoint2(CPPoint2), PPoint2(PPoint2)) +import Graphics.Slicer.Math.PGA (plinesIntersectIn, PIntersection(IntersectsIn), flipPLine2, PLine2(PLine2), pLineIsLeft, distanceBetweenPPointsWithErr, Pointable(canPoint, pPointOf, ePointOf), Arcable(hasArc, outOf, ulpOfOut, outUlpMag), CPPoint2(CPPoint2), PPoint2(PPoint2)) import Graphics.Slicer.Math.Definitions (Contour, LineSeg(LineSeg), Point2, mapWithFollower, fudgeFactor, startPoint, distance, endPoint, lineSegsOfContour, makeLineSeg) From fc0e06a1412ea22767eff51d5b6fa3bced31cb94 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Fri, 14 Oct 2022 21:56:56 +0000 Subject: [PATCH 009/206] remove cPToEPoint2 --- Graphics/Slicer/Machine/Contour.hs | 6 +++--- Graphics/Slicer/Math/Intersections.hs | 6 +++--- Graphics/Slicer/Math/PGA.hs | 11 +---------- Graphics/Slicer/Math/Skeleton/Cells.hs | 6 +++--- Graphics/Slicer/Math/Skeleton/Line.hs | 8 ++++---- Graphics/Slicer/Math/Skeleton/Motorcycles.hs | 10 +++++----- 6 files changed, 19 insertions(+), 28 deletions(-) diff --git a/Graphics/Slicer/Machine/Contour.hs b/Graphics/Slicer/Machine/Contour.hs index e9cdd8ec1..1ec76ef66 100644 --- a/Graphics/Slicer/Machine/Contour.hs +++ b/Graphics/Slicer/Machine/Contour.hs @@ -35,9 +35,9 @@ import Graphics.Slicer.Math.Intersections (noIntersection) import Graphics.Slicer.Math.Line (combineLineSegs) -import Graphics.Slicer.Math.Lossy (eToPLine2, translatePLine2) +import Graphics.Slicer.Math.Lossy (eToPLine2, pToEPoint2, translatePLine2) -import Graphics.Slicer.Math.PGA (combineConsecutiveLineSegs, PIntersection(IntersectsIn), plinesIntersectIn, cPToEPoint2) +import Graphics.Slicer.Math.PGA (combineConsecutiveLineSegs, PIntersection(IntersectsIn), plinesIntersectIn) import Graphics.Slicer.Definitions(ℝ) @@ -113,7 +113,7 @@ modifyContour pathWidth contour direction IntersectsIn _ _ -> True _other -> False intersectionPoint pl1 pl2 = case plinesIntersectIn pl1 pl2 of - IntersectsIn p2 _ -> cPToEPoint2 p2 + IntersectsIn p2 _ -> pToEPoint2 p2 a -> error $ "impossible result!\nresult: " <> show a <> "\npline 1: " <> show pl1 <> "\npline 2: " <> show pl2 <> "\nEvaluating line intersections between:\nFirst: " <> show previousln diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index 79c2a216a..25c5dbedf 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -36,9 +36,9 @@ import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, mapWithNeighb import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum)) -import Graphics.Slicer.Math.Lossy (normalizePLine2) +import Graphics.Slicer.Math.Lossy (normalizePLine2, pToEPoint2) -import Graphics.Slicer.Math.PGA (CPPoint2, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), Intersection(HitEndPoint, HitStartPoint, NoIntersection), PLine2, intersectsWith, cPToEPoint2, distanceBetweenNPLine2sWithErr, outputIntersectsLineSeg, plinesIntersectIn, ulpOfLineSeg) +import Graphics.Slicer.Math.PGA (CPPoint2, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), Intersection(HitEndPoint, HitStartPoint, NoIntersection), PLine2, intersectsWith, distanceBetweenNPLine2sWithErr, outputIntersectsLineSeg, plinesIntersectIn, ulpOfLineSeg) import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle)) @@ -103,7 +103,7 @@ getPLine2Intersections pLine c getPoints vs = getPoint <$> vs where getPoint (_, Left v) = v - getPoint (_, Right v) = cPToEPoint2 v + getPoint (_, Right v) = pToEPoint2 v -- | filter the intersections given. -- The purpose of this function is to ensure we only count the crossing of a line (segment) across a contour's edge more than once. so if it hits a sttartpoint, make sure we don't count the endpoint.. etc. diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 2c81e17f0..81d587502 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -38,7 +38,6 @@ module Graphics.Slicer.Math.PGA( angleBetweenWithErr, combineConsecutiveLineSegs, canonicalize, - cPToEPoint2, distanceBetweenPPointsWithErr, distanceBetweenNPLine2sWithErr, distanceCPPointToNPLineWithErr, @@ -797,14 +796,6 @@ makeCPPoint2WithErr x y = (pPoint pPoint = CPPoint2 $ GVec $ foldl' addValWithoutErr [GVal 1 (fromList [GEPlus 1, GEPlus 2])] [ GVal (negate x) (fromList [GEZero 1, GEPlus 2]), GVal y (fromList [GEZero 1, GEPlus 1]) ] posErr = PPoint2PosErr $ abs (realToFrac $ doubleUlp $ negate x) -- + abs (realToFrac $ doubleUlp y) --- | Create a euclidian point from a projective point. -cPToEPoint2 :: CPPoint2 -> Point2 -cPToEPoint2 (CPPoint2 rawPoint) - | isNothing res = error "created an infinite point when trying to convert from a Projective point to a euclidian one." - | otherwise = fst $ fromJust res - where - res = pPointToPoint2 $ PPoint2 rawPoint - -- | Maybe create a euclidian point from a projective point. -- FIXME: canonicalization certainly does... pPointToPoint2 :: (ProjectivePoint2 a) => a -> Maybe (Point2, UlpSum) @@ -989,7 +980,7 @@ canonicalizeIntersectionWithErr pl1 pl2 ulpTotal = intersectionErr <> canonicalizationErr foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(PPoint2 (GVec vals)) -> vals) pp1 --- | Normalize a PLine2. +-- | Normalize a Projective Line. normalizePLine2WithErr :: (ProjectiveLine2 a) => a -> (NPLine2, PLine2Err) normalizePLine2WithErr line = (res, resErr) where diff --git a/Graphics/Slicer/Math/Skeleton/Cells.hs b/Graphics/Slicer/Math/Skeleton/Cells.hs index 49adbea36..8006eed42 100644 --- a/Graphics/Slicer/Math/Skeleton/Cells.hs +++ b/Graphics/Slicer/Math/Skeleton/Cells.hs @@ -56,9 +56,9 @@ import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum)) import Graphics.Slicer.Math.Intersections (intersectionOf) -import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, eToCPPoint2, eToNPLine2, eToPLine2, eToPPoint2, join2PPoint2, normalizePLine2) +import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, eToCPPoint2, eToNPLine2, eToPLine2, eToPPoint2, join2PPoint2, normalizePLine2, pToEPoint2) -import Graphics.Slicer.Math.PGA (Arcable(outOf), Pointable(canPoint, ePointOf, pPointOf), CPPoint2, PIntersection(PAntiCollinear, IntersectsIn), angleBetweenWithErr, distanceBetweenPPointsWithErr, plinesIntersectIn, cPToEPoint2) +import Graphics.Slicer.Math.PGA (Arcable(outOf), Pointable(canPoint, ePointOf, pPointOf), CPPoint2, PIntersection(PAntiCollinear, IntersectsIn), angleBetweenWithErr, distanceBetweenPPointsWithErr, plinesIntersectIn) data UnsupportedReason = INodeCrossesDivide ![(INode,CellDivide)] !NodeTree deriving (Show, Eq) @@ -112,7 +112,7 @@ findDivisions contour crashTree = case motorcyclesIn crashTree of intersectionIsBehind m = angleFound < realToFrac angleErr where (angleFound, UlpSum angleErr) = angleBetweenWithErr (normalizePLine2 $ outOf m) (eToNPLine2 $ lineSegToIntersection m) - lineSegToIntersection m = makeLineSeg (ePointOf m) (cPToEPoint2 intersectionPPoint) + lineSegToIntersection m = makeLineSeg (ePointOf m) (pToEPoint2 intersectionPPoint) intersectionPPoint = intersectionOf (outOf firstMC) (outOf secondMC) (Slist (_:_) _) -> error "too many motorcycles." motorcyclesIn (CrashTree motorcycles _ _) = motorcycles diff --git a/Graphics/Slicer/Math/Skeleton/Line.hs b/Graphics/Slicer/Math/Skeleton/Line.hs index 2b46ab6a8..b2b514569 100644 --- a/Graphics/Slicer/Math/Skeleton/Line.hs +++ b/Graphics/Slicer/Math/Skeleton/Line.hs @@ -42,9 +42,9 @@ import Graphics.Slicer.Math.Intersections (intersectionOf) import Graphics.Slicer.Math.Skeleton.Face (Face(Face)) -import Graphics.Slicer.Math.Lossy (eToNPLine2, eToPLine2, distanceCPPointToNPLine, translatePLine2) +import Graphics.Slicer.Math.Lossy (eToNPLine2, eToPLine2, distanceCPPointToNPLine, translatePLine2, pToEPoint2) -import Graphics.Slicer.Math.PGA (PLine2, cPToEPoint2, pLineIsLeft) +import Graphics.Slicer.Math.PGA (PLine2, pLineIsLeft) import Graphics.Slicer.Machine.Infill (makeInfill, InfillType) @@ -77,12 +77,12 @@ addLineSegsToFace distance insets face@(Face edge firstArc midArcs@(Slist rawMid linesToRender = maybe linesUntilEnd (min linesUntilEnd) insets -- | The line segments we are placing. - foundLineSegs = [ makeLineSeg (cPToEPoint2 $ intersectionOf newSide firstArc) (cPToEPoint2 $ intersectionOf newSide lastArc) | newSide <- newSides ] + foundLineSegs = [ makeLineSeg (pToEPoint2 $ intersectionOf newSide firstArc) (pToEPoint2 $ intersectionOf newSide lastArc) | newSide <- newSides ] where newSides = [ translatePLine2 (eToPLine2 edge) $ translateDir (-(distance+(distance * fromIntegral segmentNum))) | segmentNum <- [0..linesToRender-1] ] -- | The line where we are no longer able to fill this face. from the firstArc to the lastArc, along the point that the lines we place stop. - finalSide = makeLineSeg (cPToEPoint2 $ intersectionOf finalLine firstArc) (cPToEPoint2 $ intersectionOf finalLine lastArc) + finalSide = makeLineSeg (pToEPoint2 $ intersectionOf finalLine firstArc) (pToEPoint2 $ intersectionOf finalLine lastArc) where finalLine = translatePLine2 (eToPLine2 edge) $ translateDir (distance * fromIntegral linesToRender) diff --git a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs index db328e5a0..9692ebb62 100644 --- a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs +++ b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs @@ -48,9 +48,9 @@ import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, distance, map import Graphics.Slicer.Math.Intersections (getMotorcycleSegSetIntersections, getMotorcycleContourIntersections, intersectionOf, isAntiCollinear, noIntersection) -import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, pPointBetweenPPoints, distanceBetweenPPoints, eToNPLine2, eToCPPoint2, eToPLine2, normalizePLine2, pLineFromEndpoints, translatePLine2) +import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, pPointBetweenPPoints, distanceBetweenPPoints, eToNPLine2, eToCPPoint2, eToPLine2, normalizePLine2, pLineFromEndpoints, pToEPoint2, translatePLine2) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2(NPLine2), PLine2(PLine2), PPoint2, Arcable(outOf), Pointable(canPoint, ePointOf, pPointOf), cPToEPoint2, flipPLine2, pLineIsLeft, pPointsOnSameSideOfPLine, PIntersection(IntersectsIn,PAntiCollinear), plinesIntersectIn, angleBetweenWithErr, outputIntersectsLineSeg, ulpOfPLine2, ulpOfLineSeg) +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2(NPLine2), PLine2(PLine2), PPoint2, Arcable(outOf), Pointable(canPoint, ePointOf, pPointOf), flipPLine2, pLineIsLeft, pPointsOnSameSideOfPLine, PIntersection(IntersectsIn,PAntiCollinear), plinesIntersectIn, angleBetweenWithErr, outputIntersectsLineSeg, ulpOfPLine2, ulpOfLineSeg) import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle), ENode(ENode), getFirstLineSeg, linePairs, CellDivide(CellDivide), DividingMotorcycles(DividingMotorcycles), MotorcycleIntersection(WithLineSeg, WithENode, WithMotorcycle)) @@ -158,7 +158,7 @@ crashMotorcycles contour holes intersectionIsBehind m = angleFound < realToFrac angleErr where (angleFound, UlpSum angleErr) = angleBetweenWithErr (normalizePLine2 $ outOf m) (eToNPLine2 $ lineSegToIntersection m) - lineSegToIntersection m = makeLineSeg (ePointOf m) (cPToEPoint2 intersectionPPoint) + lineSegToIntersection m = makeLineSeg (ePointOf m) (pToEPoint2 intersectionPPoint) -- | Find the non-reflex virtexes of a contour and draw motorcycles from them. Useful for contours that are a 'hole' in a bigger contour. -- This function is meant to be used on the exterior contour. @@ -259,7 +259,7 @@ motorcycleMightIntersectWith lineSegs motorcycle where (angleFound, UlpSum angleErr) = angleBetweenWithErr (normalizePLine2 $ outOf motorcycle) (eToNPLine2 $ lineSegToIntersectionP pPoint) lineSegToIntersection myPoint = makeLineSeg (ePointOf motorcycle) myPoint - lineSegToIntersectionP myPPoint = makeLineSeg (ePointOf motorcycle) (cPToEPoint2 myPPoint) + lineSegToIntersectionP myPPoint = makeLineSeg (ePointOf motorcycle) (pToEPoint2 myPPoint) -- | Find the closest place where a motorcycle intersects a contour that is not the point where it ejects from. -- If the motorcycle lands between two segments, return the second line segment, otherwise return the PPoint2 of the intersection with the first LineSeg. @@ -302,7 +302,7 @@ motorcycleIntersectsAt contour motorcycle = case intersections of where (angleFound, UlpSum angleErr) = angleBetweenWithErr (normalizePLine2 $ outOf motorcycle) (eToNPLine2 $ lineSegToIntersectionP pPoint) lineSegToIntersection myPoint = makeLineSeg (ePointOf motorcycle) myPoint - lineSegToIntersectionP myPPoint = makeLineSeg (ePointOf motorcycle) (cPToEPoint2 myPPoint) + lineSegToIntersectionP myPPoint = makeLineSeg (ePointOf motorcycle) (pToEPoint2 myPPoint) motorcyclePoint = canonicalizePPoint2 $ pPointOf motorcycle intersections = getMotorcycleContourIntersections motorcycle contour From 8732b9841e58e08d8c8f97324d570c399c06320c Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 15 Oct 2022 10:20:15 +0000 Subject: [PATCH 010/206] implement flipL, and use consLike to rebuild flipL and force*basis into type mirroring functions. --- Graphics/Slicer/Math/Ganja.hs | 8 +- Graphics/Slicer/Math/PGA.hs | 108 ++++++++++--------- Graphics/Slicer/Math/Skeleton/Concave.hs | 14 +-- Graphics/Slicer/Math/Skeleton/Definitions.hs | 4 +- Graphics/Slicer/Math/Skeleton/Motorcycles.hs | 6 +- tests/Math/PGA.hs | 8 +- 6 files changed, 76 insertions(+), 72 deletions(-) diff --git a/Graphics/Slicer/Math/Ganja.hs b/Graphics/Slicer/Math/Ganja.hs index a8ed68a72..53e4e2225 100644 --- a/Graphics/Slicer/Math/Ganja.hs +++ b/Graphics/Slicer/Math/Ganja.hs @@ -114,7 +114,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (GNum(GEPlus, GEZero), GVec(GVec), import Graphics.Slicer.Math.Lossy (eToPLine2, eToPPoint2, join2PPoint2, normalizePLine2, pPointBetweenPPoints, pToEPoint2) -import Graphics.Slicer.Math.PGA (PPoint2(PPoint2), PLine2(PLine2), flipPLine2, translateRotatePPoint2, pLineFromEndpointsWithErr, ulpOfLineSeg, outOf, pPointOf, NPLine2(NPLine2)) +import Graphics.Slicer.Math.PGA (PPoint2(PPoint2), PLine2(PLine2), flipL, translateRotatePPoint2, pLineFromEndpointsWithErr, ulpOfLineSeg, outOf, pPointOf, NPLine2(NPLine2)) import Graphics.Slicer.Math.Skeleton.Concave (makeENode, getOutsideArc) @@ -656,13 +656,13 @@ randomINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 = makeINode [maybeFlippedpl1,m r1 = rawR1 / 2 r2 = r1 + (rawR2 / 2) pl1 = (\(NPLine2 a) -> PLine2 a) $ normalizePLine2 $ eToPLine2 $ getFirstLineSeg eNode - pl2 = (\(NPLine2 a) -> PLine2 a) $ normalizePLine2 $ flipPLine2 $ eToPLine2 $ getLastLineSeg eNode + pl2 = (\(NPLine2 a) -> PLine2 a) $ normalizePLine2 $ flipL $ eToPLine2 $ getLastLineSeg eNode intersectionPPoint = pPointOf eNode eNode = randomENode x y d1 rawR1 d2 rawR2 pp1 = translateRotatePPoint2 intersectionPPoint (coerce d1) (coerce r1) pp2 = translateRotatePPoint2 intersectionPPoint (coerce d2) (coerce r2) - maybeFlippedpl1 = if flipIn1 then flipPLine2 pl1 else pl1 - maybeFlippedpl2 = if flipIn2 then flipPLine2 pl2 else pl2 + maybeFlippedpl1 = if flipIn1 then flipL pl1 else pl1 + maybeFlippedpl2 = if flipIn2 then flipL pl2 else pl2 bisector1 = (\(NPLine2 a) -> PLine2 a) $ normalizePLine2 $ getOutsideArc pp1 (normalizePLine2 maybeFlippedpl1) pp2 (normalizePLine2 maybeFlippedpl2) -- | A helper function. constructs a random PLine. diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 81d587502..6c1cc8017 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -45,7 +45,7 @@ module Graphics.Slicer.Math.PGA( eToCPPoint2WithErr, eToPLine2WithErr, eToPPoint2WithErr, - flipPLine2, + flipL, getInsideArcWithErr, getFirstArcWithErr, intersectsWith, @@ -206,7 +206,7 @@ distanceCPPointToNPLineWithErr point line (newPLine, newPLineErr) = join2CPPoint2WithErr point linePoint (perpLine, (plMulErr,plAddErr))= lvec ⨅+ npvec (PLine2 lvec) = forcePLine2Basis (PLine2 nplvec) - (CPPoint2 npvec) = forceCPPoint2Basis point + (CPPoint2 npvec) = forceBasisOfP point (linePoint, lpErr) = fromJust $ canonicalizeIntersectionWithErr (PLine2 lvec) (PLine2 perpLine) ulpTotal = sumErrVals plMulErr <> sumErrVals plAddErr {- <> resErr -} <> newPLineErr <> lpErr foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(CPPoint2 (GVec vals)) -> vals) point @@ -226,8 +226,8 @@ pPointsOnSameSideOfPLine point1 point2 line unlikeP2UlpSum = sumErrVals unlikeP2MulErr <> sumErrVals unlikeP2AddErr (GVec unlikeP1, (unlikeP1MulErr, unlikeP1AddErr)) = pv1 ⎤+ lv1 (GVec unlikeP2, (unlikeP2MulErr, unlikeP2AddErr)) = pv2 ⎤+ lv1 - (PPoint2 pv1) = forcePPoint2Basis point1 - (PPoint2 pv2) = forcePPoint2Basis point2 + (PPoint2 pv1) = forceBasisOfP point1 + (PPoint2 pv2) = forceBasisOfP point2 lv1 = vecOfL $ forcePLine2Basis line distanceBetweenPPointsWithErr :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> (ℝ, UlpSum) @@ -293,7 +293,7 @@ pPointOnPerpWithErr line rppoint d = (PPoint2 res, (NPLine2 rlvec, lErr) = normalize line (perpLine, (plMulErr,plAddErr))= lvec ⨅+ pvec (PLine2 lvec) = forcePLine2Basis $ PLine2 rlvec - (PPoint2 pvec) = forcePPoint2Basis rppoint + (PPoint2 pvec) = forceBasisOfP rppoint motor = addVecPairWithoutErr (perpLine • gaIScaled) (GVec [GVal 1 (singleton G0)]) -- I, in this geometric algebra system. we multiply it times d/2, to shorten the number of multiples we have to do when creating the motor. gaIScaled = GVec [GVal (d/2) (fromList [GEZero 1, GEPlus 1, GEPlus 2])] @@ -600,7 +600,7 @@ getInsideArcWithErr line1 line2 ulpSum = resUlp <> sumErrVals addVecErr (NPLine2 normRes, resUlp) = normalize $ PLine2 $ addVecRes (addVecRes, addVecErr) = addVecPairWithErr flippedPV1 pv2 - flippedPV1 = vecOfL $ flipPLine2 line1 + flippedPV1 = vecOfL $ flipL line1 pv2 = vecOfL line2 ------------------------------------------------ @@ -664,18 +664,24 @@ class Arcable a where class ProjectivePoint2 a where canonicalize :: a -> (CPPoint2, UlpSum) - pToEP :: a -> (Point2, UlpSum) + consLikeP :: a -> (GVec -> a) + forceBasisOfP :: a -> a idealNormOfP :: a -> (ℝ, UlpSum) + pToEP :: a -> (Point2, UlpSum) vecOfP :: a -> GVec instance ProjectivePoint2 PPoint2 where canonicalize p = (\(a, PPoint2Err _ c8izeErrs _ _ _ _ _) -> (a,sumPPointErrs c8izeErrs)) $ canonicalizePPoint2WithErr p + consLikeP (PPoint2 _) = PPoint2 + forceBasisOfP a = forceProjectivePointBasis a idealNormOfP a = idealNormPPoint2WithErr a pToEP a = fromMaybe (error "created an infinite point when trying to convert from a Projective point to a euclidian one.") $ pPointToPoint2 a vecOfP (PPoint2 a) = a instance ProjectivePoint2 CPPoint2 where canonicalize p = (p, mempty) + consLikeP (CPPoint2 _) = CPPoint2 + forceBasisOfP a = forceProjectivePointBasis a idealNormOfP a = idealNormPPoint2WithErr a pToEP a = fromMaybe (error "created an infinite point when trying to convert from a Projective point to a euclidian one.") $ pPointToPoint2 a vecOfP (CPPoint2 a) = a @@ -689,23 +695,26 @@ newtype NPLine2 = NPLine2 GVec deriving (Eq, Generic, NFData, Show) class ProjectiveLine2 a where - normalize :: a -> (NPLine2, UlpSum) - flipPLine2 :: a -> a + consLikeL :: a -> (GVec -> a) + flipL :: a -> a forcePLine2Basis :: a -> a + normalize :: a -> (NPLine2, UlpSum) translatePLine2WithErr :: a -> ℝ -> (a, UlpSum) vecOfL :: a -> GVec instance ProjectiveLine2 NPLine2 where + consLikeL (NPLine2 _) = NPLine2 + flipL a = flipProjectiveLine a + forcePLine2Basis a = forceProjectiveLine2Basis a normalize a = (a, mempty) - flipPLine2 (NPLine2 a) = NPLine2 $ flipGVec a - forcePLine2Basis (NPLine2 a) = NPLine2 $ forceProjectiveLine2Basis a translatePLine2WithErr (NPLine2 a) d = (\(b,(PLine2Err _ _ _ _ t _)) -> (NPLine2 b,t)) $ translateProjectiveLine2WithErr a d vecOfL (NPLine2 a) = a instance ProjectiveLine2 PLine2 where + consLikeL (PLine2 _) = PLine2 + flipL a = flipProjectiveLine a + forcePLine2Basis a = forceProjectiveLine2Basis a normalize a = (\(b,(PLine2Err _ _ c d _ _)) -> (b,c <> d)) $ normalizePLine2WithErr a - flipPLine2 (PLine2 a) = PLine2 $ flipGVec a - forcePLine2Basis (PLine2 a) = PLine2 $ forceProjectiveLine2Basis a translatePLine2WithErr (PLine2 a) d = (\(b,(PLine2Err _ _ _ _ t _)) -> (PLine2 b,t)) $ translateProjectiveLine2WithErr a d vecOfL (PLine2 a) = a @@ -760,8 +769,8 @@ join2CPPoint2WithErr pp1 pp2 = (PLine2 res, resUlp) where (res,resUlp) = pv1 ∨+ pv2 - (CPPoint2 pv1) = forceCPPoint2Basis pp1 - (CPPoint2 pv2) = forceCPPoint2Basis pp2 + (CPPoint2 pv1) = forceBasisOfP pp1 + (CPPoint2 pv2) = forceBasisOfP pp2 -- | A typed meet function. the meeting of two lines is a point. meet2PLine2WithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PPoint2, UlpSum) @@ -852,35 +861,36 @@ forceBasis numsets (GVec vals) = GVec $ forceVal vals <$> sort numsets forceVal has needs = GVal (valOf 0 $ getVal (elems needs) has) needs -- | runtime basis coersion. ensure all of the '0' components exist on a PLine2. -forceProjectiveLine2Basis :: GVec -> GVec -forceProjectiveLine2Basis pvec@(GVec [GVal _ gnum1, GVal _ gnum2, GVal _ gnum3]) - | gnum1 == singleton (GEZero 1) && - gnum2 == singleton (GEPlus 1) && - gnum3 == singleton (GEPlus 2) = pvec - | otherwise = forceBasis [singleton (GEZero 1), singleton (GEPlus 1), singleton (GEPlus 2)] pvec -forceProjectiveLine2Basis pvec = forceBasis [singleton (GEZero 1), singleton (GEPlus 1), singleton (GEPlus 2)] pvec - --- | runtime basis coersion. ensure all of the '0' components exist on a PPoint2. -forcePPoint2Basis :: PPoint2 -> PPoint2 -forcePPoint2Basis pt@(PPoint2 pvec@(GVec [GVal _ gnum1, GVal _ gnum2, GVal _ gnum3])) - | gnum1 == fromList [GEZero 1, GEPlus 1] && - gnum2 == fromList [GEZero 1, GEPlus 2] && - gnum3 == fromList [GEPlus 1, GEPlus 2] = pt - | otherwise = PPoint2 $ forceBasis [fromList [GEZero 1, GEPlus 1], fromList [GEZero 1, GEPlus 2], fromList [GEPlus 1, GEPlus 2]] pvec -forcePPoint2Basis (PPoint2 pvec) = PPoint2 $ forceBasis [fromList [GEZero 1, GEPlus 1], fromList [GEZero 1, GEPlus 2], fromList [GEPlus 1, GEPlus 2]] pvec - --- | runtime basis coersion. ensure all of the '0' components exist on a PPoint2. -forceCPPoint2Basis :: CPPoint2 -> CPPoint2 -forceCPPoint2Basis pt@(CPPoint2 pvec@(GVec [GVal _ gnum1, GVal _ gnum2, GVal _ gnum3])) - | gnum1 == fromList [GEZero 1, GEPlus 1] && - gnum2 == fromList [GEZero 1, GEPlus 2] && - gnum3 == fromList [GEPlus 1, GEPlus 2] = pt - | otherwise = CPPoint2 $ forceBasis [fromList [GEZero 1, GEPlus 1], fromList [GEZero 1, GEPlus 2], fromList [GEPlus 1, GEPlus 2]] pvec -forceCPPoint2Basis (CPPoint2 pvec) = CPPoint2 $ forceBasis [fromList [GEZero 1, GEPlus 1], fromList [GEZero 1, GEPlus 2], fromList [GEPlus 1, GEPlus 2]] pvec +forceProjectiveLine2Basis :: (ProjectiveLine2 a) => a -> a +forceProjectiveLine2Basis line + | gnums == Just [singleton (GEZero 1), + singleton (GEPlus 1), + singleton (GEPlus 2)] = line + | otherwise = (consLikeL line) res + where + res = forceBasis [singleton (GEZero 1), singleton (GEPlus 1), singleton (GEPlus 2)] pvec + gnums = case vals of + [GVal _ g1, GVal _ g2, GVal _ g3] -> Just [g1,g2,g3] + _ -> Nothing + pvec@(GVec vals) = vecOfL line + +-- | runtime basis coersion. ensure all of the '0' components exist on a Projective Point. +forceProjectivePointBasis :: (ProjectivePoint2 a) => a -> a +forceProjectivePointBasis point + | gnums == Just [fromList [GEZero 1, GEPlus 1], + fromList [GEZero 1, GEPlus 2], + fromList [GEPlus 1, GEPlus 2]] = point + | otherwise = (consLikeP point) res + where + res = forceBasis [fromList [GEZero 1, GEPlus 1], fromList [GEZero 1, GEPlus 2], fromList [GEPlus 1, GEPlus 2]] pvec + gnums = case vals of + [GVal _ g1, GVal _ g2, GVal _ g3] -> Just [g1,g2,g3] + _ -> Nothing + pvec@(GVec vals) = vecOfP point -- | Reverse a line. same line, but pointed in the other direction. -flipGVec :: GVec -> GVec -flipGVec (GVec vals) = rawRes +flipProjectiveLine :: (ProjectiveLine2 a) => a -> a +flipProjectiveLine pline = (consLikeL pline) rawRes where rawRes = GVec $ foldl' addValWithoutErr [] [ @@ -888,22 +898,16 @@ flipGVec (GVec vals) = rawRes , GVal (negate $ valOf 0 $ getVal [GEPlus 1] vals) (singleton (GEPlus 1)) , GVal (negate $ valOf 0 $ getVal [GEPlus 2] vals) (singleton (GEPlus 2)) ] + (GVec vals) = vecOfL pline eToPLine2WithErr :: LineSeg -> (PLine2, UlpSum) eToPLine2WithErr l1 = pLineFromEndpointsWithErr (startPoint l1) (endPoint l1) + pLineFromEndpointsWithErr :: Point2 -> Point2 -> (PLine2, UlpSum) -pLineFromEndpointsWithErr (Point2 (x1,y1)) (Point2 (x2,y2)) = (PLine2 $ GVec $ foldl' addValWithoutErr [] [ GVal c (singleton (GEZero 1)), GVal a (singleton (GEPlus 1)), GVal b (singleton (GEPlus 2)) ], ulpTotal) +pLineFromEndpointsWithErr start stop = (res, resErr) where - a=y2-y1 - b=x1-x2 - c=y1*x2-x1*y2 - ulpTotal = UlpSum - $ abs (realToFrac $ doubleUlp $ y1*x2) - + abs (realToFrac $ doubleUlp $ x1*y2) - + abs (realToFrac $ doubleUlp a) - + abs (realToFrac $ doubleUlp b) - + abs (realToFrac $ doubleUlp c) + (res, resErr) = join2PPoint2WithErr (fst $ eToPPoint2WithErr start) (fst $ eToPPoint2WithErr stop) -- | Get the sum of the error involved in storing the values in a given PLine2. ulpOfPLine2 :: (ProjectiveLine2 a) => a -> UlpSum diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index cac354479..4f3aa28b2 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -60,7 +60,7 @@ import Graphics.Slicer.Math.Intersections (intersectionOf, intersectionBetween, import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, distancePPointToPLine, eToPLine2, getInsideArc, join2CPPoint2, normalizePLine2) -import Graphics.Slicer.Math.PGA (Arcable(hasArc, outOf), Pointable(canPoint, pPointOf), PLine2(PLine2), CPPoint2(CPPoint2), PPoint2(PPoint2), flipPLine2, getFirstArcWithErr, distanceBetweenPPointsWithErr, pLineIsLeft, angleBetweenWithErr, distancePPointToPLineWithErr, flipPLine2, NPLine2(NPLine2)) +import Graphics.Slicer.Math.PGA (Arcable(hasArc, outOf), Pointable(canPoint, pPointOf), PLine2(PLine2), CPPoint2(CPPoint2), PPoint2(PPoint2), flipL, getFirstArcWithErr, distanceBetweenPPointsWithErr, pLineIsLeft, angleBetweenWithErr, distancePPointToPLineWithErr, NPLine2(NPLine2)) import Graphics.Slicer.Math.Skeleton.Definitions (ENode(ENode), ENodeSet(ENodeSet), INode(INode), INodeSet(INodeSet), NodeTree(NodeTree), concavePLines, getFirstLineSeg, getLastLineSeg, finalOutOf, firstInOf, getPairs, indexPLinesTo, insOf, lastINodeOf, linePairs, makeINode, sortedPLines, isLoop) @@ -107,11 +107,11 @@ findINodes inSegSets | len inSegSets == 2 = -- Two walls, no closed ends. solve the ends of a hallway region, so we can then hand off the solutioning to our regular process. case initialENodes of - [] -> INodeSet $ slist [[makeINode [getInsideArc (flipPLine2 $ eToPLine2 firstSeg) (eToPLine2 lastSeg), getInsideArc (eToPLine2 firstSeg) (flipPLine2 $ eToPLine2 lastSeg)] Nothing]] + [] -> INodeSet $ slist [[makeINode [getInsideArc (flipL $ eToPLine2 firstSeg) (eToPLine2 lastSeg), getInsideArc (eToPLine2 firstSeg) (flipL $ eToPLine2 lastSeg)] Nothing]] where firstSeg = SL.head $ slist $ SL.head inSegSets lastSeg = SL.head $ slist $ SL.last inSegSets - [a] -> INodeSet $ slist [[makeINode [getInsideArc (eToPLine2 lastSeg) (eToPLine2 shortSide), getInsideArc (eToPLine2 firstSeg) (eToPLine2 shortSide)] (Just $ flipPLine2 $ outOf a)]] + [a] -> INodeSet $ slist [[makeINode [getInsideArc (eToPLine2 lastSeg) (eToPLine2 shortSide), getInsideArc (eToPLine2 firstSeg) (eToPLine2 shortSide)] (Just $ flipL $ outOf a)]] where firstSeg = fromMaybe (error "no first segment?") $ safeHead $ slist longSide lastSeg = SL.last $ slist longSide @@ -198,10 +198,10 @@ getOutsideArc :: PPoint2 -> NPLine2 -> PPoint2 -> NPLine2 -> PLine2 getOutsideArc ppoint1 npline1 ppoint2 npline2 | npline1 == npline2 = error "need to be able to return two PLines." | noIntersection pline1 pline2 = error $ "no intersection between pline " <> show pline1 <> " and " <> show pline2 <> ".\n" - | l1TowardPoint && l2TowardPoint = flipPLine2 $ getInsideArc pline1 (flipPLine2 pline2) - | l1TowardPoint = flipPLine2 $ getInsideArc pline1 pline2 + | l1TowardPoint && l2TowardPoint = flipL $ getInsideArc pline1 (flipL pline2) + | l1TowardPoint = flipL $ getInsideArc pline1 pline2 | l2TowardPoint = getInsideArc pline1 pline2 - | otherwise = getInsideArc pline1 (flipPLine2 pline2) + | otherwise = getInsideArc pline1 (flipL pline2) where pline1 = (\(NPLine2 v) -> PLine2 v) npline1 pline2 = (\(NPLine2 v) -> PLine2 v) npline2 @@ -493,7 +493,7 @@ sortINodesByENodes loop inSegSets inGens@(INodeSet rawGenerations) newINode1 = makeINode (withoutConnectingPLine $ insOf iNode2) (Just newConnectingPLine) -- like iNode1, but with our flipped connecting line in, and iNode2's original out. newINode2 = makeINode ([newConnectingPLine] <> insOf iNode1) maybeOut2 - newConnectingPLine = flipPLine2 oldConnectingPLine + newConnectingPLine = flipL oldConnectingPLine oldConnectingPLine = case iNodeInsOf iNode2 of [] -> error "could not find old connecting PLine." [v] -> v diff --git a/Graphics/Slicer/Math/Skeleton/Definitions.hs b/Graphics/Slicer/Math/Skeleton/Definitions.hs index 08a932929..3f762107c 100644 --- a/Graphics/Slicer/Math/Skeleton/Definitions.hs +++ b/Graphics/Slicer/Math/Skeleton/Definitions.hs @@ -55,7 +55,7 @@ import Graphics.Implicit.Definitions (ℝ) import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, eToPLine2, eToPPoint2, pToEPoint2) -import Graphics.Slicer.Math.PGA (plinesIntersectIn, PIntersection(IntersectsIn), flipPLine2, PLine2(PLine2), pLineIsLeft, distanceBetweenPPointsWithErr, Pointable(canPoint, pPointOf, ePointOf), Arcable(hasArc, outOf, ulpOfOut, outUlpMag), CPPoint2(CPPoint2), PPoint2(PPoint2)) +import Graphics.Slicer.Math.PGA (plinesIntersectIn, PIntersection(IntersectsIn), flipL, PLine2(PLine2), pLineIsLeft, distanceBetweenPPointsWithErr, Pointable(canPoint, pPointOf, ePointOf), Arcable(hasArc, outOf, ulpOfOut, outUlpMag), CPPoint2(CPPoint2), PPoint2(PPoint2)) import Graphics.Slicer.Math.Definitions (Contour, LineSeg(LineSeg), Point2, mapWithFollower, fudgeFactor, startPoint, distance, endPoint, lineSegsOfContour, makeLineSeg) @@ -320,7 +320,7 @@ concavePLines seg1 seg2 | otherwise = Nothing where (PLine2 pv1) = eToPLine2 seg1 - (PLine2 pv2) = flipPLine2 $ eToPLine2 seg2 + (PLine2 pv2) = flipL $ eToPLine2 seg2 -- | check if an INodeSet is empty. hasNoINodes :: INodeSet -> Bool diff --git a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs index 9692ebb62..be8be4271 100644 --- a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs +++ b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs @@ -50,7 +50,7 @@ import Graphics.Slicer.Math.Intersections (getMotorcycleSegSetIntersections, get import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, pPointBetweenPPoints, distanceBetweenPPoints, eToNPLine2, eToCPPoint2, eToPLine2, normalizePLine2, pLineFromEndpoints, pToEPoint2, translatePLine2) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2(NPLine2), PLine2(PLine2), PPoint2, Arcable(outOf), Pointable(canPoint, ePointOf, pPointOf), flipPLine2, pLineIsLeft, pPointsOnSameSideOfPLine, PIntersection(IntersectsIn,PAntiCollinear), plinesIntersectIn, angleBetweenWithErr, outputIntersectsLineSeg, ulpOfPLine2, ulpOfLineSeg) +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2(NPLine2), PLine2(PLine2), PPoint2, Arcable(outOf), Pointable(canPoint, ePointOf, pPointOf), flipL, pLineIsLeft, pPointsOnSameSideOfPLine, PIntersection(IntersectsIn,PAntiCollinear), plinesIntersectIn, angleBetweenWithErr, outputIntersectsLineSeg, ulpOfPLine2, ulpOfLineSeg) import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle), ENode(ENode), getFirstLineSeg, linePairs, CellDivide(CellDivide), DividingMotorcycles(DividingMotorcycles), MotorcycleIntersection(WithLineSeg, WithENode, WithMotorcycle)) @@ -194,9 +194,9 @@ motorcycleFromPoints p1 p2 p3 = getOutsideArc (pLineFromEndpoints p1 p2) (pLineF <> "PLine1: " <> show pline1 <> "\n" <> "PLine2: " <> show pline2 <> "\n" <> "result: " <> show (plinesIntersectIn pline1 pline2) <> "\n" - | otherwise = flipPLine2 $ PLine2 $ addVecPair flippedNPV1 npv2 + | otherwise = flipL $ PLine2 $ addVecPair flippedNPV1 npv2 where - (PLine2 flippedNPV1) = flipPLine2 $ (\(NPLine2 a) -> PLine2 a) $ normalizePLine2 pline1 + (PLine2 flippedNPV1) = flipL $ (\(NPLine2 a) -> PLine2 a) $ normalizePLine2 pline1 (NPLine2 npv2) = normalizePLine2 pline2 -- | Find the non-reflex virtexes of a contour and draw motorcycles from them. diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index 476cb85e6..b87272c67 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -59,7 +59,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(GEZero, GEPlu import Graphics.Slicer.Math.Lossy (angleBetween, canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenNPLine2s, distancePPointToPLine, eToCPPoint2, eToPLine2, eToPPoint2, getFirstArc, join2PPoint2, makeCPPoint2, makePPoint2, normalizePLine2, pPointOnPerp) -- Our 2D Projective Geometric Algebra library. -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PPoint2PosErr(PPoint2PosErr), canonicalize, pPointBetweenPPointsWithErr, distanceBetweenPPointsWithErr, distanceCPPointToNPLineWithErr, join2CPPoint2WithErr, pLineIntersectionWithErr, translatePLine2WithErr, translateRotatePPoint2, angleBetweenWithErr, flipPLine2, makeCPPoint2WithErr, normalize, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, pLineFromEndpointsWithErr, distancePPointToPLineWithErr, pPointOnPerpWithErr, outOf, pPointOf, ulpOfOut, outputIntersectsLineSeg, pPointBetweenPPointsWithErr) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PPoint2PosErr(PPoint2PosErr), canonicalize, pPointBetweenPPointsWithErr, distanceBetweenPPointsWithErr, distanceCPPointToNPLineWithErr, join2CPPoint2WithErr, pLineIntersectionWithErr, translatePLine2WithErr, translateRotatePPoint2, angleBetweenWithErr, flipL, makeCPPoint2WithErr, normalize, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, pLineFromEndpointsWithErr, distancePPointToPLineWithErr, pPointOnPerpWithErr, outOf, pPointOf, ulpOfOut, outputIntersectsLineSeg, pPointBetweenPPointsWithErr) -- Our Contour library. import Graphics.Slicer.Math.Contour (contourContainsContour, getContours, pointsOfContour, numPointsOfContour, justOneContourFrom, lineSegsOfContour, makeLineSegContour, makePointContour, insideIsLeft, innerContourPoint, firstPointPairOfContour, firstLineSegOfContour) @@ -1323,9 +1323,9 @@ prop_obtuseBisectorOnBiggerSide_makeENode x y d1 rawR1 d2 rawR2 testFirstLine | otherwise = pLineIsLeft pl2 bisector --> Just True where pl1 = eToPLine2 $ getFirstLineSeg eNode - pl2 = flipPLine2 $ eToPLine2 $ getLastLineSeg eNode + pl2 = flipL $ eToPLine2 $ getLastLineSeg eNode eNode = randomENode x y d1 rawR1 d2 rawR2 - bisector = flipPLine2 $ outOf eNode + bisector = flipL $ outOf eNode prop_obtuseBisectorOnBiggerSide_makeINode :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> Positive ℝ -> Radian ℝ -> Bool -> Bool -> Expectation prop_obtuseBisectorOnBiggerSide_makeINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 = (angleFound > realToFrac (1-angleErr), angleFound < realToFrac (-1 + angleErr :: Rounded 'TowardInf ℝ)) --> (True, False) @@ -1334,7 +1334,7 @@ prop_obtuseBisectorOnBiggerSide_makeINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 eNode = randomENode x y d1 rawR1 d2 rawR2 iNode = randomINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 bisector1 = normalizePLine2 $ outOf iNode - bisector2 = normalizePLine2 $ flipPLine2 $ outOf eNode + bisector2 = normalizePLine2 $ flipL $ outOf eNode prop_eNodeTowardIntersection1 :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> Positive ℝ -> Radian ℝ -> Expectation prop_eNodeTowardIntersection1 x y d1 rawR1 d2 rawR2 = l1TowardIntersection --> True From f542f39110d3cec4703de09d3caef17d4535487a Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 15 Oct 2022 11:48:15 +0000 Subject: [PATCH 011/206] somplify reverse and dual vector operations. --- Graphics/Slicer/Math/PGA.hs | 20 +++++++------------- 1 file changed, 7 insertions(+), 13 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 6c1cc8017..abe35b080 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -95,7 +95,7 @@ import Graphics.Slicer.Definitions (ℝ) import Graphics.Slicer.Math.Definitions (Point2(Point2), LineSeg(LineSeg), addPoints, scalePoint, startPoint, endPoint, distance) -import Graphics.Slicer.Math.GeometricAlgebra (ErrVal, GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎣+), (⎤+), (⨅), (⨅+), (∧), (•), addErr, addValWithoutErr, addVecPairWithErr, addVecPairWithoutErr, divVecScalarWithErr, eValOf, getVal, mulScalarVecWithErr, scalarPart, sumErrVals, ulpVal, valOf, vectorPart) +import Graphics.Slicer.Math.GeometricAlgebra (ErrVal, GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎣+), (⎤+), (⨅), (⨅+), (∧), (•), addErr, addValWithoutErr, addVecPairWithErr, addVecPairWithoutErr, divVecScalarWithErr, eValOf, getVal, mulScalarVecWithErr, scalarPart, sumErrVals, ulpVal, valOf) import Graphics.Slicer.Math.Line (combineLineSegs) @@ -821,9 +821,9 @@ pPointToPoint2 ppoint -- | Reverse a vector. Really, take every value in it, and recompute it in the reverse order of the vectors (so instead of e0∧e1, e1∧e0). which has the effect of negating bi and tri-vectors. reverseGVec :: GVec -> GVec -reverseGVec vec = GVec $ foldl' addValWithoutErr [] +reverseGVec (GVec vals) = GVec $ foldl' addValWithoutErr [] [ - GVal realVal (singleton G0) + GVal ( valOf 0 $ getVal [G0] vals) (singleton G0) , GVal ( valOf 0 $ getVal [GEZero 1] vals) (singleton (GEZero 1)) , GVal ( valOf 0 $ getVal [GEPlus 1] vals) (singleton (GEPlus 1)) , GVal ( valOf 0 $ getVal [GEPlus 2] vals) (singleton (GEPlus 2)) @@ -832,15 +832,12 @@ reverseGVec vec = GVec $ foldl' addValWithoutErr [] , GVal (negate $ valOf 0 $ getVal [GEPlus 1, GEPlus 2] vals) (fromList [GEPlus 1, GEPlus 2]) , GVal (negate $ valOf 0 $ getVal [GEZero 1, GEPlus 1, GEPlus 2] vals) (fromList [GEZero 1, GEPlus 1, GEPlus 2]) ] - where - realVal = scalarPart vec - (GVec vals) = vectorPart vec -- | get the dual of a vector. for a point, find a line, for a line, a point... dual2DGVec :: GVec -> GVec -dual2DGVec vec = GVec $ foldl' addValWithoutErr [] +dual2DGVec (GVec vals) = GVec $ foldl' addValWithoutErr [] [ - GVal realVal (fromList [GEZero 1, GEPlus 1, GEPlus 2]) + GVal ( valOf 0 $ getVal [G0] vals) (fromList [GEZero 1, GEPlus 1, GEPlus 2]) , GVal ( valOf 0 $ getVal [GEZero 1] vals) (fromList [GEPlus 1, GEPlus 2]) , GVal (negate $ valOf 0 $ getVal [GEPlus 1] vals) (fromList [GEZero 1, GEPlus 2]) , GVal ( valOf 0 $ getVal [GEPlus 2] vals) (fromList [GEZero 1, GEPlus 1]) @@ -849,9 +846,6 @@ dual2DGVec vec = GVec $ foldl' addValWithoutErr [] , GVal ( valOf 0 $ getVal [GEPlus 1, GEPlus 2] vals) (singleton (GEZero 1)) , GVal ( valOf 0 $ getVal [GEZero 1, GEPlus 1, GEPlus 2] vals) (singleton G0) ] - where - realVal = scalarPart vec - (GVec vals) = vectorPart vec -- | perform basis coersion. ensure all of the required '0' components exist. required before using basis sensitive raw operators. forceBasis :: [Set GNum] -> GVec -> GVec @@ -860,13 +854,13 @@ forceBasis numsets (GVec vals) = GVec $ forceVal vals <$> sort numsets forceVal :: [GVal] -> Set GNum -> GVal forceVal has needs = GVal (valOf 0 $ getVal (elems needs) has) needs --- | runtime basis coersion. ensure all of the '0' components exist on a PLine2. +-- | runtime basis coersion. ensure all of the '0' components exist on a Projective Line. forceProjectiveLine2Basis :: (ProjectiveLine2 a) => a -> a forceProjectiveLine2Basis line | gnums == Just [singleton (GEZero 1), singleton (GEPlus 1), singleton (GEPlus 2)] = line - | otherwise = (consLikeL line) res + | otherwise = (consLikeL line) res where res = forceBasis [singleton (GEZero 1), singleton (GEPlus 1), singleton (GEPlus 2)] pvec gnums = case vals of From 9374a6d749bba730206072a15c4e5c3df00c7147 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 15 Oct 2022 13:20:18 +0000 Subject: [PATCH 012/206] rename pPointToPoint2 to projectivePointToPoint2, and simplify. --- Graphics/Slicer/Math/PGA.hs | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index abe35b080..c5878b7b5 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -675,7 +675,7 @@ instance ProjectivePoint2 PPoint2 where consLikeP (PPoint2 _) = PPoint2 forceBasisOfP a = forceProjectivePointBasis a idealNormOfP a = idealNormPPoint2WithErr a - pToEP a = fromMaybe (error "created an infinite point when trying to convert from a Projective point to a euclidian one.") $ pPointToPoint2 a + pToEP a = fromMaybe (error "created an infinite point when trying to convert from a Projective point to a euclidian one.") $ projectivePointToPoint2 a vecOfP (PPoint2 a) = a instance ProjectivePoint2 CPPoint2 where @@ -683,7 +683,7 @@ instance ProjectivePoint2 CPPoint2 where consLikeP (CPPoint2 _) = CPPoint2 forceBasisOfP a = forceProjectivePointBasis a idealNormOfP a = idealNormPPoint2WithErr a - pToEP a = fromMaybe (error "created an infinite point when trying to convert from a Projective point to a euclidian one.") $ pPointToPoint2 a + pToEP a = fromMaybe (error "created an infinite point when trying to convert from a Projective point to a euclidian one.") $ projectivePointToPoint2 a vecOfP (CPPoint2 a) = a -- | A projective line in 2D space. @@ -807,13 +807,12 @@ makeCPPoint2WithErr x y = (pPoint -- | Maybe create a euclidian point from a projective point. -- FIXME: canonicalization certainly does... -pPointToPoint2 :: (ProjectivePoint2 a) => a -> Maybe (Point2, UlpSum) -pPointToPoint2 ppoint +projectivePointToPoint2 :: (ProjectivePoint2 a) => a -> Maybe (Point2, UlpSum) +projectivePointToPoint2 ppoint | e12Val == 0 = Nothing - | e12Val == 1 = Just (Point2 (xVal, yVal), cpErr) - | otherwise = Just (Point2 (xVal, yVal), cpErr) + | otherwise = Just (Point2 (xVal, yVal), cpErrs) where - (CPPoint2 (GVec vals), cpErr) = canonicalize ppoint + (CPPoint2 (GVec vals), cpErrs) = canonicalize ppoint xVal = negate $ valOf 0 $ getVal [GEZero 1, GEPlus 2] vals yVal = valOf 0 $ getVal [GEZero 1, GEPlus 1] vals e12Val = valOf 0 (getVal [GEPlus 1, GEPlus 2] rawVals) From f215e71f336ec843a5379af3c04b081bff6ac5c6 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 15 Oct 2022 13:38:34 +0000 Subject: [PATCH 013/206] remove PPoint2PosErr newtype. --- Graphics/Slicer/Math/PGA.hs | 28 ++++++++++++---------------- tests/Math/PGA.hs | 26 +++++++++++++------------- 2 files changed, 25 insertions(+), 29 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index c5878b7b5..918854834 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -32,7 +32,6 @@ module Graphics.Slicer.Math.PGA( PLine2(PLine2), Pointable(canPoint, pPointOf, ePointOf), PPoint2(PPoint2), - PPoint2PosErr(PPoint2PosErr), ProjectiveLine2, ProjectivePoint2, angleBetweenWithErr, @@ -442,8 +441,8 @@ pLineIntersectsLineSeg (pl1, UlpSum pl1Err) (l1, UlpSum l1Err) ulpScale where (startDistance, UlpSum startDistanceErr) = distanceBetweenPPointsWithErr rawIntersection start (endDistance, UlpSum endDistanceErr) = distanceBetweenPPointsWithErr rawIntersection end - (start, PPoint2PosErr startErr) = eToCPPoint2WithErr $ startPoint l1 - (end, PPoint2PosErr endErr) = eToCPPoint2WithErr $ endPoint l1 + (start, UlpSum startErr) = eToCPPoint2WithErr $ startPoint l1 + (end, UlpSum endErr) = eToCPPoint2WithErr $ endPoint l1 ulpStartSum, ulpEndSum :: ℝ ulpStartSum = realToFrac $ ulpTotal+startDistanceErr ulpEndSum = realToFrac $ ulpTotal+endDistanceErr @@ -488,10 +487,10 @@ lineSegIntersectsLineSeg (l1, UlpSum l1Err) (l2, UlpSum ulpL2) (start2Distance, UlpSum start2DistanceErr) = distanceBetweenPPointsWithErr rawIntersection start2 (end1Distance, UlpSum end1DistanceErr) = distanceBetweenPPointsWithErr rawIntersection end1 (end2Distance, UlpSum end2DistanceErr) = distanceBetweenPPointsWithErr rawIntersection end2 - (start1, PPoint2PosErr start1Err) = eToCPPoint2WithErr $ startPoint l1 - (end1, PPoint2PosErr end1Err) = eToCPPoint2WithErr $ endPoint l1 - (start2, PPoint2PosErr start2Err) = eToCPPoint2WithErr $ startPoint l2 - (end2, PPoint2PosErr end2Err) = eToCPPoint2WithErr $ endPoint l2 + (start1, UlpSum start1Err) = eToCPPoint2WithErr $ startPoint l1 + (end1, UlpSum end1Err) = eToCPPoint2WithErr $ endPoint l1 + (start2, UlpSum start2Err) = eToCPPoint2WithErr $ startPoint l2 + (end2, UlpSum end2Err) = eToCPPoint2WithErr $ endPoint l2 (pl1, UlpSum pl1Err) = eToPLine2WithErr l1 (pl2, UlpSum pl2Err) = eToPLine2WithErr l2 -- | the sum of all ULPs. used to expand the hitcircle of an endpoint. @@ -520,9 +519,9 @@ onSegment ls i startUlp endUlp = (startDistance, UlpSum startDistanceErr) = distanceBetweenPPointsWithErr start i (midDistance, UlpSum midDistanceErr) = distanceBetweenPPointsWithErr mid i (endDistance, UlpSum endDistanceErr) = distanceBetweenPPointsWithErr end i - (start, PPoint2PosErr startErr) = eToCPPoint2WithErr $ startPoint ls + (start, UlpSum startErr) = eToCPPoint2WithErr $ startPoint ls (mid, UlpSum midErr) = pPointBetweenPPointsWithErr start end 0.5 0.5 - (end, PPoint2PosErr endErr) = eToCPPoint2WithErr $ endPoint ls + (end, UlpSum endErr) = eToCPPoint2WithErr $ endPoint ls lengthOfSegment = distance (startPoint ls) (endPoint ls) startFudgeFactor, midFudgeFactor, endFudgeFactor :: ℝ startFudgeFactor = realToFrac $ realToFrac startUlp + startDistanceErr + startErr @@ -784,29 +783,26 @@ meet2PLine2WithErr line1 line2 = (PPoint2 res, (NPLine2 plr1,_) = normalize line1 (NPLine2 plr2,_) = normalize line2 -newtype PPoint2PosErr = PPoint2PosErr (Rounded 'TowardInf ℝ) - -eToPPoint2WithErr :: Point2 -> (PPoint2, PPoint2PosErr) +eToPPoint2WithErr :: Point2 -> (PPoint2, UlpSum) eToPPoint2WithErr (Point2 (x,y)) = (PPoint2 res, resUlp) where (CPPoint2 res, resUlp) = makeCPPoint2WithErr x y -eToCPPoint2WithErr :: Point2 -> (CPPoint2, PPoint2PosErr) +eToCPPoint2WithErr :: Point2 -> (CPPoint2, UlpSum) eToCPPoint2WithErr (Point2 (x,y)) = (res, resUlp) where (res, resUlp) = makeCPPoint2WithErr x y -- | Create a canonical euclidian projective point from the given coordinates, with error. -- FIXME: is there any chance of loss of precision on y? -makeCPPoint2WithErr :: ℝ -> ℝ -> (CPPoint2, PPoint2PosErr) +makeCPPoint2WithErr :: ℝ -> ℝ -> (CPPoint2, UlpSum) makeCPPoint2WithErr x y = (pPoint , posErr) where pPoint = CPPoint2 $ GVec $ foldl' addValWithoutErr [GVal 1 (fromList [GEPlus 1, GEPlus 2])] [ GVal (negate x) (fromList [GEZero 1, GEPlus 2]), GVal y (fromList [GEZero 1, GEPlus 1]) ] - posErr = PPoint2PosErr $ abs (realToFrac $ doubleUlp $ negate x) -- + abs (realToFrac $ doubleUlp y) + posErr = UlpSum $ abs (realToFrac $ doubleUlp $ negate x) -- + abs (realToFrac $ doubleUlp y) -- | Maybe create a euclidian point from a projective point. --- FIXME: canonicalization certainly does... projectivePointToPoint2 :: (ProjectivePoint2 a) => a -> Maybe (Point2, UlpSum) projectivePointToPoint2 ppoint | e12Val == 0 = Nothing diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index b87272c67..86edb1edb 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -59,7 +59,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(GEZero, GEPlu import Graphics.Slicer.Math.Lossy (angleBetween, canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenNPLine2s, distancePPointToPLine, eToCPPoint2, eToPLine2, eToPPoint2, getFirstArc, join2PPoint2, makeCPPoint2, makePPoint2, normalizePLine2, pPointOnPerp) -- Our 2D Projective Geometric Algebra library. -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PPoint2PosErr(PPoint2PosErr), canonicalize, pPointBetweenPPointsWithErr, distanceBetweenPPointsWithErr, distanceCPPointToNPLineWithErr, join2CPPoint2WithErr, pLineIntersectionWithErr, translatePLine2WithErr, translateRotatePPoint2, angleBetweenWithErr, flipL, makeCPPoint2WithErr, normalize, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, pLineFromEndpointsWithErr, distancePPointToPLineWithErr, pPointOnPerpWithErr, outOf, pPointOf, ulpOfOut, outputIntersectsLineSeg, pPointBetweenPPointsWithErr) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), canonicalize, pPointBetweenPPointsWithErr, distanceBetweenPPointsWithErr, distanceCPPointToNPLineWithErr, join2CPPoint2WithErr, pLineIntersectionWithErr, translatePLine2WithErr, translateRotatePPoint2, angleBetweenWithErr, flipL, makeCPPoint2WithErr, normalize, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, pLineFromEndpointsWithErr, distancePPointToPLineWithErr, pPointOnPerpWithErr, outOf, pPointOf, ulpOfOut, outputIntersectsLineSeg, pPointBetweenPPointsWithErr) -- Our Contour library. import Graphics.Slicer.Math.Contour (contourContainsContour, getContours, pointsOfContour, numPointsOfContour, justOneContourFrom, lineSegsOfContour, makeLineSegContour, makePointContour, insideIsLeft, innerContourPoint, firstPointPairOfContour, firstLineSegOfContour) @@ -405,8 +405,8 @@ prop_perpAt90Degrees x y rawX2 y2 rawD (bisectorEnd, UlpSum bisectorEndErr) = canonicalize bisectorEndRaw (pline3, UlpSum pline3Err) = join2CPPoint2WithErr (CPPoint2 rawBisectorStart) bisectorEnd (normedPLine3, UlpSum norm3Err) = normalize pline3 - (sourceStart, PPoint2PosErr sourceStartErr) = makeCPPoint2WithErr x y - (sourceEnd, PPoint2PosErr sourceEndErr) = makeCPPoint2WithErr x2 y2 + (sourceStart, UlpSum sourceStartErr) = makeCPPoint2WithErr x y + (sourceEnd, UlpSum sourceEndErr) = makeCPPoint2WithErr x2 y2 (pline4, UlpSum pline4Err) = join2CPPoint2WithErr sourceStart sourceEnd (normedPLine4, UlpSum norm4Err) = normalize pline4 errTotal3 = angle2Err + norm3Err + pline3Err + pline4Err + norm4Err + bisectorStartErr + bisectorEndRawErr + bisectorEndErr + sourceStartErr + sourceEndErr @@ -1191,8 +1191,8 @@ prop_PPointWithinErrRange x y | otherwise = (p1 /= p2) || (res == 0 || error "the same, but distance?") where (res, UlpSum resErr) = distanceBetweenPPointsWithErr p1 p2 - (p1, PPoint2PosErr p1Err) = makeCPPoint2WithErr x y - (p2, PPoint2PosErr p2Err) = makeCPPoint2WithErr (x + realToFrac p1Err) (y + realToFrac p1Err) + (p1, UlpSum p1Err) = makeCPPoint2WithErr x y + (p2, UlpSum p2Err) = makeCPPoint2WithErr (x + realToFrac p1Err) (y + realToFrac p1Err) prop_LineSegWithinErrRange :: ℝ -> ℝ -> ℝ -> ℝ -> Bool prop_LineSegWithinErrRange x1 y1 rawX2 rawY2 @@ -1233,8 +1233,8 @@ prop_PLineWithinErrRange1 x1 y1 rawX2 rawY2 -- distance1 and distance2 should be 0, in an ideal world. (distance1, UlpSum distance1Err) = distanceCPPointToNPLineWithErr pPoint1 nPLine (distance2, UlpSum distance2Err) = distanceCPPointToNPLineWithErr pPoint2 nPLine - (pPoint1, PPoint2PosErr ulpSumP1) = makeCPPoint2WithErr x1 y1 - (pPoint2, PPoint2PosErr ulpSumP2) = makeCPPoint2WithErr x2 y2 + (pPoint1, UlpSum ulpSumP1) = makeCPPoint2WithErr x1 y1 + (pPoint2, UlpSum ulpSumP2) = makeCPPoint2WithErr x2 y2 (nPLine, UlpSum nPLineErr) = normalize pLine (pLine, UlpSum ulpPLine) = pLineFromEndpointsWithErr (Point2 (x1,y1)) (Point2 (x2,y2)) ulpTotal1 = ulpSumP1 + ulpPLine + distance1Err + nPLineErr @@ -1269,8 +1269,8 @@ prop_PLineWithinErrRange2 x1 y1 rawX2 rawY2 -- distance1 and distance2 should be 0, in an ideal world. (distance1, UlpSum distance1Err) = distancePPointToPLineWithErr (PPoint2 pPoint1) pLine1 (distance2, UlpSum distance2Err) = distancePPointToPLineWithErr (PPoint2 pPoint2) pLine1 - (CPPoint2 pPoint1, PPoint2PosErr ulpSumP1) = makeCPPoint2WithErr x1 y1 - (CPPoint2 pPoint2, PPoint2PosErr ulpSumP2) = makeCPPoint2WithErr x2 y2 + (CPPoint2 pPoint1, UlpSum ulpSumP1) = makeCPPoint2WithErr x1 y1 + (CPPoint2 pPoint2, UlpSum ulpSumP2) = makeCPPoint2WithErr x2 y2 (pLine1, UlpSum ulpPLine) = join2CPPoint2WithErr (CPPoint2 pPoint1) (CPPoint2 pPoint2) (NPLine2 lvec, UlpSum normErr) = normalize pLine1 ulpTotal1 = ulpSumP1 + ulpPLine + distance1Err @@ -1303,8 +1303,8 @@ prop_PPointOnPerpWithinErrRange x1 y1 rawX2 rawY2 rawD (res2,UlpSum res2Err) = distancePPointToPLineWithErr perp2 pLine (perp1, UlpSum ulpSumPerp1) = pPointOnPerpWithErr pLine (PPoint2 pPoint1) d (perp2, UlpSum ulpSumPerp2) = pPointOnPerpWithErr pLine (PPoint2 pPoint2) d - (CPPoint2 pPoint1, PPoint2PosErr ulpSumP1) = makeCPPoint2WithErr x1 y1 - (CPPoint2 pPoint2, PPoint2PosErr ulpSumP2) = makeCPPoint2WithErr x2 y2 + (CPPoint2 pPoint1, UlpSum ulpSumP1) = makeCPPoint2WithErr x1 y1 + (CPPoint2 pPoint2, UlpSum ulpSumP2) = makeCPPoint2WithErr x2 y2 (pLine, UlpSum ulpPLine) = join2CPPoint2WithErr (CPPoint2 pPoint1) (CPPoint2 pPoint2) ulpTotal1 = ulpSumP1 + ulpPLine + res1Err + ulpSumPerp1 ulpTotal2 = ulpSumP2 + ulpPLine + res2Err + ulpSumPerp2 @@ -1374,7 +1374,7 @@ prop_PLinesIntersectAtOrigin rawX y rawX2 rawY2 | foundDistance < realToFrac errSum = True | otherwise = error "wtf" where - (originPPoint2, PPoint2PosErr originErr) = makeCPPoint2WithErr 0 0 + (originPPoint2, UlpSum originErr) = makeCPPoint2WithErr 0 0 (foundDistance, UlpSum distanceErr) = distanceBetweenPPointsWithErr originPPoint2 intersectionCPPoint2 (intersectionCPPoint2, UlpSum canonicalizationErr) = canonicalize intersectionPPoint2 (intersectionPPoint2, UlpSum intersectionErr) = pLineIntersectionWithErr randomPLine1 randomPLine2 @@ -1402,7 +1402,7 @@ prop_PLinesIntersectAtPoint rawX y rawX2 rawY2 targetX targetY <> show foundDistance <> "\n" <> show distanceErr <> "\n" where - (targetPPoint2, PPoint2PosErr targetErr) = makeCPPoint2WithErr (coerce targetX) (coerce targetY) + (targetPPoint2, UlpSum targetErr) = makeCPPoint2WithErr (coerce targetX) (coerce targetY) (foundDistance, UlpSum distanceErr) = distanceBetweenPPointsWithErr targetPPoint2 intersectionCPPoint2 (intersectionCPPoint2, UlpSum canonicalizationErr) = canonicalize intersectionPPoint2 (intersectionPPoint2, UlpSum intersectionErr) = pLineIntersectionWithErr randomPLine1 randomPLine2 From bce250a1b4b9936aec3095cf3a1da9d142a4ace0 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 15 Oct 2022 14:21:40 +0000 Subject: [PATCH 014/206] add meetOf2PL to the ProjectiveLine2 typeclass, and rename forecPLine2Basis to forceBasisOfL --- Graphics/Slicer/Math/PGA.hs | 35 +++++++++++++++++++---------------- 1 file changed, 19 insertions(+), 16 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 918854834..d414e503a 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -167,7 +167,7 @@ pLineIsLeft pl1 pl2 pLineIntersectionWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PPoint2, UlpSum) pLineIntersectionWithErr pl1 pl2 = (res, ulpTotal) where - (res, resErr) = meet2PLine2WithErr npl1 npl2 + (res, resErr) = meetOf2PL npl1 npl2 (npl1, npl1Err) = normalize pl1 (npl2, npl2Err) = normalize pl2 ulpTotal = resErr <> npl1Err <> npl2Err @@ -204,7 +204,7 @@ distanceCPPointToNPLineWithErr point line (res, _) = normOfPLine2WithErr newPLine (newPLine, newPLineErr) = join2CPPoint2WithErr point linePoint (perpLine, (plMulErr,plAddErr))= lvec ⨅+ npvec - (PLine2 lvec) = forcePLine2Basis (PLine2 nplvec) + (PLine2 lvec) = forceBasisOfL (PLine2 nplvec) (CPPoint2 npvec) = forceBasisOfP point (linePoint, lpErr) = fromJust $ canonicalizeIntersectionWithErr (PLine2 lvec) (PLine2 perpLine) ulpTotal = sumErrVals plMulErr <> sumErrVals plAddErr {- <> resErr -} <> newPLineErr <> lpErr @@ -227,7 +227,7 @@ pPointsOnSameSideOfPLine point1 point2 line (GVec unlikeP2, (unlikeP2MulErr, unlikeP2AddErr)) = pv2 ⎤+ lv1 (PPoint2 pv1) = forceBasisOfP point1 (PPoint2 pv2) = forceBasisOfP point2 - lv1 = vecOfL $ forcePLine2Basis line + lv1 = vecOfL $ forceBasisOfL line distanceBetweenPPointsWithErr :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> (ℝ, UlpSum) distanceBetweenPPointsWithErr point1 point2 = (res, ulpTotal) @@ -245,8 +245,8 @@ distanceBetweenNPLine2sWithErr line1 line2 = (ideal, resUlpSum) (ideal, idealUlpSum) = idealNormOfP $ PPoint2 likeRes resUlpSum = idealUlpSum <> sumErrVals likeMulErr <> sumErrVals likeAddErr (likeRes, (likeMulErr, likeAddErr)) = p1 ⎣+ p2 - p1 = vecOfL $ forcePLine2Basis npl1 - p2 = vecOfL $ forcePLine2Basis npl2 + p1 = vecOfL $ forceBasisOfL npl1 + p2 = vecOfL $ forceBasisOfL npl2 (npl1, _) = normalize line1 (npl2, _) = normalize line2 @@ -258,8 +258,8 @@ angleBetweenWithErr pl1 pl2 = (scalarPart likeRes where ulpSum = sumErrVals likeMulErr <> sumErrVals likeAddErr (likeRes, (likeMulErr, likeAddErr)) = p1 ⎣+ p2 - (PLine2 p1) = forcePLine2Basis $ PLine2 pv1 - (PLine2 p2) = forcePLine2Basis $ PLine2 pv2 + (PLine2 p1) = forceBasisOfL $ PLine2 pv1 + (PLine2 p2) = forceBasisOfL $ PLine2 pv2 (NPLine2 pv1, _) = normalize pl1 (NPLine2 pv2, _) = normalize pl2 @@ -291,7 +291,7 @@ pPointOnPerpWithErr line rppoint d = (PPoint2 res, res = motor•pvec•reverseGVec motor (NPLine2 rlvec, lErr) = normalize line (perpLine, (plMulErr,plAddErr))= lvec ⨅+ pvec - (PLine2 lvec) = forcePLine2Basis $ PLine2 rlvec + (PLine2 lvec) = forceBasisOfL $ PLine2 rlvec (PPoint2 pvec) = forceBasisOfP rppoint motor = addVecPairWithoutErr (perpLine • gaIScaled) (GVec [GVal 1 (singleton G0)]) -- I, in this geometric algebra system. we multiply it times d/2, to shorten the number of multiples we have to do when creating the motor. @@ -318,8 +318,8 @@ translateRotatePPoint2 ppoint d rotation = PPoint2 $ translator•pvec•reverse (PPoint2 pvec) = ppoint xLineThroughPPoint2 = (pvec ⨅ xLineVec) • pvec where - (PLine2 xLineVec) = forcePLine2Basis $ fst $ pLineFromEndpointsWithErr (Point2 (0,0)) (Point2 (1,0)) - (PLine2 angledLineThroughPPoint2) = forcePLine2Basis $ PLine2 $ rotator•xLineThroughPPoint2•reverseGVec rotator + (PLine2 xLineVec) = forceBasisOfL $ fst $ pLineFromEndpointsWithErr (Point2 (0,0)) (Point2 (1,0)) + (PLine2 angledLineThroughPPoint2) = forceBasisOfL $ PLine2 $ rotator•xLineThroughPPoint2•reverseGVec rotator where rotator = addVecPairWithoutErr (fst $ mulScalarVecWithErr (sin $ rotation/2) pvec) (GVec [GVal (cos $ rotation/2) (singleton G0)]) translator = addVecPairWithoutErr (angledLineThroughPPoint2 • gaIScaled) (GVec [GVal 1 (singleton G0)]) @@ -696,7 +696,8 @@ newtype NPLine2 = NPLine2 GVec class ProjectiveLine2 a where consLikeL :: a -> (GVec -> a) flipL :: a -> a - forcePLine2Basis :: a -> a + forceBasisOfL :: a -> a + meetOf2PL :: a -> a -> (PPoint2, UlpSum) normalize :: a -> (NPLine2, UlpSum) translatePLine2WithErr :: a -> ℝ -> (a, UlpSum) vecOfL :: a -> GVec @@ -704,7 +705,8 @@ class ProjectiveLine2 a where instance ProjectiveLine2 NPLine2 where consLikeL (NPLine2 _) = NPLine2 flipL a = flipProjectiveLine a - forcePLine2Basis a = forceProjectiveLine2Basis a + forceBasisOfL a = forceProjectiveLine2Basis a + meetOf2PL a b = meet2PLine2WithErr a b normalize a = (a, mempty) translatePLine2WithErr (NPLine2 a) d = (\(b,(PLine2Err _ _ _ _ t _)) -> (NPLine2 b,t)) $ translateProjectiveLine2WithErr a d vecOfL (NPLine2 a) = a @@ -712,7 +714,8 @@ instance ProjectiveLine2 NPLine2 where instance ProjectiveLine2 PLine2 where consLikeL (PLine2 _) = PLine2 flipL a = flipProjectiveLine a - forcePLine2Basis a = forceProjectiveLine2Basis a + forceBasisOfL a = forceProjectiveLine2Basis a + meetOf2PL a b = meet2PLine2WithErr a b normalize a = (\(b,(PLine2Err _ _ c d _ _)) -> (b,c <> d)) $ normalizePLine2WithErr a translatePLine2WithErr (PLine2 a) d = (\(b,(PLine2Err _ _ _ _ t _)) -> (PLine2 b,t)) $ translateProjectiveLine2WithErr a d vecOfL (PLine2 a) = a @@ -772,14 +775,14 @@ join2CPPoint2WithErr pp1 pp2 = (PLine2 res, (CPPoint2 pv2) = forceBasisOfP pp2 -- | A typed meet function. the meeting of two lines is a point. -meet2PLine2WithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PPoint2, UlpSum) +meet2PLine2WithErr :: (ProjectiveLine2 a) => a -> a -> (PPoint2, UlpSum) meet2PLine2WithErr line1 line2 = (PPoint2 res, ulpSum) where ulpSum = sumErrVals unlikeMulErr <> sumErrVals unlikeAddErr (res, (unlikeMulErr, unlikeAddErr)) = pv1 ⎤+ pv2 - (PLine2 pv1) = forcePLine2Basis $ PLine2 plr1 - (PLine2 pv2) = forcePLine2Basis $ PLine2 plr2 + (PLine2 pv1) = forceBasisOfL $ PLine2 plr1 + (PLine2 pv2) = forceBasisOfL $ PLine2 plr2 (NPLine2 plr1,_) = normalize line1 (NPLine2 plr2,_) = normalize line2 From b3016526ff2958bcb5248aa51c5c5123685ee2af Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 15 Oct 2022 17:12:54 +0000 Subject: [PATCH 015/206] remove eToCPPoint2WithErr, move from eToPPoint2WithErr to eToPPoint2, move from join2PPoint2WithErr to join2PP, and move from makeCPPoint2WithErr to makeCPPoint2. --- Graphics/Slicer/Math/Contour.hs | 4 +- Graphics/Slicer/Math/Ganja.hs | 6 +- Graphics/Slicer/Math/Lossy.hs | 24 ++--- Graphics/Slicer/Math/PGA.hs | 103 +++++++++---------- Graphics/Slicer/Math/Skeleton/Cells.hs | 6 +- Graphics/Slicer/Math/Skeleton/Concave.hs | 10 +- Graphics/Slicer/Math/Skeleton/Definitions.hs | 8 +- tests/Math/PGA.hs | 65 ++++++------ 8 files changed, 101 insertions(+), 125 deletions(-) diff --git a/Graphics/Slicer/Math/Contour.hs b/Graphics/Slicer/Math/Contour.hs index 2841211d6..5c3414869 100644 --- a/Graphics/Slicer/Math/Contour.hs +++ b/Graphics/Slicer/Math/Contour.hs @@ -50,9 +50,9 @@ import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum)) import Graphics.Slicer.Math.Intersections (contourIntersectionCount, noIntersection) -import Graphics.Slicer.Math.Lossy (eToPPoint2, join2PPoint2, pPointBetweenPPoints, pToEPoint2) +import Graphics.Slicer.Math.Lossy (join2PPoint2, pPointBetweenPPoints, pToEPoint2) -import Graphics.Slicer.Math.PGA (PPoint2, pLineFromEndpointsWithErr, pLineIsLeft, pPointOnPerpWithErr) +import Graphics.Slicer.Math.PGA (PPoint2, eToPPoint2, pLineFromEndpointsWithErr, pLineIsLeft, pPointOnPerpWithErr) -- Unapologetically ripped from ImplicitCAD. -- Added the ability to look at line segments backwards. diff --git a/Graphics/Slicer/Math/Ganja.hs b/Graphics/Slicer/Math/Ganja.hs index 53e4e2225..b11139d56 100644 --- a/Graphics/Slicer/Math/Ganja.hs +++ b/Graphics/Slicer/Math/Ganja.hs @@ -112,9 +112,9 @@ import Graphics.Slicer.Math.Definitions (Contour, Point2(Point2), LineSeg, endPo import Graphics.Slicer.Math.GeometricAlgebra (GNum(GEPlus, GEZero), GVec(GVec), getVal, valOf, UlpSum) -import Graphics.Slicer.Math.Lossy (eToPLine2, eToPPoint2, join2PPoint2, normalizePLine2, pPointBetweenPPoints, pToEPoint2) +import Graphics.Slicer.Math.Lossy (eToPLine2, join2PPoint2, normalizePLine2, pPointBetweenPPoints, pToEPoint2) -import Graphics.Slicer.Math.PGA (PPoint2(PPoint2), PLine2(PLine2), flipL, translateRotatePPoint2, pLineFromEndpointsWithErr, ulpOfLineSeg, outOf, pPointOf, NPLine2(NPLine2)) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), PLine2(PLine2), PPoint2(PPoint2), eToPPoint2, flipL, translateRotatePPoint2, pLineFromEndpointsWithErr, ulpOfLineSeg, outOf, pPointOf, NPLine2(NPLine2)) import Graphics.Slicer.Math.Skeleton.Concave (makeENode, getOutsideArc) @@ -634,7 +634,7 @@ randomStarPoly centerX centerY radianDistPairs = fromMaybe dumpError $ maybeFlip dumpError = error $ "failed to flip a contour:" <> dumpGanjas [toGanja contour, toGanja (Point2 (centerX, centerY)), toGanja outsidePLine] <> "\n" where outsidePLine = join2PPoint2 myMidPoint outsidePoint - outsidePoint = eToPPoint2 $ pointFarOutsideContour contour + outsidePoint = (\(CPPoint2 a) -> PPoint2 a) $ eToPPoint2 $ pointFarOutsideContour contour myMidPoint = pPointBetweenPPoints (eToPPoint2 p1) (eToPPoint2 p2) 0.5 0.5 (p1, p2) = firstPointPairOfContour contour diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index cbda27f19..fb9ec186e 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -28,7 +28,6 @@ module Graphics.Slicer.Math.Lossy ( eToCPPoint2, eToNPLine2, eToPLine2, - eToPPoint2, getFirstArc, getInsideArc, join2CPPoint2, @@ -50,7 +49,7 @@ import Graphics.Slicer.Definitions (ℝ) import Graphics.Slicer.Math.Definitions (LineSeg, Point2) -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2, PLine2, PPoint2(PPoint2), ProjectiveLine2, ProjectivePoint2, angleBetweenWithErr, canonicalize, distanceBetweenPPointsWithErr, distanceBetweenNPLine2sWithErr, distanceCPPointToNPLineWithErr, distancePPointToPLineWithErr, eToCPPoint2WithErr, eToPLine2WithErr, eToPPoint2WithErr, getFirstArcWithErr, getInsideArcWithErr, join2CPPoint2WithErr, join2PPoint2WithErr, makeCPPoint2WithErr, normalize, pLineFromEndpointsWithErr, pPointBetweenPPointsWithErr, pPointOnPerpWithErr, pToEP, translatePLine2WithErr) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2, PLine2, PPoint2(PPoint2), ProjectiveLine2, ProjectivePoint2, angleBetweenWithErr, canonicalize, distanceBetweenPPointsWithErr, distanceBetweenNPLine2sWithErr, distanceCPPointToNPLineWithErr, distancePPointToPLineWithErr, eToPLine2WithErr, eToPPoint2, getFirstArcWithErr, getInsideArcWithErr, join2CPPoint2WithErr, join2PP, makeCPPoint2, normalize, pLineFromEndpointsWithErr, pPointBetweenPPointsWithErr, pPointOnPerpWithErr, pToEP, translatePLine2WithErr) angleBetween :: NPLine2 -> NPLine2 -> ℝ angleBetween nPLine1 nPLine2 = fst $ angleBetweenWithErr nPLine1 nPLine2 @@ -70,12 +69,12 @@ distanceCPPointToNPLine :: CPPoint2 -> NPLine2 -> ℝ distanceCPPointToNPLine point line = fst $ distanceCPPointToNPLineWithErr point line -- | Find the unsigned distance between a point and a line. -distancePPointToPLine :: PPoint2 -> PLine2 -> ℝ +distancePPointToPLine :: (ProjectivePoint2 a) => a -> PLine2 -> ℝ distancePPointToPLine point line = fst $ distancePPointToPLineWithErr point line -- | Create a projective point from a euclidian point. eToCPPoint2 :: Point2 -> CPPoint2 -eToCPPoint2 point = fst $ eToCPPoint2WithErr point +eToCPPoint2 point = eToPPoint2 point -- | Create a normalized projective line from a euclidian line segment. eToNPLine2 :: LineSeg -> NPLine2 @@ -85,10 +84,6 @@ eToNPLine2 l1 = fst $ normalize $ fst $ eToPLine2WithErr l1 eToPLine2 :: LineSeg -> PLine2 eToPLine2 l1 = fst $ eToPLine2WithErr l1 --- | Create a projective point from a euclidian point. -eToPPoint2 :: Point2 -> PPoint2 -eToPPoint2 point = fst $ eToPPoint2WithErr point - -- | Get a PLine in the direction of the inside of the contour, at the angle bisector of the intersection of the line segment, and another segment from the end of the given line segment, toward the given point. getFirstArc :: Point2 -> Point2 -> Point2 -> PLine2 getFirstArc p1 p2 p3 = fst $ getFirstArcWithErr p1 p2 p3 @@ -97,22 +92,17 @@ getInsideArc :: PLine2 -> PLine2 -> PLine2 getInsideArc pl1 pl2 = fst $ getInsideArcWithErr pl1 pl2 -- | a typed join function. join two points, returning a line. -join2PPoint2 :: PPoint2 -> PPoint2 -> PLine2 -join2PPoint2 pp1 pp2 = fst $ join2PPoint2WithErr pp1 pp2 +join2PPoint2 :: (ProjectivePoint2 a) => a -> a -> PLine2 +join2PPoint2 pp1 pp2 = fst $ join2PP pp1 pp2 -- | a typed join function. join two points, returning a line. join2CPPoint2 :: CPPoint2 -> CPPoint2 -> PLine2 join2CPPoint2 pp1 pp2 = fst $ join2CPPoint2WithErr pp1 pp2 --- | create a canonical euclidian projective point from the given coordinates. --- Really, just wraps makeCPPoint2WithErr -makeCPPoint2 :: ℝ -> ℝ -> CPPoint2 -makeCPPoint2 x y = fst $ makeCPPoint2WithErr x y - -- | create a euclidian projective point from the given coordinates. --- Really, just wraps makeCPPoint2WithErr +-- Really, just wraps makeCPPoint2 makePPoint2 :: ℝ -> ℝ -> PPoint2 -makePPoint2 x y = (\(CPPoint2 p) -> PPoint2 p) $ fst $ makeCPPoint2WithErr x y +makePPoint2 x y = (\(CPPoint2 p) -> PPoint2 p) $ makeCPPoint2 x y -- | Normalize a PLine2. normalizePLine2 :: (ProjectiveLine2 a) => a -> NPLine2 diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index d414e503a..01a82195d 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -41,17 +41,16 @@ module Graphics.Slicer.Math.PGA( distanceBetweenNPLine2sWithErr, distanceCPPointToNPLineWithErr, distancePPointToPLineWithErr, - eToCPPoint2WithErr, eToPLine2WithErr, - eToPPoint2WithErr, + eToPPoint2, flipL, getInsideArcWithErr, getFirstArcWithErr, intersectsWith, intersectsWithErr, - join2PPoint2WithErr, + join2PP, join2CPPoint2WithErr, - makeCPPoint2WithErr, + makeCPPoint2, normalize, outputIntersectsLineSeg, pLineFromEndpointsWithErr, @@ -212,7 +211,7 @@ distanceCPPointToNPLineWithErr point line (NPLine2 nplvec,_) = normalize line -- | Determine if two points are on the same side of a given line. -pPointsOnSameSideOfPLine :: (ProjectiveLine2 c) => PPoint2 -> PPoint2 -> c -> Maybe Bool +pPointsOnSameSideOfPLine :: (ProjectivePoint2 a, ProjectivePoint2 b, ProjectiveLine2 c) => a -> b -> c -> Maybe Bool pPointsOnSameSideOfPLine point1 point2 line -- Return nothing if one of the points is on the line. | abs foundP1 < realToFrac (ulpVal unlikeP1UlpSum) || @@ -225,8 +224,8 @@ pPointsOnSameSideOfPLine point1 point2 line unlikeP2UlpSum = sumErrVals unlikeP2MulErr <> sumErrVals unlikeP2AddErr (GVec unlikeP1, (unlikeP1MulErr, unlikeP1AddErr)) = pv1 ⎤+ lv1 (GVec unlikeP2, (unlikeP2MulErr, unlikeP2AddErr)) = pv2 ⎤+ lv1 - (PPoint2 pv1) = forceBasisOfP point1 - (PPoint2 pv2) = forceBasisOfP point2 + pv1 = vecOfP $ forceBasisOfP point1 + pv2 = vecOfP $ forceBasisOfP point2 lv1 = vecOfL $ forceBasisOfL line distanceBetweenPPointsWithErr :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> (ℝ, UlpSum) @@ -312,10 +311,10 @@ translateProjectiveLine2WithErr lineVec d = (res, nErr <> PLine2Err resUlp mempt (n, nErr) = normOfPLine2WithErr (PLine2 lineVec) -- | Translate a point a given distance away from where it is, rotating it a given amount clockwise (in radians) around it's original location, with 0 degrees being aligned to the X axis. -translateRotatePPoint2 :: PPoint2 -> ℝ -> ℝ -> PPoint2 +translateRotatePPoint2 :: (ProjectivePoint2 a) => a -> ℝ -> ℝ -> PPoint2 translateRotatePPoint2 ppoint d rotation = PPoint2 $ translator•pvec•reverseGVec translator where - (PPoint2 pvec) = ppoint + pvec = vecOfP ppoint xLineThroughPPoint2 = (pvec ⨅ xLineVec) • pvec where (PLine2 xLineVec) = forceBasisOfL $ fst $ pLineFromEndpointsWithErr (Point2 (0,0)) (Point2 (1,0)) @@ -431,7 +430,7 @@ pLineIntersectsLineSeg (pl1, UlpSum pl1Err) (l1, UlpSum l1Err) ulpScale | plinesIntersectIn pl1 pl2 == PAntiParallel = Right PAntiParallel | plinesIntersectIn pl1 pl2 == PCollinear = Right PCollinear | plinesIntersectIn pl1 pl2 == PAntiCollinear = Right PAntiCollinear - | hasRawIntersection && distance (startPoint l1) (endPoint l1) < realToFrac (startErr + endErr + startDistanceErr+endDistanceErr+ulpTotal) = error $ "cannot resolve endpoints of segment: " <> show l1 <> ".\nulpTotal: " <> show ulpTotal <> "\nulpScale: " <> show ulpScale <> "\nrawIntersect" <> show rawIntersect <> dumpULPs + | hasRawIntersection && distance (startPoint l1) (endPoint l1) < realToFrac (startDistanceErr+endDistanceErr+ulpTotal) = error $ "cannot resolve endpoints of segment: " <> show l1 <> ".\nulpTotal: " <> show ulpTotal <> "\nulpScale: " <> show ulpScale <> "\nrawIntersect" <> show rawIntersect <> dumpULPs | hasIntersection && valOf 0 foundVal == 0 = error "intersection, but cannot cannonicalize." | hasIntersection && startDistance <= ulpStartSum = Left $ HitStartPoint l1 | hasIntersection && endDistance <= ulpEndSum = Left $ HitEndPoint l1 @@ -441,8 +440,8 @@ pLineIntersectsLineSeg (pl1, UlpSum pl1Err) (l1, UlpSum l1Err) ulpScale where (startDistance, UlpSum startDistanceErr) = distanceBetweenPPointsWithErr rawIntersection start (endDistance, UlpSum endDistanceErr) = distanceBetweenPPointsWithErr rawIntersection end - (start, UlpSum startErr) = eToCPPoint2WithErr $ startPoint l1 - (end, UlpSum endErr) = eToCPPoint2WithErr $ endPoint l1 + start = eToPPoint2 $ startPoint l1 + end = eToPPoint2 $ endPoint l1 ulpStartSum, ulpEndSum :: ℝ ulpStartSum = realToFrac $ ulpTotal+startDistanceErr ulpEndSum = realToFrac $ ulpTotal+endDistanceErr @@ -465,8 +464,8 @@ lineSegIntersectsLineSeg :: (LineSeg, UlpSum) -> (LineSeg, UlpSum) -> Either Int lineSegIntersectsLineSeg (l1, UlpSum l1Err) (l2, UlpSum ulpL2) | plinesIntersectIn pl1 pl2 == PParallel = Right PParallel | plinesIntersectIn pl1 pl2 == PAntiParallel = Right PAntiParallel - | hasRawIntersection && distance (startPoint l1) (endPoint l1) < realToFrac (start1Err + end1Err + start1DistanceErr+end1DistanceErr+ulpTotal) = error $ "cannot resolve endpoints of segment: " <> show l1 <> ".\nulpTotal: " <> show ulpTotal <> "\nrawIntersection" <> show rawIntersection <> dumpULPs - | hasRawIntersection && distance (startPoint l2) (endPoint l2) < realToFrac (start2Err + end2Err + start2DistanceErr+end2DistanceErr+ulpTotal) = error $ "cannot resolve endpoints of segment: " <> show l1 <> ".\nulpTotal: " <> show ulpTotal <> "\nrawIntersection" <> show rawIntersection <> dumpULPs + | hasRawIntersection && distance (startPoint l1) (endPoint l1) < realToFrac (start1DistanceErr+end1DistanceErr+ulpTotal) = error $ "cannot resolve endpoints of segment: " <> show l1 <> ".\nulpTotal: " <> show ulpTotal <> "\nrawIntersection" <> show rawIntersection <> dumpULPs + | hasRawIntersection && distance (startPoint l2) (endPoint l2) < realToFrac (start2DistanceErr+end2DistanceErr+ulpTotal) = error $ "cannot resolve endpoints of segment: " <> show l1 <> ".\nulpTotal: " <> show ulpTotal <> "\nrawIntersection" <> show rawIntersection <> dumpULPs | hasIntersection && plinesIntersectIn pl1 pl2 == PCollinear = Right PCollinear | hasIntersection && plinesIntersectIn pl1 pl2 == PAntiCollinear = Right PAntiCollinear -- FIXME: why do we return a start/endpoint here? @@ -481,16 +480,16 @@ lineSegIntersectsLineSeg (l1, UlpSum l1Err) (l2, UlpSum ulpL2) ulpStartSum1, ulpEndSum1, ulpStartSum2, ulpEndSum2 :: ℝ ulpStartSum1 = realToFrac $ ulpTotal+start1DistanceErr ulpStartSum2 = realToFrac $ ulpTotal+start2DistanceErr - ulpEndSum1 = realToFrac $ ulpTotal+end1Err - ulpEndSum2 = realToFrac $ ulpTotal+end2Err + ulpEndSum1 = realToFrac $ ulpTotal + ulpEndSum2 = realToFrac $ ulpTotal (start1Distance, UlpSum start1DistanceErr) = distanceBetweenPPointsWithErr rawIntersection start1 (start2Distance, UlpSum start2DistanceErr) = distanceBetweenPPointsWithErr rawIntersection start2 (end1Distance, UlpSum end1DistanceErr) = distanceBetweenPPointsWithErr rawIntersection end1 (end2Distance, UlpSum end2DistanceErr) = distanceBetweenPPointsWithErr rawIntersection end2 - (start1, UlpSum start1Err) = eToCPPoint2WithErr $ startPoint l1 - (end1, UlpSum end1Err) = eToCPPoint2WithErr $ endPoint l1 - (start2, UlpSum start2Err) = eToCPPoint2WithErr $ startPoint l2 - (end2, UlpSum end2Err) = eToCPPoint2WithErr $ endPoint l2 + start1 = eToPPoint2 $ startPoint l1 + end1 = eToPPoint2 $ endPoint l1 + start2 = eToPPoint2 $ startPoint l2 + end2 = eToPPoint2 $ endPoint l2 (pl1, UlpSum pl1Err) = eToPLine2WithErr l1 (pl2, UlpSum pl2Err) = eToPLine2WithErr l2 -- | the sum of all ULPs. used to expand the hitcircle of an endpoint. @@ -519,14 +518,14 @@ onSegment ls i startUlp endUlp = (startDistance, UlpSum startDistanceErr) = distanceBetweenPPointsWithErr start i (midDistance, UlpSum midDistanceErr) = distanceBetweenPPointsWithErr mid i (endDistance, UlpSum endDistanceErr) = distanceBetweenPPointsWithErr end i - (start, UlpSum startErr) = eToCPPoint2WithErr $ startPoint ls + start = eToPPoint2 $ startPoint ls (mid, UlpSum midErr) = pPointBetweenPPointsWithErr start end 0.5 0.5 - (end, UlpSum endErr) = eToCPPoint2WithErr $ endPoint ls + end = eToPPoint2 $ endPoint ls lengthOfSegment = distance (startPoint ls) (endPoint ls) startFudgeFactor, midFudgeFactor, endFudgeFactor :: ℝ - startFudgeFactor = realToFrac $ realToFrac startUlp + startDistanceErr + startErr + startFudgeFactor = realToFrac $ realToFrac startUlp + startDistanceErr midFudgeFactor = realToFrac $ abs (realToFrac $ doubleUlp lengthOfSegment) + midDistanceErr + midErr - endFudgeFactor = realToFrac $ realToFrac endUlp + endDistanceErr + endErr + endFudgeFactor = realToFrac $ realToFrac endUlp + endDistanceErr -- | Combine consecutive line segments. expects line segments with their end points connecting, EG, a contour generated by makeContours. combineConsecutiveLineSegs :: [LineSeg] -> [LineSeg] @@ -652,7 +651,6 @@ class Pointable a where canPoint :: a -> Bool pPointOf :: a -> PPoint2 ePointOf :: a -> Point2 --- ulpOfPoint :: a -> UlpSum -- | does this node have an output (resulting) pLine? class Arcable a where @@ -666,6 +664,7 @@ class ProjectivePoint2 a where consLikeP :: a -> (GVec -> a) forceBasisOfP :: a -> a idealNormOfP :: a -> (ℝ, UlpSum) + join2PP :: a -> a -> (PLine2, UlpSum) pToEP :: a -> (Point2, UlpSum) vecOfP :: a -> GVec @@ -674,6 +673,7 @@ instance ProjectivePoint2 PPoint2 where consLikeP (PPoint2 _) = PPoint2 forceBasisOfP a = forceProjectivePointBasis a idealNormOfP a = idealNormPPoint2WithErr a + join2PP a b = join2ProjectivePointsWithErr a b pToEP a = fromMaybe (error "created an infinite point when trying to convert from a Projective point to a euclidian one.") $ projectivePointToPoint2 a vecOfP (PPoint2 a) = a @@ -682,6 +682,7 @@ instance ProjectivePoint2 CPPoint2 where consLikeP (CPPoint2 _) = CPPoint2 forceBasisOfP a = forceProjectivePointBasis a idealNormOfP a = idealNormPPoint2WithErr a + join2PP a b = join2ProjectivePointsWithErr a b pToEP a = fromMaybe (error "created an infinite point when trying to convert from a Projective point to a euclidian one.") $ projectivePointToPoint2 a vecOfP (CPPoint2 a) = a @@ -705,8 +706,8 @@ class ProjectiveLine2 a where instance ProjectiveLine2 NPLine2 where consLikeL (NPLine2 _) = NPLine2 flipL a = flipProjectiveLine a - forceBasisOfL a = forceProjectiveLine2Basis a - meetOf2PL a b = meet2PLine2WithErr a b + forceBasisOfL a = forceProjectiveLineBasis a + meetOf2PL a b = meet2ProjectiveLinesWithErr a b normalize a = (a, mempty) translatePLine2WithErr (NPLine2 a) d = (\(b,(PLine2Err _ _ _ _ t _)) -> (NPLine2 b,t)) $ translateProjectiveLine2WithErr a d vecOfL (NPLine2 a) = a @@ -714,8 +715,8 @@ instance ProjectiveLine2 NPLine2 where instance ProjectiveLine2 PLine2 where consLikeL (PLine2 _) = PLine2 flipL a = flipProjectiveLine a - forceBasisOfL a = forceProjectiveLine2Basis a - meetOf2PL a b = meet2PLine2WithErr a b + forceBasisOfL a = forceProjectiveLineBasis a + meetOf2PL a b = meet2ProjectiveLinesWithErr a b normalize a = (\(b,(PLine2Err _ _ c d _ _)) -> (b,c <> d)) $ normalizePLine2WithErr a translatePLine2WithErr (PLine2 a) d = (\(b,(PLine2Err _ _ _ _ t _)) -> (PLine2 b,t)) $ translateProjectiveLine2WithErr a d vecOfL (PLine2 a) = a @@ -756,8 +757,8 @@ instance Semigroup PLine2Err where infixl 9 ∨+ -- | a typed join function. join two points, returning a line. -join2PPoint2WithErr :: PPoint2 -> PPoint2 -> (PLine2, UlpSum) -join2PPoint2WithErr pp1 pp2 = (res, +join2ProjectivePointsWithErr ::(ProjectivePoint2 a) => a -> a -> (PLine2, UlpSum) +join2ProjectivePointsWithErr pp1 pp2 = (res, errTotal) where (res, resErr) = join2CPPoint2WithErr cp1 cp2 @@ -775,37 +776,30 @@ join2CPPoint2WithErr pp1 pp2 = (PLine2 res, (CPPoint2 pv2) = forceBasisOfP pp2 -- | A typed meet function. the meeting of two lines is a point. -meet2PLine2WithErr :: (ProjectiveLine2 a) => a -> a -> (PPoint2, UlpSum) -meet2PLine2WithErr line1 line2 = (PPoint2 res, +meet2ProjectiveLinesWithErr :: (ProjectiveLine2 a) => a -> a -> (PPoint2, UlpSum) +meet2ProjectiveLinesWithErr line1 line2 = (PPoint2 res, ulpSum) where ulpSum = sumErrVals unlikeMulErr <> sumErrVals unlikeAddErr (res, (unlikeMulErr, unlikeAddErr)) = pv1 ⎤+ pv2 - (PLine2 pv1) = forceBasisOfL $ PLine2 plr1 - (PLine2 pv2) = forceBasisOfL $ PLine2 plr2 - (NPLine2 plr1,_) = normalize line1 - (NPLine2 plr2,_) = normalize line2 + (NPLine2 pv1) = forceBasisOfL npl1 + (NPLine2 pv2) = forceBasisOfL npl2 + (npl1,_) = normalize line1 + (npl2,_) = normalize line2 -eToPPoint2WithErr :: Point2 -> (PPoint2, UlpSum) -eToPPoint2WithErr (Point2 (x,y)) = (PPoint2 res, resUlp) +eToPPoint2 :: Point2 -> CPPoint2 +eToPPoint2 (Point2 (x,y)) = res where - (CPPoint2 res, resUlp) = makeCPPoint2WithErr x y - -eToCPPoint2WithErr :: Point2 -> (CPPoint2, UlpSum) -eToCPPoint2WithErr (Point2 (x,y)) = (res, resUlp) - where - (res, resUlp) = makeCPPoint2WithErr x y + res = makeCPPoint2 x y -- | Create a canonical euclidian projective point from the given coordinates, with error. -- FIXME: is there any chance of loss of precision on y? -makeCPPoint2WithErr :: ℝ -> ℝ -> (CPPoint2, UlpSum) -makeCPPoint2WithErr x y = (pPoint - , posErr) +makeCPPoint2 :: ℝ -> ℝ -> CPPoint2 +makeCPPoint2 x y = pPoint where - pPoint = CPPoint2 $ GVec $ foldl' addValWithoutErr [GVal 1 (fromList [GEPlus 1, GEPlus 2])] [ GVal (negate x) (fromList [GEZero 1, GEPlus 2]), GVal y (fromList [GEZero 1, GEPlus 1]) ] - posErr = UlpSum $ abs (realToFrac $ doubleUlp $ negate x) -- + abs (realToFrac $ doubleUlp y) + pPoint = CPPoint2 $ GVec $ foldl' addValWithoutErr [GVal 1 (fromList [GEPlus 1, GEPlus 2])] [ GVal (negate x) (fromList [GEZero 1, GEPlus 2]), GVal y (fromList [GEZero 1, GEPlus 1])] --- | Maybe create a euclidian point from a projective point. +-- | Maybe create a euclidian point from a projective point. Will fail if the projective point is ideal. projectivePointToPoint2 :: (ProjectivePoint2 a) => a -> Maybe (Point2, UlpSum) projectivePointToPoint2 ppoint | e12Val == 0 = Nothing @@ -853,8 +847,8 @@ forceBasis numsets (GVec vals) = GVec $ forceVal vals <$> sort numsets forceVal has needs = GVal (valOf 0 $ getVal (elems needs) has) needs -- | runtime basis coersion. ensure all of the '0' components exist on a Projective Line. -forceProjectiveLine2Basis :: (ProjectiveLine2 a) => a -> a -forceProjectiveLine2Basis line +forceProjectiveLineBasis :: (ProjectiveLine2 a) => a -> a +forceProjectiveLineBasis line | gnums == Just [singleton (GEZero 1), singleton (GEPlus 1), singleton (GEPlus 2)] = line @@ -895,11 +889,10 @@ flipProjectiveLine pline = (consLikeL pline) rawRes eToPLine2WithErr :: LineSeg -> (PLine2, UlpSum) eToPLine2WithErr l1 = pLineFromEndpointsWithErr (startPoint l1) (endPoint l1) - pLineFromEndpointsWithErr :: Point2 -> Point2 -> (PLine2, UlpSum) pLineFromEndpointsWithErr start stop = (res, resErr) where - (res, resErr) = join2PPoint2WithErr (fst $ eToPPoint2WithErr start) (fst $ eToPPoint2WithErr stop) + (res, resErr) = join2PP (eToPPoint2 start) (eToPPoint2 stop) -- | Get the sum of the error involved in storing the values in a given PLine2. ulpOfPLine2 :: (ProjectiveLine2 a) => a -> UlpSum diff --git a/Graphics/Slicer/Math/Skeleton/Cells.hs b/Graphics/Slicer/Math/Skeleton/Cells.hs index 8006eed42..c2df6f8bd 100644 --- a/Graphics/Slicer/Math/Skeleton/Cells.hs +++ b/Graphics/Slicer/Math/Skeleton/Cells.hs @@ -56,9 +56,9 @@ import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum)) import Graphics.Slicer.Math.Intersections (intersectionOf) -import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, eToCPPoint2, eToNPLine2, eToPLine2, eToPPoint2, join2PPoint2, normalizePLine2, pToEPoint2) +import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, eToCPPoint2, eToNPLine2, eToPLine2, join2PPoint2, normalizePLine2, pToEPoint2) -import Graphics.Slicer.Math.PGA (Arcable(outOf), Pointable(canPoint, ePointOf, pPointOf), CPPoint2, PIntersection(PAntiCollinear, IntersectsIn), angleBetweenWithErr, distanceBetweenPPointsWithErr, plinesIntersectIn) +import Graphics.Slicer.Math.PGA (Arcable(outOf), CPPoint2(CPPoint2), Pointable(canPoint, ePointOf, pPointOf), PIntersection(PAntiCollinear, IntersectsIn), PPoint2(PPoint2), angleBetweenWithErr, distanceBetweenPPointsWithErr, eToPPoint2, plinesIntersectIn) data UnsupportedReason = INodeCrossesDivide ![(INode,CellDivide)] !NodeTree deriving (Show, Eq) @@ -415,7 +415,7 @@ crossoverINodes nodeTree@(NodeTree _ (INodeSet (Slist iNodes _))) cellDivision = where nodeCrosses :: INode -> Bool nodeCrosses a = Just False `elem` (intersectionSameSide pointOnSide a <$> motorcyclesInDivision cellDivision) - pointOnSide = eToPPoint2 $ pointInCell nodeTree cellDivision + pointOnSide = (\(CPPoint2 a) -> PPoint2 a) $ eToPPoint2 $ pointInCell nodeTree cellDivision pointInCell cell (CellDivide (DividingMotorcycles m _) _) | firstSegOf cell == lastCSegOf m = endPoint $ firstSegOf cell | lastSegOf cell == firstCSegOf m = startPoint $ lastSegOf cell diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index 4f3aa28b2..2a2c04f5d 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -60,7 +60,7 @@ import Graphics.Slicer.Math.Intersections (intersectionOf, intersectionBetween, import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, distancePPointToPLine, eToPLine2, getInsideArc, join2CPPoint2, normalizePLine2) -import Graphics.Slicer.Math.PGA (Arcable(hasArc, outOf), Pointable(canPoint, pPointOf), PLine2(PLine2), CPPoint2(CPPoint2), PPoint2(PPoint2), flipL, getFirstArcWithErr, distanceBetweenPPointsWithErr, pLineIsLeft, angleBetweenWithErr, distancePPointToPLineWithErr, NPLine2(NPLine2)) +import Graphics.Slicer.Math.PGA (Arcable(hasArc, outOf), Pointable(canPoint, pPointOf), PLine2(PLine2), ProjectivePoint2, CPPoint2(CPPoint2), PPoint2(PPoint2), canonicalize, flipL, getFirstArcWithErr, distanceBetweenPPointsWithErr, pLineIsLeft, angleBetweenWithErr, distancePPointToPLineWithErr, NPLine2(NPLine2)) import Graphics.Slicer.Math.Skeleton.Definitions (ENode(ENode), ENodeSet(ENodeSet), INode(INode), INodeSet(INodeSet), NodeTree(NodeTree), concavePLines, getFirstLineSeg, getLastLineSeg, finalOutOf, firstInOf, getPairs, indexPLinesTo, insOf, lastINodeOf, linePairs, makeINode, sortedPLines, isLoop) @@ -194,7 +194,7 @@ sortedPair n1 n2 = sortedPLines [outOf n1, outOf n2] -- Note: we normalize our output lines. -- FIXME: the outer PLine returned by two PLines in the same direction should be two PLines, whch are the same line in both directions. -- FIXME: should return amount of error. -getOutsideArc :: PPoint2 -> NPLine2 -> PPoint2 -> NPLine2 -> PLine2 +getOutsideArc :: (ProjectivePoint2 a, Show a) => a -> NPLine2 -> a -> NPLine2 -> PLine2 getOutsideArc ppoint1 npline1 ppoint2 npline2 | npline1 == npline2 = error "need to be able to return two PLines." | noIntersection pline1 pline2 = error $ "no intersection between pline " <> show pline1 <> " and " <> show pline2 <> ".\n" @@ -212,14 +212,14 @@ getOutsideArc ppoint1 npline1 ppoint2 npline2 -- Determine if the line segment formed by the two given points starts with the first point, or the second. -- Note that due to numeric uncertainty, we cannot rely on Eq here, and must check the sign of the angle. -- FIXME: shouldn't we be given an error component in our inputs? -towardIntersection :: PPoint2 -> PLine2 -> CPPoint2 -> Bool +towardIntersection :: (ProjectivePoint2 a, Show a) => a -> PLine2 -> CPPoint2 -> Bool towardIntersection pp1 pl1 pp2 | d <= realToFrac dErr = error $ "cannot resolve points finely enough.\nPPoint1: " <> show pp1 <> "\nPPoint2: " <> show pp2 <> "\nPLineIn: " <> show pl1 <> "\nnewPLine: " <> show newPLine <> "\n" | otherwise = angleFound > realToFrac angleErr where (angleFound, UlpSum angleErr) = angleBetweenWithErr newPLine (normalizePLine2 pl1) - (d, UlpSum dErr) = distanceBetweenPPointsWithErr (canonicalizePPoint2 pp1) pp2 - newPLine = normalizePLine2 $ join2CPPoint2 (canonicalizePPoint2 pp1) pp2 + (d, UlpSum dErr) = distanceBetweenPPointsWithErr (fst $ canonicalize pp1) pp2 + newPLine = normalizePLine2 $ join2CPPoint2 (fst $ canonicalize pp1) pp2 -- | Make a first generation node. makeENode :: Point2 -> Point2 -> Point2 -> ENode diff --git a/Graphics/Slicer/Math/Skeleton/Definitions.hs b/Graphics/Slicer/Math/Skeleton/Definitions.hs index 3f762107c..6b55c60cc 100644 --- a/Graphics/Slicer/Math/Skeleton/Definitions.hs +++ b/Graphics/Slicer/Math/Skeleton/Definitions.hs @@ -53,9 +53,9 @@ import Slist.Type (Slist(Slist)) import Graphics.Implicit.Definitions (ℝ) -import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, eToPLine2, eToPPoint2, pToEPoint2) +import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, eToPLine2, pToEPoint2) -import Graphics.Slicer.Math.PGA (plinesIntersectIn, PIntersection(IntersectsIn), flipL, PLine2(PLine2), pLineIsLeft, distanceBetweenPPointsWithErr, Pointable(canPoint, pPointOf, ePointOf), Arcable(hasArc, outOf, ulpOfOut, outUlpMag), CPPoint2(CPPoint2), PPoint2(PPoint2)) +import Graphics.Slicer.Math.PGA (plinesIntersectIn, PIntersection(IntersectsIn), flipL, PLine2(PLine2), pLineIsLeft, distanceBetweenPPointsWithErr, Pointable(canPoint, pPointOf, ePointOf), Arcable(hasArc, outOf, ulpOfOut, outUlpMag), CPPoint2(CPPoint2), PPoint2(PPoint2), eToPPoint2) import Graphics.Slicer.Math.Definitions (Contour, LineSeg(LineSeg), Point2, mapWithFollower, fudgeFactor, startPoint, distance, endPoint, lineSegsOfContour, makeLineSeg) @@ -78,7 +78,7 @@ instance Arcable ENode where instance Pointable ENode where -- an ENode always contains a point. canPoint _ = True - pPointOf a = eToPPoint2 $ ePointOf a + pPointOf a = (\(CPPoint2 v) -> PPoint2 v) $ eToPPoint2 $ ePointOf a ePointOf (ENode (_,centerPoint,_) _ _ _) = centerPoint -- | A point in our straight skeleton where two arcs intersect, resulting in the creation of another arc. @@ -162,7 +162,7 @@ instance Arcable Motorcycle where instance Pointable Motorcycle where -- A motorcycle always contains a point. canPoint _ = True - pPointOf a = eToPPoint2 $ ePointOf a + pPointOf a = (\(CPPoint2 v) -> PPoint2 v) $ eToPPoint2 $ ePointOf a ePointOf (Motorcycle (_, LineSeg point _) _ _ _) = point -- | The motorcycles that are involved in dividing two cells. diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index 86edb1edb..ca6061f99 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -56,10 +56,10 @@ import Graphics.Slicer.Math.Definitions(Point2(Point2), Contour(LineSegContour), -- Our Geometric Algebra library. import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(GEZero, GEPlus, G0), GVal(GVal), GVec(GVec), UlpSum(UlpSum), addValPairWithErr, subValPairWithErr, addValWithErr, subVal, addVecPair, subVecPair, mulScalarVecWithErr, divVecScalarWithErr, scalarPart, vectorPart, (•), (∧), (⋅), (⎣), (⎤)) -import Graphics.Slicer.Math.Lossy (angleBetween, canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenNPLine2s, distancePPointToPLine, eToCPPoint2, eToPLine2, eToPPoint2, getFirstArc, join2PPoint2, makeCPPoint2, makePPoint2, normalizePLine2, pPointOnPerp) +import Graphics.Slicer.Math.Lossy (angleBetween, canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenNPLine2s, distancePPointToPLine, eToCPPoint2, eToPLine2, getFirstArc, join2PPoint2, makePPoint2, normalizePLine2, pPointOnPerp) -- Our 2D Projective Geometric Algebra library. -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), canonicalize, pPointBetweenPPointsWithErr, distanceBetweenPPointsWithErr, distanceCPPointToNPLineWithErr, join2CPPoint2WithErr, pLineIntersectionWithErr, translatePLine2WithErr, translateRotatePPoint2, angleBetweenWithErr, flipL, makeCPPoint2WithErr, normalize, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, pLineFromEndpointsWithErr, distancePPointToPLineWithErr, pPointOnPerpWithErr, outOf, pPointOf, ulpOfOut, outputIntersectsLineSeg, pPointBetweenPPointsWithErr) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), canonicalize, pPointBetweenPPointsWithErr, distanceBetweenPPointsWithErr, distanceCPPointToNPLineWithErr, eToPPoint2, join2CPPoint2WithErr, pLineIntersectionWithErr, translatePLine2WithErr, translateRotatePPoint2, angleBetweenWithErr, flipL, makeCPPoint2, normalize, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, pLineFromEndpointsWithErr, distancePPointToPLineWithErr, pPointOnPerpWithErr, outOf, pPointOf, ulpOfOut, outputIntersectsLineSeg, pPointBetweenPPointsWithErr) -- Our Contour library. import Graphics.Slicer.Math.Contour (contourContainsContour, getContours, pointsOfContour, numPointsOfContour, justOneContourFrom, lineSegsOfContour, makeLineSegContour, makePointContour, insideIsLeft, innerContourPoint, firstPointPairOfContour, firstLineSegOfContour) @@ -328,7 +328,7 @@ geomAlgSpec = do prop_ScalarDotScalar :: ℝ -> ℝ -> ℝ -> ℝ -> Bool prop_ScalarDotScalar v1 v2 v3 v4 = scalarPart (rawPPoint2 (v1,v2) ⋅ rawPPoint2 (v3,v4)) == (-1) where - rawPPoint2 (x,y) = (\(PPoint2 v) -> v) $ eToPPoint2 (Point2 (x,y)) + rawPPoint2 (x,y) = (\(CPPoint2 v) -> v) $ eToPPoint2 (Point2 (x,y)) -- | A property test making sure that the wedge product of two PLines along two different axises is always in e1e2. prop_TwoAxisAlignedLines :: NonZero ℝ -> NonZero ℝ -> NonZero ℝ -> NonZero ℝ -> Expectation @@ -405,12 +405,12 @@ prop_perpAt90Degrees x y rawX2 y2 rawD (bisectorEnd, UlpSum bisectorEndErr) = canonicalize bisectorEndRaw (pline3, UlpSum pline3Err) = join2CPPoint2WithErr (CPPoint2 rawBisectorStart) bisectorEnd (normedPLine3, UlpSum norm3Err) = normalize pline3 - (sourceStart, UlpSum sourceStartErr) = makeCPPoint2WithErr x y - (sourceEnd, UlpSum sourceEndErr) = makeCPPoint2WithErr x2 y2 + sourceStart = makeCPPoint2 x y + sourceEnd = makeCPPoint2 x2 y2 (pline4, UlpSum pline4Err) = join2CPPoint2WithErr sourceStart sourceEnd (normedPLine4, UlpSum norm4Err) = normalize pline4 - errTotal3 = angle2Err + norm3Err + pline3Err + pline4Err + norm4Err + bisectorStartErr + bisectorEndRawErr + bisectorEndErr + sourceStartErr + sourceEndErr - errTotal4 = angle2Err + norm3Err + pline3Err + pline4Err + norm4Err + bisectorStartErr + bisectorEndRawErr + bisectorEndErr + sourceStartErr + sourceEndErr + errTotal3 = angle2Err + norm3Err + pline3Err + pline4Err + norm4Err + bisectorStartErr + bisectorEndRawErr + bisectorEndErr + errTotal4 = angle2Err + norm3Err + pline3Err + pline4Err + norm4Err + bisectorStartErr + bisectorEndRawErr + bisectorEndErr x2 :: ℝ x2 = coerce rawX2 d :: ℝ @@ -927,7 +927,7 @@ prop_TriangleNoDivides centerX centerY rawRadians rawDists = findDivisions trian (myMidPoint,_) = pPointBetweenPPointsWithErr (eToPPoint2 p1) (eToPPoint2 p2) 0.5 0.5 -- we normalize this for Ganja.js. (NPLine2 pLineToInside) = normalizePLine2 $ join2PPoint2 myMidPoint innerPoint - (NPLine2 pLineToOutside) = normalizePLine2 $ join2PPoint2 innerPoint $ eToPPoint2 outsidePoint + (NPLine2 pLineToOutside) = normalizePLine2 $ join2PPoint2 innerPoint $ (\(CPPoint2 a) -> PPoint2 a) $ eToPPoint2 outsidePoint innerPoint = fromMaybe (dumpError2) maybeInnerPoint minPoint = fst $ minMaxPoints triangle outsidePoint = Point2 (xOf minPoint - 0.00000001 , yOf minPoint - 0.00000001) @@ -1187,12 +1187,12 @@ prop_ConcaveChevronQuadFacesInOrder a b c d e f = doTest $ randomConcaveChevronQ -- make sure that the measured distance between two points that have been placed as close as possible is less than the amount of error placing both points added to the amount of error of doing a measurement of distance. prop_PPointWithinErrRange :: ℝ -> ℝ -> Bool prop_PPointWithinErrRange x y - | res > realToFrac (p1Err + p2Err + resErr) = error $ "res too big: " <> show res <> "\nulpSum1: " <> show p1Err <> "\nulpSum2: " <> show p2Err <> "\n" + | res > realToFrac (resErr) = error $ "res too big: " <> show res | otherwise = (p1 /= p2) || (res == 0 || error "the same, but distance?") where (res, UlpSum resErr) = distanceBetweenPPointsWithErr p1 p2 - (p1, UlpSum p1Err) = makeCPPoint2WithErr x y - (p2, UlpSum p2Err) = makeCPPoint2WithErr (x + realToFrac p1Err) (y + realToFrac p1Err) + p1 = makeCPPoint2 x y + p2 = makeCPPoint2 x y prop_LineSegWithinErrRange :: ℝ -> ℝ -> ℝ -> ℝ -> Bool prop_LineSegWithinErrRange x1 y1 rawX2 rawY2 @@ -1223,8 +1223,6 @@ prop_PLineWithinErrRange1 x1 y1 rawX2 rawY2 <> "ulpTotal2: " <> show ulpTotal2 <> "\n" <> "distance1Err: " <> show distance1Err <> "\n" <> "distance2Err: " <> show distance2Err <> "\n" - <> "PPoint1ULP: " <> show ulpSumP1 <> "\n" - <> "PPoint2ULP: " <> show ulpSumP2 <> "\n" <> "PLine1ULP: " <> show ulpPLine <> "\n" <> "PLine: " <> show pLine <> "\n" <> "NPLine: " <> show nPLine <> "\n" @@ -1233,12 +1231,12 @@ prop_PLineWithinErrRange1 x1 y1 rawX2 rawY2 -- distance1 and distance2 should be 0, in an ideal world. (distance1, UlpSum distance1Err) = distanceCPPointToNPLineWithErr pPoint1 nPLine (distance2, UlpSum distance2Err) = distanceCPPointToNPLineWithErr pPoint2 nPLine - (pPoint1, UlpSum ulpSumP1) = makeCPPoint2WithErr x1 y1 - (pPoint2, UlpSum ulpSumP2) = makeCPPoint2WithErr x2 y2 + pPoint1 = makeCPPoint2 x1 y1 + pPoint2 = makeCPPoint2 x2 y2 (nPLine, UlpSum nPLineErr) = normalize pLine (pLine, UlpSum ulpPLine) = pLineFromEndpointsWithErr (Point2 (x1,y1)) (Point2 (x2,y2)) - ulpTotal1 = ulpSumP1 + ulpPLine + distance1Err + nPLineErr - ulpTotal2 = ulpSumP2 + ulpPLine + distance2Err + nPLineErr + ulpTotal1 = ulpPLine + distance1Err + nPLineErr + ulpTotal2 = ulpPLine + distance2Err + nPLineErr -- make sure we do not try to create a 0 length line segment. (x2,y2) | x1 == rawX2 && y1 == rawY2 = if x1 == 0 && y1 == 0 @@ -1258,8 +1256,6 @@ prop_PLineWithinErrRange2 x1 y1 rawX2 rawY2 <> "ulpTotal2: " <> show ulpTotal2 <> "\n" <> "distance1Err: " <> show distance1Err <> "\n" <> "distance2Err: " <> show distance2Err <> "\n" - <> "PPoint1ULP: " <> show ulpSumP1 <> "\n" - <> "PPoint2ULP: " <> show ulpSumP2 <> "\n" <> "PLine1ULP: " <> show ulpPLine <> "\n" <> "PLine1NormULP: " <> show normErr <> "\n" <> "PLine1: " <> show pLine1 <> "\n" @@ -1269,12 +1265,12 @@ prop_PLineWithinErrRange2 x1 y1 rawX2 rawY2 -- distance1 and distance2 should be 0, in an ideal world. (distance1, UlpSum distance1Err) = distancePPointToPLineWithErr (PPoint2 pPoint1) pLine1 (distance2, UlpSum distance2Err) = distancePPointToPLineWithErr (PPoint2 pPoint2) pLine1 - (CPPoint2 pPoint1, UlpSum ulpSumP1) = makeCPPoint2WithErr x1 y1 - (CPPoint2 pPoint2, UlpSum ulpSumP2) = makeCPPoint2WithErr x2 y2 + (CPPoint2 pPoint1) = makeCPPoint2 x1 y1 + (CPPoint2 pPoint2) = makeCPPoint2 x2 y2 (pLine1, UlpSum ulpPLine) = join2CPPoint2WithErr (CPPoint2 pPoint1) (CPPoint2 pPoint2) (NPLine2 lvec, UlpSum normErr) = normalize pLine1 - ulpTotal1 = ulpSumP1 + ulpPLine + distance1Err - ulpTotal2 = ulpSumP2 + ulpPLine + distance2Err + ulpTotal1 = ulpPLine + distance1Err + ulpTotal2 = ulpPLine + distance2Err -- make sure we do not try to create a 0 length line segment. (x2,y2) | x1 == rawX2 && y1 == rawY2 = if x1 == 0 && y1 == 0 @@ -1294,8 +1290,6 @@ prop_PPointOnPerpWithinErrRange x1 y1 rawX2 rawY2 rawD <> "distance2: " <> show res2 <> "\n" <> "PLine: " <> show pLine <> "\n" <> "PLineULP: " <> show ulpPLine <> "\n" - <> "PPoint1ULP: " <> show ulpSumP1 <> "\n" - <> "PPoint2ULP: " <> show ulpSumP2 <> "\n" <> "ulpTotal1: " <> show ulpTotal1 <> "\n" <> "ulpTotal2: " <> show ulpTotal2 <> "\n" -- res should be d, in an ideal world. @@ -1303,11 +1297,11 @@ prop_PPointOnPerpWithinErrRange x1 y1 rawX2 rawY2 rawD (res2,UlpSum res2Err) = distancePPointToPLineWithErr perp2 pLine (perp1, UlpSum ulpSumPerp1) = pPointOnPerpWithErr pLine (PPoint2 pPoint1) d (perp2, UlpSum ulpSumPerp2) = pPointOnPerpWithErr pLine (PPoint2 pPoint2) d - (CPPoint2 pPoint1, UlpSum ulpSumP1) = makeCPPoint2WithErr x1 y1 - (CPPoint2 pPoint2, UlpSum ulpSumP2) = makeCPPoint2WithErr x2 y2 + (CPPoint2 pPoint1) = makeCPPoint2 x1 y1 + (CPPoint2 pPoint2) = makeCPPoint2 x2 y2 (pLine, UlpSum ulpPLine) = join2CPPoint2WithErr (CPPoint2 pPoint1) (CPPoint2 pPoint2) - ulpTotal1 = ulpSumP1 + ulpPLine + res1Err + ulpSumPerp1 - ulpTotal2 = ulpSumP2 + ulpPLine + res2Err + ulpSumPerp2 + ulpTotal1 = ulpPLine + res1Err + ulpSumPerp1 + ulpTotal2 = ulpPLine + res2Err + ulpSumPerp2 d :: ℝ d = coerce rawD -- make sure we do not try to create a 0 length line segment. @@ -1339,7 +1333,7 @@ prop_obtuseBisectorOnBiggerSide_makeINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 prop_eNodeTowardIntersection1 :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> Positive ℝ -> Radian ℝ -> Expectation prop_eNodeTowardIntersection1 x y d1 rawR1 d2 rawR2 = l1TowardIntersection --> True where - l1TowardIntersection = towardIntersection (eToPPoint2 $ startPoint l1) pl1 eNodePoint + l1TowardIntersection = towardIntersection ((\(CPPoint2 v)-> PPoint2 v) $ eToPPoint2 $ startPoint l1) pl1 eNodePoint (eNodePoint, _) = canonicalize $ pPointOf eNode l1 = getFirstLineSeg eNode pl1 = eToPLine2 l1 @@ -1348,7 +1342,7 @@ prop_eNodeTowardIntersection1 x y d1 rawR1 d2 rawR2 = l1TowardIntersection --> T prop_eNodeAwayFromIntersection2 :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> Positive ℝ -> Radian ℝ -> Expectation prop_eNodeAwayFromIntersection2 x y d1 rawR1 d2 rawR2 = l2TowardIntersection --> False where - l2TowardIntersection = towardIntersection (eToPPoint2 $ endPoint l2) pl2 eNodePoint + l2TowardIntersection = towardIntersection ((\(CPPoint2 v)-> PPoint2 v) $ eToPPoint2 $ endPoint l2) pl2 eNodePoint (eNodePoint, _) = canonicalize $ pPointOf eNode l2 = getLastLineSeg eNode pl2 = eToPLine2 l2 @@ -1374,13 +1368,13 @@ prop_PLinesIntersectAtOrigin rawX y rawX2 rawY2 | foundDistance < realToFrac errSum = True | otherwise = error "wtf" where - (originPPoint2, UlpSum originErr) = makeCPPoint2WithErr 0 0 + originPPoint2 = makeCPPoint2 0 0 (foundDistance, UlpSum distanceErr) = distanceBetweenPPointsWithErr originPPoint2 intersectionCPPoint2 (intersectionCPPoint2, UlpSum canonicalizationErr) = canonicalize intersectionPPoint2 (intersectionPPoint2, UlpSum intersectionErr) = pLineIntersectionWithErr randomPLine1 randomPLine2 (randomPLine1, UlpSum pline1Err) = randomPLineThroughOrigin x y (randomPLine2, UlpSum pline2Err) = randomPLineThroughOrigin x2 y2 - errSum = intersectionErr + originErr + pline1Err + pline2Err + distanceErr + canonicalizationErr + errSum = intersectionErr + pline1Err + pline2Err + distanceErr + canonicalizationErr x,x2,y2 :: ℝ x = coerce rawX x2 @@ -1398,17 +1392,16 @@ prop_PLinesIntersectAtPoint rawX y rawX2 rawY2 targetX targetY <> show foundDistance <> "\n" <> show errSum <> "\n" <> show targetPPoint2 <> "\n" - <> show targetErr <> "\n" <> show foundDistance <> "\n" <> show distanceErr <> "\n" where - (targetPPoint2, UlpSum targetErr) = makeCPPoint2WithErr (coerce targetX) (coerce targetY) + (targetPPoint2) = makeCPPoint2 (coerce targetX) (coerce targetY) (foundDistance, UlpSum distanceErr) = distanceBetweenPPointsWithErr targetPPoint2 intersectionCPPoint2 (intersectionCPPoint2, UlpSum canonicalizationErr) = canonicalize intersectionPPoint2 (intersectionPPoint2, UlpSum intersectionErr) = pLineIntersectionWithErr randomPLine1 randomPLine2 (randomPLine1, UlpSum pline1Err) = randomPLineWithErr x y targetX targetY (randomPLine2, UlpSum pline2Err) = randomPLineWithErr x2 y2 targetX targetY - errSum = intersectionErr + targetErr + pline1Err + pline2Err + distanceErr + canonicalizationErr + errSum = intersectionErr + pline1Err + pline2Err + distanceErr + canonicalizationErr x,x2,y2 :: ℝ x = coerce rawX x2 From 9e9994ae72af959bb0782516c8a82baa19230585 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 15 Oct 2022 17:39:22 +0000 Subject: [PATCH 016/206] move from distanceBetweenNPLine2sWithErr to distanceBetweenPLinesWithErr. --- Graphics/Slicer/Math/Intersections.hs | 6 +++--- Graphics/Slicer/Math/Lossy.hs | 8 ++++---- Graphics/Slicer/Math/PGA.hs | 8 ++++---- tests/Math/PGA.hs | 10 +++------- 4 files changed, 14 insertions(+), 18 deletions(-) diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index 25c5dbedf..e453cd63e 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -36,9 +36,9 @@ import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, mapWithNeighb import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum)) -import Graphics.Slicer.Math.Lossy (normalizePLine2, pToEPoint2) +import Graphics.Slicer.Math.Lossy (pToEPoint2) -import Graphics.Slicer.Math.PGA (CPPoint2, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), Intersection(HitEndPoint, HitStartPoint, NoIntersection), PLine2, intersectsWith, distanceBetweenNPLine2sWithErr, outputIntersectsLineSeg, plinesIntersectIn, ulpOfLineSeg) +import Graphics.Slicer.Math.PGA (CPPoint2, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), Intersection(HitEndPoint, HitStartPoint, NoIntersection), PLine2, intersectsWith, distanceBetweenPLinesWithErr, outputIntersectsLineSeg, plinesIntersectIn, ulpOfLineSeg) import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle)) @@ -186,7 +186,7 @@ intersectionOf pl1 pl2 = saneIntersection $ plinesIntersectIn pl1 pl2 intersectionBetween :: PLine2 -> PLine2 -> Maybe (Either PLine2 CPPoint2) intersectionBetween pl1 pl2 = saneIntersection $ plinesIntersectIn pl1 pl2 where - (foundDistance, UlpSum foundErr) = distanceBetweenNPLine2sWithErr (normalizePLine2 pl1) (normalizePLine2 pl2) + (foundDistance, UlpSum foundErr) = distanceBetweenPLinesWithErr pl1 pl2 saneIntersection PAntiCollinear = Just $ Left pl1 saneIntersection PCollinear = Just $ Left pl1 saneIntersection PParallel = if foundDistance < realToFrac foundErr diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index fb9ec186e..540e8eea6 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -22,7 +22,7 @@ module Graphics.Slicer.Math.Lossy ( angleBetween, canonicalizePPoint2, distanceBetweenPPoints, - distanceBetweenNPLine2s, + distanceBetweenPLines, distanceCPPointToNPLine, distancePPointToPLine, eToCPPoint2, @@ -49,7 +49,7 @@ import Graphics.Slicer.Definitions (ℝ) import Graphics.Slicer.Math.Definitions (LineSeg, Point2) -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2, PLine2, PPoint2(PPoint2), ProjectiveLine2, ProjectivePoint2, angleBetweenWithErr, canonicalize, distanceBetweenPPointsWithErr, distanceBetweenNPLine2sWithErr, distanceCPPointToNPLineWithErr, distancePPointToPLineWithErr, eToPLine2WithErr, eToPPoint2, getFirstArcWithErr, getInsideArcWithErr, join2CPPoint2WithErr, join2PP, makeCPPoint2, normalize, pLineFromEndpointsWithErr, pPointBetweenPPointsWithErr, pPointOnPerpWithErr, pToEP, translatePLine2WithErr) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2, PLine2, PPoint2(PPoint2), ProjectiveLine2, ProjectivePoint2, angleBetweenWithErr, canonicalize, distanceBetweenPPointsWithErr, distanceBetweenPLinesWithErr, distanceCPPointToNPLineWithErr, distancePPointToPLineWithErr, eToPLine2WithErr, eToPPoint2, getFirstArcWithErr, getInsideArcWithErr, join2CPPoint2WithErr, join2PP, makeCPPoint2, normalize, pLineFromEndpointsWithErr, pPointBetweenPPointsWithErr, pPointOnPerpWithErr, pToEP, translatePLine2WithErr) angleBetween :: NPLine2 -> NPLine2 -> ℝ angleBetween nPLine1 nPLine2 = fst $ angleBetweenWithErr nPLine1 nPLine2 @@ -61,8 +61,8 @@ canonicalizePPoint2 point = fst $ canonicalize point distanceBetweenPPoints :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> ℝ distanceBetweenPPoints point1 point2 = fst $ distanceBetweenPPointsWithErr point1 point2 -distanceBetweenNPLine2s :: NPLine2 -> NPLine2 -> ℝ -distanceBetweenNPLine2s nPLine1 nPLine2 = fst $ distanceBetweenNPLine2sWithErr nPLine1 nPLine2 +distanceBetweenPLines :: (ProjectiveLine2 a) => a -> a -> ℝ +distanceBetweenPLines nPLine1 nPLine2 = fst $ distanceBetweenPLinesWithErr nPLine1 nPLine2 -- | Find the unsigned distance between a point and a line. distanceCPPointToNPLine :: CPPoint2 -> NPLine2 -> ℝ diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 01a82195d..4c9d47989 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -35,10 +35,10 @@ module Graphics.Slicer.Math.PGA( ProjectiveLine2, ProjectivePoint2, angleBetweenWithErr, - combineConsecutiveLineSegs, canonicalize, + combineConsecutiveLineSegs, distanceBetweenPPointsWithErr, - distanceBetweenNPLine2sWithErr, + distanceBetweenPLinesWithErr, distanceCPPointToNPLineWithErr, distancePPointToPLineWithErr, eToPLine2WithErr, @@ -238,8 +238,8 @@ distanceBetweenPPointsWithErr point1 point2 = (res, ulpTotal) (cpoint2, _) = canonicalize point2 -- | Find the unsigned distance between two parallel or antiparallel projective lines. -distanceBetweenNPLine2sWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, UlpSum) -distanceBetweenNPLine2sWithErr line1 line2 = (ideal, resUlpSum) +distanceBetweenPLinesWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, UlpSum) +distanceBetweenPLinesWithErr line1 line2 = (ideal, resUlpSum) where (ideal, idealUlpSum) = idealNormOfP $ PPoint2 likeRes resUlpSum = idealUlpSum <> sumErrVals likeMulErr <> sumErrVals likeAddErr diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index ca6061f99..7aae877d8 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -56,7 +56,7 @@ import Graphics.Slicer.Math.Definitions(Point2(Point2), Contour(LineSegContour), -- Our Geometric Algebra library. import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(GEZero, GEPlus, G0), GVal(GVal), GVec(GVec), UlpSum(UlpSum), addValPairWithErr, subValPairWithErr, addValWithErr, subVal, addVecPair, subVecPair, mulScalarVecWithErr, divVecScalarWithErr, scalarPart, vectorPart, (•), (∧), (⋅), (⎣), (⎤)) -import Graphics.Slicer.Math.Lossy (angleBetween, canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenNPLine2s, distancePPointToPLine, eToCPPoint2, eToPLine2, getFirstArc, join2PPoint2, makePPoint2, normalizePLine2, pPointOnPerp) +import Graphics.Slicer.Math.Lossy (angleBetween, canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenPLines, distancePPointToPLine, eToCPPoint2, eToPLine2, getFirstArc, join2PPoint2, makePPoint2, normalizePLine2, pPointOnPerp) -- Our 2D Projective Geometric Algebra library. import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), canonicalize, pPointBetweenPPointsWithErr, distanceBetweenPPointsWithErr, distanceCPPointToNPLineWithErr, eToPPoint2, join2CPPoint2WithErr, pLineIntersectionWithErr, translatePLine2WithErr, translateRotatePPoint2, angleBetweenWithErr, flipL, makeCPPoint2, normalize, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, pLineFromEndpointsWithErr, distancePPointToPLineWithErr, pPointOnPerpWithErr, outOf, pPointOf, ulpOfOut, outputIntersectsLineSeg, pPointBetweenPPointsWithErr) @@ -457,19 +457,15 @@ prop_PerpTranslateID x y dx dy rawT $ "failed:\n" <> "origPLine: " <> show origPLine <> "\n" <> "resPLine: " <> show resPLine <> "\n" - <> "origNPline: " <> show origNPLine <> "\n" - <> "resNPline: " <> show resNPLine <> "\n" <> "res: " <> show res <> "\n" <> "resErr: " <> show resErr <> "\n" where - res = distanceBetweenNPLine2s resNPLine origNPLine - (resNPLine, UlpSum resNErr) = normalize resPLine - (origNPLine, UlpSum origNErr) = normalize origPLine + res = distanceBetweenPLines resPLine origPLine (resPLine, UlpSum resPLineErr) = translatePLine2WithErr translatedPLine (-t) (translatedPLine, UlpSum translatedPLineErr) = translatePLine2WithErr origPLine t (origPLine, UlpSum origPLineErr) = randomPLineWithErr x y dx dy resErr, t :: ℝ - resErr = realToFrac (resPLineErr + translatedPLineErr + origPLineErr + resNErr + origNErr) + resErr = realToFrac (resPLineErr + translatedPLineErr + origPLineErr) t = coerce rawT pgaSpec :: Spec From 2e9f0ab4b8d24a850e95b401b3271b6e09cdfc90 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 15 Oct 2022 22:16:40 +0000 Subject: [PATCH 017/206] remove join2CPPoint2WithErr, rename makeCPPoint2 to makePPoint2, rename translatePLine2WithErr to translateL, and make sure translateL returns a PLine2. --- Graphics/Slicer/Math/Lossy.hs | 17 +++----- Graphics/Slicer/Math/PGA.hs | 82 ++++++++++++++++------------------- tests/Math/PGA.hs | 50 ++++++++++----------- 3 files changed, 67 insertions(+), 82 deletions(-) diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index 540e8eea6..a3ae68c3c 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -32,8 +32,6 @@ module Graphics.Slicer.Math.Lossy ( getInsideArc, join2CPPoint2, join2PPoint2, - makePPoint2, - makeCPPoint2, normalizePLine2, pLineFromEndpoints, pPointBetweenPPoints, @@ -49,7 +47,7 @@ import Graphics.Slicer.Definitions (ℝ) import Graphics.Slicer.Math.Definitions (LineSeg, Point2) -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2, PLine2, PPoint2(PPoint2), ProjectiveLine2, ProjectivePoint2, angleBetweenWithErr, canonicalize, distanceBetweenPPointsWithErr, distanceBetweenPLinesWithErr, distanceCPPointToNPLineWithErr, distancePPointToPLineWithErr, eToPLine2WithErr, eToPPoint2, getFirstArcWithErr, getInsideArcWithErr, join2CPPoint2WithErr, join2PP, makeCPPoint2, normalize, pLineFromEndpointsWithErr, pPointBetweenPPointsWithErr, pPointOnPerpWithErr, pToEP, translatePLine2WithErr) +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PPoint2, ProjectiveLine2, ProjectivePoint2, angleBetweenWithErr, canonicalize, distanceBetweenPPointsWithErr, distanceBetweenPLinesWithErr, distanceCPPointToNPLineWithErr, distancePPointToPLineWithErr, eToPLine2WithErr, eToPPoint2, getFirstArcWithErr, getInsideArcWithErr, join2PP, normalize, pLineFromEndpointsWithErr, pPointBetweenPPointsWithErr, pPointOnPerpWithErr, pToEP, translateL) angleBetween :: NPLine2 -> NPLine2 -> ℝ angleBetween nPLine1 nPLine2 = fst $ angleBetweenWithErr nPLine1 nPLine2 @@ -96,13 +94,8 @@ join2PPoint2 :: (ProjectivePoint2 a) => a -> a -> PLine2 join2PPoint2 pp1 pp2 = fst $ join2PP pp1 pp2 -- | a typed join function. join two points, returning a line. -join2CPPoint2 :: CPPoint2 -> CPPoint2 -> PLine2 -join2CPPoint2 pp1 pp2 = fst $ join2CPPoint2WithErr pp1 pp2 - --- | create a euclidian projective point from the given coordinates. --- Really, just wraps makeCPPoint2 -makePPoint2 :: ℝ -> ℝ -> PPoint2 -makePPoint2 x y = (\(CPPoint2 p) -> PPoint2 p) $ makeCPPoint2 x y +join2CPPoint2 :: (ProjectivePoint2 a) => a -> a -> PLine2 +join2CPPoint2 pp1 pp2 = fst $ join2PP pp1 pp2 -- | Normalize a PLine2. normalizePLine2 :: (ProjectiveLine2 a) => a -> NPLine2 @@ -121,9 +114,9 @@ pPointBetweenPPoints :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> pPointBetweenPPoints startOfSeg stopOfSeg weight1 weight2 = fst $ pPointBetweenPPointsWithErr startOfSeg stopOfSeg weight1 weight2 -- | Find a projective point a given distance along a line perpendicularly bisecting the given line at a given point. -pPointOnPerp :: PLine2 -> PPoint2 -> ℝ -> PPoint2 +pPointOnPerp :: (ProjectiveLine2 a, ProjectivePoint2 b) => a -> b -> ℝ -> PPoint2 pPointOnPerp pline ppoint d = fst $ pPointOnPerpWithErr pline ppoint d -- | translate a PLine2 along it's perpendicular bisector. translatePLine2 :: PLine2 -> ℝ -> PLine2 -translatePLine2 pline distance = fst $ translatePLine2WithErr pline distance +translatePLine2 pline distance = fst $ translateL pline distance diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 4c9d47989..44ba9b64d 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -49,8 +49,7 @@ module Graphics.Slicer.Math.PGA( intersectsWith, intersectsWithErr, join2PP, - join2CPPoint2WithErr, - makeCPPoint2, + makePPoint2, normalize, outputIntersectsLineSeg, pLineFromEndpointsWithErr, @@ -61,7 +60,7 @@ module Graphics.Slicer.Math.PGA( pPointsOnSameSideOfPLine, pToEP, plinesIntersectIn, - translatePLine2WithErr, + translateL, translateRotatePPoint2, ulpOfLineSeg, ulpOfPLine2 @@ -201,7 +200,7 @@ distanceCPPointToNPLineWithErr point line | otherwise = (res, ulpTotal) where (res, _) = normOfPLine2WithErr newPLine - (newPLine, newPLineErr) = join2CPPoint2WithErr point linePoint + (newPLine, newPLineErr) = join2PP point linePoint (perpLine, (plMulErr,plAddErr))= lvec ⨅+ npvec (PLine2 lvec) = forceBasisOfL (PLine2 nplvec) (CPPoint2 npvec) = forceBasisOfP point @@ -232,7 +231,7 @@ distanceBetweenPPointsWithErr :: (ProjectivePoint2 a, ProjectivePoint2 b) => a - distanceBetweenPPointsWithErr point1 point2 = (res, ulpTotal) where (res, _) = normOfPLine2WithErr newPLine - (newPLine, newPLineUlp) = join2CPPoint2WithErr cpoint1 cpoint2 + (newPLine, newPLineUlp) = join2PP cpoint1 cpoint2 ulpTotal = newPLineUlp -- resErr -- <> PLine2Err _ _ _ _ _ newPLineUlp (cpoint1, _) = canonicalize point1 (cpoint2, _) = canonicalize point2 @@ -283,15 +282,15 @@ oppositeDirection a b = res <= minAngle (res, resErr) = angleBetweenWithErr a b -- | Find a projective point a given distance along a line perpendicularly bisecting the given line at a given point. -pPointOnPerpWithErr :: (ProjectiveLine2 a) => a -> PPoint2 -> ℝ -> (PPoint2, UlpSum) -pPointOnPerpWithErr line rppoint d = (PPoint2 res, - ulpTotal) +pPointOnPerpWithErr :: (ProjectiveLine2 a, ProjectivePoint2 b) => a -> b -> ℝ -> (PPoint2, UlpSum) +pPointOnPerpWithErr line ppoint d = (PPoint2 res, + ulpTotal) where res = motor•pvec•reverseGVec motor - (NPLine2 rlvec, lErr) = normalize line (perpLine, (plMulErr,plAddErr))= lvec ⨅+ pvec - (PLine2 lvec) = forceBasisOfL $ PLine2 rlvec - (PPoint2 pvec) = forceBasisOfP rppoint + lvec = vecOfL $ forceBasisOfL npl + (npl,lErr) = normalize line + pvec = vecOfP $ forceBasisOfP ppoint motor = addVecPairWithoutErr (perpLine • gaIScaled) (GVec [GVal 1 (singleton G0)]) -- I, in this geometric algebra system. we multiply it times d/2, to shorten the number of multiples we have to do when creating the motor. gaIScaled = GVec [GVal (d/2) (fromList [GEZero 1, GEPlus 1, GEPlus 2])] @@ -300,15 +299,15 @@ pPointOnPerpWithErr line rppoint d = (PPoint2 res, -- | Translate a line a given distance along it's perpendicular bisector. -- Abuses the property that translation of a line is expressed on the GEZero component. -translateProjectiveLine2WithErr :: GVec -> ℝ -> (GVec, PLine2Err) -translateProjectiveLine2WithErr lineVec d = (res, nErr <> PLine2Err resUlp mempty mempty mempty tUlp mempty) +translateProjectiveLine2WithErr :: (ProjectiveLine2 a) => a -> ℝ -> (PLine2, PLine2Err) +translateProjectiveLine2WithErr line d = (PLine2 res, nErr <> PLine2Err resUlp mempty mempty mempty tUlp mempty) where - (res, resUlp) = addVecPairWithErr m lineVec + (res, resUlp) = addVecPairWithErr m $ vecOfL line m = GVec [GVal tAdd (singleton (GEZero 1))] -- the amount to add to the GEZero 1 component. tAdd = d * n tUlp = UlpSum $ abs $ realToFrac $ doubleUlp tAdd - (n, nErr) = normOfPLine2WithErr (PLine2 lineVec) + (n, nErr) = normOfPLine2WithErr line -- | Translate a point a given distance away from where it is, rotating it a given amount clockwise (in radians) around it's original location, with 0 degrees being aligned to the X axis. translateRotatePPoint2 :: (ProjectivePoint2 a) => a -> ℝ -> ℝ -> PPoint2 @@ -700,25 +699,25 @@ class ProjectiveLine2 a where forceBasisOfL :: a -> a meetOf2PL :: a -> a -> (PPoint2, UlpSum) normalize :: a -> (NPLine2, UlpSum) - translatePLine2WithErr :: a -> ℝ -> (a, UlpSum) + translateL :: a -> ℝ -> (PLine2, UlpSum) vecOfL :: a -> GVec instance ProjectiveLine2 NPLine2 where - consLikeL (NPLine2 _) = NPLine2 - flipL a = flipProjectiveLine a - forceBasisOfL a = forceProjectiveLineBasis a - meetOf2PL a b = meet2ProjectiveLinesWithErr a b - normalize a = (a, mempty) - translatePLine2WithErr (NPLine2 a) d = (\(b,(PLine2Err _ _ _ _ t _)) -> (NPLine2 b,t)) $ translateProjectiveLine2WithErr a d - vecOfL (NPLine2 a) = a + consLikeL _ = NPLine2 + flipL l = flipProjectiveLine l + forceBasisOfL l = forceProjectiveLineBasis l + meetOf2PL l1 l2 = meet2ProjectiveLinesWithErr l1 l2 + normalize l = (l, mempty) + translateL l d = (\(r,(PLine2Err _ _ _ _ t _)) -> (r,t)) $ translateProjectiveLine2WithErr l d + vecOfL (NPLine2 v) = v instance ProjectiveLine2 PLine2 where - consLikeL (PLine2 _) = PLine2 - flipL a = flipProjectiveLine a - forceBasisOfL a = forceProjectiveLineBasis a - meetOf2PL a b = meet2ProjectiveLinesWithErr a b - normalize a = (\(b,(PLine2Err _ _ c d _ _)) -> (b,c <> d)) $ normalizePLine2WithErr a - translatePLine2WithErr (PLine2 a) d = (\(b,(PLine2Err _ _ _ _ t _)) -> (PLine2 b,t)) $ translateProjectiveLine2WithErr a d + consLikeL _ = PLine2 + flipL l = flipProjectiveLine l + forceBasisOfL l = forceProjectiveLineBasis l + meetOf2PL l1 l2 = meet2ProjectiveLinesWithErr l1 l2 + normalize l = (\(b,(PLine2Err _ _ c d _ _)) -> (b,c <> d)) $ normalizePLine2WithErr l + translateL l d = (\(r,(PLine2Err _ _ _ _ t _)) -> (r,t)) $ translateProjectiveLine2WithErr l d vecOfL (PLine2 a) = a -- | the two types of error of a projective line. @@ -758,22 +757,15 @@ infixl 9 ∨+ -- | a typed join function. join two points, returning a line. join2ProjectivePointsWithErr ::(ProjectivePoint2 a) => a -> a -> (PLine2, UlpSum) -join2ProjectivePointsWithErr pp1 pp2 = (res, +join2ProjectivePointsWithErr pp1 pp2 = (PLine2 res, errTotal) - where - (res, resErr) = join2CPPoint2WithErr cp1 cp2 - (cp1, pv1Err) = canonicalize pp1 - (cp2, pv2Err) = canonicalize pp2 - errTotal = resErr <> pv1Err <> pv2Err - --- | a typed join function. join two points, returning a line. -join2CPPoint2WithErr :: CPPoint2 -> CPPoint2 -> (PLine2, UlpSum) -join2CPPoint2WithErr pp1 pp2 = (PLine2 res, - resUlp) where (res,resUlp) = pv1 ∨+ pv2 - (CPPoint2 pv1) = forceBasisOfP pp1 - (CPPoint2 pv2) = forceBasisOfP pp2 + pv1 = vecOfP $ forceBasisOfP cp1 + pv2 = vecOfP $ forceBasisOfP cp2 + (cp1, pv1Ulp) = canonicalize pp1 + (cp2, pv2Ulp) = canonicalize pp2 + errTotal = resUlp <> pv1Ulp <> pv2Ulp -- | A typed meet function. the meeting of two lines is a point. meet2ProjectiveLinesWithErr :: (ProjectiveLine2 a) => a -> a -> (PPoint2, UlpSum) @@ -790,12 +782,12 @@ meet2ProjectiveLinesWithErr line1 line2 = (PPoint2 res, eToPPoint2 :: Point2 -> CPPoint2 eToPPoint2 (Point2 (x,y)) = res where - res = makeCPPoint2 x y + res = makePPoint2 x y -- | Create a canonical euclidian projective point from the given coordinates, with error. -- FIXME: is there any chance of loss of precision on y? -makeCPPoint2 :: ℝ -> ℝ -> CPPoint2 -makeCPPoint2 x y = pPoint +makePPoint2 :: ℝ -> ℝ -> CPPoint2 +makePPoint2 x y = pPoint where pPoint = CPPoint2 $ GVec $ foldl' addValWithoutErr [GVal 1 (fromList [GEPlus 1, GEPlus 2])] [ GVal (negate x) (fromList [GEZero 1, GEPlus 2]), GVal y (fromList [GEZero 1, GEPlus 1])] diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index 7aae877d8..a7389584a 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -56,10 +56,10 @@ import Graphics.Slicer.Math.Definitions(Point2(Point2), Contour(LineSegContour), -- Our Geometric Algebra library. import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(GEZero, GEPlus, G0), GVal(GVal), GVec(GVec), UlpSum(UlpSum), addValPairWithErr, subValPairWithErr, addValWithErr, subVal, addVecPair, subVecPair, mulScalarVecWithErr, divVecScalarWithErr, scalarPart, vectorPart, (•), (∧), (⋅), (⎣), (⎤)) -import Graphics.Slicer.Math.Lossy (angleBetween, canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenPLines, distancePPointToPLine, eToCPPoint2, eToPLine2, getFirstArc, join2PPoint2, makePPoint2, normalizePLine2, pPointOnPerp) +import Graphics.Slicer.Math.Lossy (angleBetween, canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenPLines, distancePPointToPLine, eToCPPoint2, eToPLine2, getFirstArc, join2PPoint2, normalizePLine2, pPointOnPerp) -- Our 2D Projective Geometric Algebra library. -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), canonicalize, pPointBetweenPPointsWithErr, distanceBetweenPPointsWithErr, distanceCPPointToNPLineWithErr, eToPPoint2, join2CPPoint2WithErr, pLineIntersectionWithErr, translatePLine2WithErr, translateRotatePPoint2, angleBetweenWithErr, flipL, makeCPPoint2, normalize, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, pLineFromEndpointsWithErr, distancePPointToPLineWithErr, pPointOnPerpWithErr, outOf, pPointOf, ulpOfOut, outputIntersectsLineSeg, pPointBetweenPPointsWithErr) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), canonicalize, pPointBetweenPPointsWithErr, distanceBetweenPPointsWithErr, distanceCPPointToNPLineWithErr, eToPPoint2, pLineIntersectionWithErr, translateL, translateRotatePPoint2, angleBetweenWithErr, flipL, join2PP, makePPoint2, normalize, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, pLineFromEndpointsWithErr, distancePPointToPLineWithErr, pPointOnPerpWithErr, outOf, pPointOf, ulpOfOut, outputIntersectsLineSeg, pPointBetweenPPointsWithErr) -- Our Contour library. import Graphics.Slicer.Math.Contour (contourContainsContour, getContours, pointsOfContour, numPointsOfContour, justOneContourFrom, lineSegsOfContour, makeLineSegContour, makePointContour, insideIsLeft, innerContourPoint, firstPointPairOfContour, firstLineSegOfContour) @@ -376,11 +376,11 @@ proj2DGeomAlgSpec = do prop_AxisProjection :: Positive ℝ -> Bool -> Bool -> Positive ℝ -> Expectation prop_AxisProjection v xAxis whichDirection dv | xAxis = if whichDirection - then canonicalizePPoint2 (pPointOnPerp (eToPLine2 $ randomLineSeg 0 0 (coerce v) 0) (makePPoint2 0 0) (coerce dv)) --> makeCPPoint2 0 (coerce dv) - else canonicalizePPoint2 (pPointOnPerp (eToPLine2 $ randomLineSeg 0 0 (-(coerce v)) 0) (makePPoint2 0 0) (coerce dv)) --> makeCPPoint2 0 (-coerce dv) + then canonicalizePPoint2 (pPointOnPerp (eToPLine2 $ randomLineSeg 0 0 (coerce v) 0) (makePPoint2 0 0) (coerce dv)) --> makePPoint2 0 (coerce dv) + else canonicalizePPoint2 (pPointOnPerp (eToPLine2 $ randomLineSeg 0 0 (-(coerce v)) 0) (makePPoint2 0 0) (coerce dv)) --> makePPoint2 0 (-coerce dv) | otherwise = if whichDirection - then canonicalizePPoint2 (pPointOnPerp (eToPLine2 $ randomLineSeg 0 0 0 (coerce v)) (makePPoint2 0 0) (coerce dv)) --> makeCPPoint2 (-coerce dv) 0 - else canonicalizePPoint2 (pPointOnPerp (eToPLine2 $ randomLineSeg 0 0 0 (-(coerce v))) (makePPoint2 0 0) (coerce dv)) --> makeCPPoint2 (coerce dv) 0 + then canonicalizePPoint2 (pPointOnPerp (eToPLine2 $ randomLineSeg 0 0 0 (coerce v)) (makePPoint2 0 0) (coerce dv)) --> makePPoint2 (-coerce dv) 0 + else canonicalizePPoint2 (pPointOnPerp (eToPLine2 $ randomLineSeg 0 0 0 (-(coerce v))) (makePPoint2 0 0) (coerce dv)) --> makePPoint2 (coerce dv) 0 -- A property test making sure than for any LineSeg, a pointOnPerp is in fact on a 90 degree perpendicular line. prop_perpAt90Degrees :: ℝ -> ℝ -> Positive ℝ -> ℝ -> NonZero ℝ -> Bool @@ -403,11 +403,11 @@ prop_perpAt90Degrees x y rawX2 y2 rawD (PPoint2 rawBisectorStart, UlpSum bisectorStartErr) = pPointBetweenPPointsWithErr sourceStart sourceEnd 0.5 0.5 (bisectorEndRaw, UlpSum bisectorEndRawErr) = pPointOnPerpWithErr pline4 (PPoint2 rawBisectorStart) d (bisectorEnd, UlpSum bisectorEndErr) = canonicalize bisectorEndRaw - (pline3, UlpSum pline3Err) = join2CPPoint2WithErr (CPPoint2 rawBisectorStart) bisectorEnd + (pline3, UlpSum pline3Err) = join2PP (CPPoint2 rawBisectorStart) bisectorEnd (normedPLine3, UlpSum norm3Err) = normalize pline3 - sourceStart = makeCPPoint2 x y - sourceEnd = makeCPPoint2 x2 y2 - (pline4, UlpSum pline4Err) = join2CPPoint2WithErr sourceStart sourceEnd + sourceStart = makePPoint2 x y + sourceEnd = makePPoint2 x2 y2 + (pline4, UlpSum pline4Err) = join2PP sourceStart sourceEnd (normedPLine4, UlpSum norm4Err) = normalize pline4 errTotal3 = angle2Err + norm3Err + pline3Err + pline4Err + norm4Err + bisectorStartErr + bisectorEndRawErr + bisectorEndErr errTotal4 = angle2Err + norm3Err + pline3Err + pline4Err + norm4Err + bisectorStartErr + bisectorEndRawErr + bisectorEndErr @@ -461,8 +461,8 @@ prop_PerpTranslateID x y dx dy rawT <> "resErr: " <> show resErr <> "\n" where res = distanceBetweenPLines resPLine origPLine - (resPLine, UlpSum resPLineErr) = translatePLine2WithErr translatedPLine (-t) - (translatedPLine, UlpSum translatedPLineErr) = translatePLine2WithErr origPLine t + (resPLine, UlpSum resPLineErr) = translateL translatedPLine (-t) + (translatedPLine, UlpSum translatedPLineErr) = translateL origPLine t (origPLine, UlpSum origPLineErr) = randomPLineWithErr x y dx dy resErr, t :: ℝ resErr = realToFrac (resPLineErr + translatedPLineErr + origPLineErr) @@ -1187,8 +1187,8 @@ prop_PPointWithinErrRange x y | otherwise = (p1 /= p2) || (res == 0 || error "the same, but distance?") where (res, UlpSum resErr) = distanceBetweenPPointsWithErr p1 p2 - p1 = makeCPPoint2 x y - p2 = makeCPPoint2 x y + p1 = makePPoint2 x y + p2 = makePPoint2 x y prop_LineSegWithinErrRange :: ℝ -> ℝ -> ℝ -> ℝ -> Bool prop_LineSegWithinErrRange x1 y1 rawX2 rawY2 @@ -1227,8 +1227,8 @@ prop_PLineWithinErrRange1 x1 y1 rawX2 rawY2 -- distance1 and distance2 should be 0, in an ideal world. (distance1, UlpSum distance1Err) = distanceCPPointToNPLineWithErr pPoint1 nPLine (distance2, UlpSum distance2Err) = distanceCPPointToNPLineWithErr pPoint2 nPLine - pPoint1 = makeCPPoint2 x1 y1 - pPoint2 = makeCPPoint2 x2 y2 + pPoint1 = makePPoint2 x1 y1 + pPoint2 = makePPoint2 x2 y2 (nPLine, UlpSum nPLineErr) = normalize pLine (pLine, UlpSum ulpPLine) = pLineFromEndpointsWithErr (Point2 (x1,y1)) (Point2 (x2,y2)) ulpTotal1 = ulpPLine + distance1Err + nPLineErr @@ -1261,9 +1261,9 @@ prop_PLineWithinErrRange2 x1 y1 rawX2 rawY2 -- distance1 and distance2 should be 0, in an ideal world. (distance1, UlpSum distance1Err) = distancePPointToPLineWithErr (PPoint2 pPoint1) pLine1 (distance2, UlpSum distance2Err) = distancePPointToPLineWithErr (PPoint2 pPoint2) pLine1 - (CPPoint2 pPoint1) = makeCPPoint2 x1 y1 - (CPPoint2 pPoint2) = makeCPPoint2 x2 y2 - (pLine1, UlpSum ulpPLine) = join2CPPoint2WithErr (CPPoint2 pPoint1) (CPPoint2 pPoint2) + (CPPoint2 pPoint1) = makePPoint2 x1 y1 + (CPPoint2 pPoint2) = makePPoint2 x2 y2 + (pLine1, UlpSum ulpPLine) = join2PP (CPPoint2 pPoint1) (CPPoint2 pPoint2) (NPLine2 lvec, UlpSum normErr) = normalize pLine1 ulpTotal1 = ulpPLine + distance1Err ulpTotal2 = ulpPLine + distance2Err @@ -1293,9 +1293,9 @@ prop_PPointOnPerpWithinErrRange x1 y1 rawX2 rawY2 rawD (res2,UlpSum res2Err) = distancePPointToPLineWithErr perp2 pLine (perp1, UlpSum ulpSumPerp1) = pPointOnPerpWithErr pLine (PPoint2 pPoint1) d (perp2, UlpSum ulpSumPerp2) = pPointOnPerpWithErr pLine (PPoint2 pPoint2) d - (CPPoint2 pPoint1) = makeCPPoint2 x1 y1 - (CPPoint2 pPoint2) = makeCPPoint2 x2 y2 - (pLine, UlpSum ulpPLine) = join2CPPoint2WithErr (CPPoint2 pPoint1) (CPPoint2 pPoint2) + (CPPoint2 pPoint1) = makePPoint2 x1 y1 + (CPPoint2 pPoint2) = makePPoint2 x2 y2 + (pLine, UlpSum ulpPLine) = join2PP (CPPoint2 pPoint1) (CPPoint2 pPoint2) ulpTotal1 = ulpPLine + res1Err + ulpSumPerp1 ulpTotal2 = ulpPLine + res2Err + ulpSumPerp2 d :: ℝ @@ -1348,7 +1348,7 @@ prop_translateRotateMoves :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> Expecta prop_translateRotateMoves x y rawD rawR = distanceBetweenPPoints (canonicalizePPoint2 $ translateRotatePPoint2 pPoint d r) cPPoint /= 0 --> True where pPoint = eToPPoint2 $ Point2 (x,y) - cPPoint = makeCPPoint2 x y + cPPoint = makePPoint2 x y r,d::ℝ r = coerce rawR d = coerce rawD @@ -1364,7 +1364,7 @@ prop_PLinesIntersectAtOrigin rawX y rawX2 rawY2 | foundDistance < realToFrac errSum = True | otherwise = error "wtf" where - originPPoint2 = makeCPPoint2 0 0 + originPPoint2 = makePPoint2 0 0 (foundDistance, UlpSum distanceErr) = distanceBetweenPPointsWithErr originPPoint2 intersectionCPPoint2 (intersectionCPPoint2, UlpSum canonicalizationErr) = canonicalize intersectionPPoint2 (intersectionPPoint2, UlpSum intersectionErr) = pLineIntersectionWithErr randomPLine1 randomPLine2 @@ -1391,7 +1391,7 @@ prop_PLinesIntersectAtPoint rawX y rawX2 rawY2 targetX targetY <> show foundDistance <> "\n" <> show distanceErr <> "\n" where - (targetPPoint2) = makeCPPoint2 (coerce targetX) (coerce targetY) + (targetPPoint2) = makePPoint2 (coerce targetX) (coerce targetY) (foundDistance, UlpSum distanceErr) = distanceBetweenPPointsWithErr targetPPoint2 intersectionCPPoint2 (intersectionCPPoint2, UlpSum canonicalizationErr) = canonicalize intersectionPPoint2 (intersectionPPoint2, UlpSum intersectionErr) = pLineIntersectionWithErr randomPLine1 randomPLine2 From f5d0fc16cbef789b84d7f97b1effec7a4b64e5c9 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 16 Oct 2022 10:21:14 +0000 Subject: [PATCH 018/206] remove distanceCPPointToNPLine. --- Graphics/Slicer/Math/Lossy.hs | 9 ++---- Graphics/Slicer/Math/PGA.hs | 42 ++++++++++++--------------- Graphics/Slicer/Math/Skeleton/Line.hs | 14 ++++----- tests/Math/PGA.hs | 6 ++-- 4 files changed, 30 insertions(+), 41 deletions(-) diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index a3ae68c3c..ac34ef51d 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -23,7 +23,6 @@ module Graphics.Slicer.Math.Lossy ( canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenPLines, - distanceCPPointToNPLine, distancePPointToPLine, eToCPPoint2, eToNPLine2, @@ -47,7 +46,7 @@ import Graphics.Slicer.Definitions (ℝ) import Graphics.Slicer.Math.Definitions (LineSeg, Point2) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PPoint2, ProjectiveLine2, ProjectivePoint2, angleBetweenWithErr, canonicalize, distanceBetweenPPointsWithErr, distanceBetweenPLinesWithErr, distanceCPPointToNPLineWithErr, distancePPointToPLineWithErr, eToPLine2WithErr, eToPPoint2, getFirstArcWithErr, getInsideArcWithErr, join2PP, normalize, pLineFromEndpointsWithErr, pPointBetweenPPointsWithErr, pPointOnPerpWithErr, pToEP, translateL) +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PPoint2, ProjectiveLine2, ProjectivePoint2, angleBetweenWithErr, canonicalize, distanceBetweenPPointsWithErr, distanceBetweenPLinesWithErr, distancePPointToPLineWithErr, eToPLine2WithErr, eToPPoint2, getFirstArcWithErr, getInsideArcWithErr, join2PP, normalize, pLineFromEndpointsWithErr, pPointBetweenPPointsWithErr, pPointOnPerpWithErr, pToEP, translateL) angleBetween :: NPLine2 -> NPLine2 -> ℝ angleBetween nPLine1 nPLine2 = fst $ angleBetweenWithErr nPLine1 nPLine2 @@ -63,11 +62,7 @@ distanceBetweenPLines :: (ProjectiveLine2 a) => a -> a -> ℝ distanceBetweenPLines nPLine1 nPLine2 = fst $ distanceBetweenPLinesWithErr nPLine1 nPLine2 -- | Find the unsigned distance between a point and a line. -distanceCPPointToNPLine :: CPPoint2 -> NPLine2 -> ℝ -distanceCPPointToNPLine point line = fst $ distanceCPPointToNPLineWithErr point line - --- | Find the unsigned distance between a point and a line. -distancePPointToPLine :: (ProjectivePoint2 a) => a -> PLine2 -> ℝ +distancePPointToPLine :: (ProjectivePoint2 a, ProjectiveLine2 b) => a -> b -> ℝ distancePPointToPLine point line = fst $ distancePPointToPLineWithErr point line -- | Create a projective point from a euclidian point. diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 44ba9b64d..584d610a7 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -39,7 +39,6 @@ module Graphics.Slicer.Math.PGA( combineConsecutiveLineSegs, distanceBetweenPPointsWithErr, distanceBetweenPLinesWithErr, - distanceCPPointToNPLineWithErr, distancePPointToPLineWithErr, eToPLine2WithErr, eToPPoint2, @@ -186,29 +185,23 @@ pPointBetweenPPointsWithErr startP stopP weight1 weight2 (startP', _) = canonicalize startP (stopP', _) = canonicalize stopP -distancePPointToPLineWithErr :: (ProjectivePoint2 a, ProjectiveLine2 b) => a -> b -> (ℝ, UlpSum) -distancePPointToPLineWithErr point line = (res, resErr <> normErr <> nPVecErr) - where - (res, resErr) = distanceCPPointToNPLineWithErr rnpvec normedLine - (rnpvec, nPVecErr) = canonicalize point - (normedLine, normErr) = normalize line - -- FIXME: use the distance to increase ULP appropriately? -distanceCPPointToNPLineWithErr :: (ProjectiveLine2 b) => CPPoint2 -> b -> (ℝ, UlpSum) -distanceCPPointToNPLineWithErr point line +distancePPointToPLineWithErr :: (ProjectivePoint2 a, ProjectiveLine2 b) => a -> b -> (ℝ, UlpSum) +distancePPointToPLineWithErr point line | valOf 0 foundVal == 0 = error "attempted to get the distance of an ideal point." | otherwise = (res, ulpTotal) where (res, _) = normOfPLine2WithErr newPLine (newPLine, newPLineErr) = join2PP point linePoint (perpLine, (plMulErr,plAddErr))= lvec ⨅+ npvec - (PLine2 lvec) = forceBasisOfL (PLine2 nplvec) - (CPPoint2 npvec) = forceBasisOfP point + lvec = vecOfL $ forceBasisOfL (PLine2 nplvec) + npvec = vecOfP $ forceBasisOfP point (linePoint, lpErr) = fromJust $ canonicalizeIntersectionWithErr (PLine2 lvec) (PLine2 perpLine) ulpTotal = sumErrVals plMulErr <> sumErrVals plAddErr {- <> resErr -} <> newPLineErr <> lpErr - foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(CPPoint2 (GVec vals)) -> vals) point + foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(GVec vals) -> vals) $ vecOfP $ point (NPLine2 nplvec,_) = normalize line + -- | Determine if two points are on the same side of a given line. pPointsOnSameSideOfPLine :: (ProjectivePoint2 a, ProjectivePoint2 b, ProjectiveLine2 c) => a -> b -> c -> Maybe Bool pPointsOnSameSideOfPLine point1 point2 line @@ -256,8 +249,8 @@ angleBetweenWithErr pl1 pl2 = (scalarPart likeRes where ulpSum = sumErrVals likeMulErr <> sumErrVals likeAddErr (likeRes, (likeMulErr, likeAddErr)) = p1 ⎣+ p2 - (PLine2 p1) = forceBasisOfL $ PLine2 pv1 - (PLine2 p2) = forceBasisOfL $ PLine2 pv2 + p1 = vecOfL $ forceBasisOfL $ PLine2 pv1 + p2 = vecOfL $ forceBasisOfL $ PLine2 pv2 (NPLine2 pv1, _) = normalize pl1 (NPLine2 pv2, _) = normalize pl2 @@ -316,8 +309,8 @@ translateRotatePPoint2 ppoint d rotation = PPoint2 $ translator•pvec•reverse pvec = vecOfP ppoint xLineThroughPPoint2 = (pvec ⨅ xLineVec) • pvec where - (PLine2 xLineVec) = forceBasisOfL $ fst $ pLineFromEndpointsWithErr (Point2 (0,0)) (Point2 (1,0)) - (PLine2 angledLineThroughPPoint2) = forceBasisOfL $ PLine2 $ rotator•xLineThroughPPoint2•reverseGVec rotator + xLineVec = vecOfL $ forceBasisOfL $ fst $ pLineFromEndpointsWithErr (Point2 (0,0)) (Point2 (1,0)) + angledLineThroughPPoint2 = vecOfL $ forceBasisOfL $ PLine2 $ rotator•xLineThroughPPoint2•reverseGVec rotator where rotator = addVecPairWithoutErr (fst $ mulScalarVecWithErr (sin $ rotation/2) pvec) (GVec [GVal (cos $ rotation/2) (singleton G0)]) translator = addVecPairWithoutErr (angledLineThroughPPoint2 • gaIScaled) (GVec [GVal 1 (singleton G0)]) @@ -663,7 +656,7 @@ class ProjectivePoint2 a where consLikeP :: a -> (GVec -> a) forceBasisOfP :: a -> a idealNormOfP :: a -> (ℝ, UlpSum) - join2PP :: a -> a -> (PLine2, UlpSum) + join2PP :: (ProjectivePoint2 b) => a -> b -> (PLine2, UlpSum) pToEP :: a -> (Point2, UlpSum) vecOfP :: a -> GVec @@ -673,7 +666,7 @@ instance ProjectivePoint2 PPoint2 where forceBasisOfP a = forceProjectivePointBasis a idealNormOfP a = idealNormPPoint2WithErr a join2PP a b = join2ProjectivePointsWithErr a b - pToEP a = fromMaybe (error "created an infinite point when trying to convert from a Projective point to a euclidian one.") $ projectivePointToPoint2 a + pToEP a = fromMaybe (error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point.") $ projectivePointToPoint2 a vecOfP (PPoint2 a) = a instance ProjectivePoint2 CPPoint2 where @@ -682,7 +675,7 @@ instance ProjectivePoint2 CPPoint2 where forceBasisOfP a = forceProjectivePointBasis a idealNormOfP a = idealNormPPoint2WithErr a join2PP a b = join2ProjectivePointsWithErr a b - pToEP a = fromMaybe (error "created an infinite point when trying to convert from a Projective point to a euclidian one.") $ projectivePointToPoint2 a + pToEP a = fromMaybe (error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point.") $ projectivePointToPoint2 a vecOfP (CPPoint2 a) = a -- | A projective line in 2D space. @@ -756,7 +749,7 @@ instance Semigroup PLine2Err where infixl 9 ∨+ -- | a typed join function. join two points, returning a line. -join2ProjectivePointsWithErr ::(ProjectivePoint2 a) => a -> a -> (PLine2, UlpSum) +join2ProjectivePointsWithErr ::(ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> (PLine2, UlpSum) join2ProjectivePointsWithErr pp1 pp2 = (PLine2 res, errTotal) where @@ -784,8 +777,7 @@ eToPPoint2 (Point2 (x,y)) = res where res = makePPoint2 x y --- | Create a canonical euclidian projective point from the given coordinates, with error. --- FIXME: is there any chance of loss of precision on y? +-- | Create a canonical euclidian projective point from the given coordinates. makePPoint2 :: ℝ -> ℝ -> CPPoint2 makePPoint2 x y = pPoint where @@ -879,7 +871,9 @@ flipProjectiveLine pline = (consLikeL pline) rawRes (GVec vals) = vecOfL pline eToPLine2WithErr :: LineSeg -> (PLine2, UlpSum) -eToPLine2WithErr l1 = pLineFromEndpointsWithErr (startPoint l1) (endPoint l1) +eToPLine2WithErr l1 = (res, resErr) + where + (res, resErr) = join2PP (eToPPoint2 $ startPoint l1) (eToPPoint2 $ endPoint l1) pLineFromEndpointsWithErr :: Point2 -> Point2 -> (PLine2, UlpSum) pLineFromEndpointsWithErr start stop = (res, resErr) diff --git a/Graphics/Slicer/Math/Skeleton/Line.hs b/Graphics/Slicer/Math/Skeleton/Line.hs index b2b514569..afc4af85d 100644 --- a/Graphics/Slicer/Math/Skeleton/Line.hs +++ b/Graphics/Slicer/Math/Skeleton/Line.hs @@ -42,7 +42,7 @@ import Graphics.Slicer.Math.Intersections (intersectionOf) import Graphics.Slicer.Math.Skeleton.Face (Face(Face)) -import Graphics.Slicer.Math.Lossy (eToNPLine2, eToPLine2, distanceCPPointToNPLine, translatePLine2, pToEPoint2) +import Graphics.Slicer.Math.Lossy (eToNPLine2, eToPLine2, distancePPointToPLine, translatePLine2, pToEPoint2) import Graphics.Slicer.Math.PGA (PLine2, pLineIsLeft) @@ -92,10 +92,10 @@ addLineSegsToFace distance insets face@(Face edge firstArc midArcs@(Slist rawMid -- | what is the distance from the edge to the place we can no longer place lines. distanceUntilEnd = case midArcs of - (Slist [] 0) -> distanceCPPointToNPLine (intersectionOf firstArc lastArc) (eToNPLine2 edge) + (Slist [] 0) -> distancePPointToPLine (intersectionOf firstArc lastArc) (eToNPLine2 edge) (Slist [oneArc] 1) -> if firstArcLonger - then distanceCPPointToNPLine (intersectionOf firstArc oneArc) (eToNPLine2 edge) - else distanceCPPointToNPLine (intersectionOf oneArc lastArc) (eToNPLine2 edge) + then distancePPointToPLine (intersectionOf firstArc oneArc) (eToNPLine2 edge) + else distancePPointToPLine (intersectionOf oneArc lastArc) (eToNPLine2 edge) (Slist _ _) -> closestArcDistance ----------------------------------------------------------- @@ -106,7 +106,7 @@ addLineSegsToFace distance insets face@(Face edge firstArc midArcs@(Slist rawMid [] -> error "no remains for an nSideRemainder?" -- | Find the closest point where two of our arcs intersect, relative to our side. - arcIntersections = initSafe $ mapWithFollower (\a b -> (distanceCPPointToNPLine (intersectionOf a b) (eToNPLine2 edge), (a, b))) $ [firstArc] <> rawMidArcs <> [lastArc] + arcIntersections = initSafe $ mapWithFollower (\a b -> (distancePPointToPLine (intersectionOf a b) (eToNPLine2 edge), (a, b))) $ [firstArc] <> rawMidArcs <> [lastArc] findClosestArc :: (ℝ, (PLine2, PLine2)) findClosestArc = case sortOn fst arcIntersections of [] -> error "empty arcIntersections?" @@ -140,13 +140,13 @@ addLineSegsToFace distance insets face@(Face edge firstArc midArcs@(Slist rawMid midArc = case midArcs of (Slist [oneArc] 1) -> oneArc (Slist _ _) -> error $ "evaluated midArc with the wrong insets of items\nd: " <> show distance <> "\nn: " <> show insets <> "\nFace: " <> show face <> "\n" - threeSideRemainder = if distanceCPPointToNPLine (intersectionOf firstArc midArc) (eToNPLine2 edge) /= distanceCPPointToNPLine (intersectionOf midArc lastArc) (eToNPLine2 edge) + threeSideRemainder = if distancePPointToPLine (intersectionOf firstArc midArc) (eToNPLine2 edge) /= distancePPointToPLine (intersectionOf midArc lastArc) (eToNPLine2 edge) then subRemains else Nothing (subSides, subRemains) = if firstArcLonger then addLineSegsToFace distance insets (Face finalSide firstArc (slist []) midArc) else addLineSegsToFace distance insets (Face finalSide midArc (slist []) lastArc) - firstArcLonger = distanceCPPointToNPLine (intersectionOf firstArc midArc) (eToNPLine2 edge) > distanceCPPointToNPLine (intersectionOf midArc lastArc) (eToNPLine2 edge) + firstArcLonger = distancePPointToPLine (intersectionOf firstArc midArc) (eToNPLine2 edge) > distancePPointToPLine (intersectionOf midArc lastArc) (eToNPLine2 edge) ---------------------------------------------- -- functions only used by a three-sided n-gon. ---------------------------------------------- diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index a7389584a..f19f49f0d 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -59,7 +59,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(GEZero, GEPlu import Graphics.Slicer.Math.Lossy (angleBetween, canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenPLines, distancePPointToPLine, eToCPPoint2, eToPLine2, getFirstArc, join2PPoint2, normalizePLine2, pPointOnPerp) -- Our 2D Projective Geometric Algebra library. -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), canonicalize, pPointBetweenPPointsWithErr, distanceBetweenPPointsWithErr, distanceCPPointToNPLineWithErr, eToPPoint2, pLineIntersectionWithErr, translateL, translateRotatePPoint2, angleBetweenWithErr, flipL, join2PP, makePPoint2, normalize, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, pLineFromEndpointsWithErr, distancePPointToPLineWithErr, pPointOnPerpWithErr, outOf, pPointOf, ulpOfOut, outputIntersectsLineSeg, pPointBetweenPPointsWithErr) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), canonicalize, pPointBetweenPPointsWithErr, distanceBetweenPPointsWithErr, distancePPointToPLineWithErr, eToPPoint2, pLineIntersectionWithErr, translateL, translateRotatePPoint2, angleBetweenWithErr, flipL, join2PP, makePPoint2, normalize, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, pLineFromEndpointsWithErr, distancePPointToPLineWithErr, pPointOnPerpWithErr, outOf, pPointOf, ulpOfOut, outputIntersectsLineSeg, pPointBetweenPPointsWithErr) -- Our Contour library. import Graphics.Slicer.Math.Contour (contourContainsContour, getContours, pointsOfContour, numPointsOfContour, justOneContourFrom, lineSegsOfContour, makeLineSegContour, makePointContour, insideIsLeft, innerContourPoint, firstPointPairOfContour, firstLineSegOfContour) @@ -1225,8 +1225,8 @@ prop_PLineWithinErrRange1 x1 y1 rawX2 rawY2 <> "PPoint1: " <> show pPoint1 <> "\n" <> "PPoint2: " <> show pPoint2 <> "\n" -- distance1 and distance2 should be 0, in an ideal world. - (distance1, UlpSum distance1Err) = distanceCPPointToNPLineWithErr pPoint1 nPLine - (distance2, UlpSum distance2Err) = distanceCPPointToNPLineWithErr pPoint2 nPLine + (distance1, UlpSum distance1Err) = distancePPointToPLineWithErr pPoint1 nPLine + (distance2, UlpSum distance2Err) = distancePPointToPLineWithErr pPoint2 nPLine pPoint1 = makePPoint2 x1 y1 pPoint2 = makePPoint2 x2 y2 (nPLine, UlpSum nPLineErr) = normalize pLine From 3ffac1c14a81e63526c8fd4dbd725b6c176f1eed Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 16 Oct 2022 11:25:18 +0000 Subject: [PATCH 019/206] remove pLineFromEndpointsWithErr. --- Graphics/Slicer/Math/Contour.hs | 4 ++-- Graphics/Slicer/Math/Ganja.hs | 8 ++++---- Graphics/Slicer/Math/Lossy.hs | 6 +++--- Graphics/Slicer/Math/PGA.hs | 30 ++++++++++++------------------ tests/Math/PGA.hs | 8 ++++---- 5 files changed, 25 insertions(+), 31 deletions(-) diff --git a/Graphics/Slicer/Math/Contour.hs b/Graphics/Slicer/Math/Contour.hs index 5c3414869..02067d7d9 100644 --- a/Graphics/Slicer/Math/Contour.hs +++ b/Graphics/Slicer/Math/Contour.hs @@ -52,7 +52,7 @@ import Graphics.Slicer.Math.Intersections (contourIntersectionCount, noIntersect import Graphics.Slicer.Math.Lossy (join2PPoint2, pPointBetweenPPoints, pToEPoint2) -import Graphics.Slicer.Math.PGA (PPoint2, eToPPoint2, pLineFromEndpointsWithErr, pLineIsLeft, pPointOnPerpWithErr) +import Graphics.Slicer.Math.PGA (PPoint2, eToPPoint2, eToPLine2WithErr, pLineIsLeft, pPointOnPerpWithErr) -- Unapologetically ripped from ImplicitCAD. -- Added the ability to look at line segments backwards. @@ -232,7 +232,7 @@ insideIsLeft contour myMidPoint = pPointBetweenPPoints (eToPPoint2 p1) (eToPPoint2 p2) 0.5 0.5 pLineToInside = join2PPoint2 myMidPoint innerPoint innerPoint = fromJust $ innerContourPoint contour - (pline1,_) = pLineFromEndpointsWithErr p1 p2 + (pline1,_) = eToPLine2WithErr $ makeLineSeg p1 p2 -- | Find a point on the interior of a given contour, on the perpendicular bisector of the first line segment, a given distance away from the line segment. innerContourPoint :: Contour -> Maybe PPoint2 diff --git a/Graphics/Slicer/Math/Ganja.hs b/Graphics/Slicer/Math/Ganja.hs index b11139d56..3fc4e259d 100644 --- a/Graphics/Slicer/Math/Ganja.hs +++ b/Graphics/Slicer/Math/Ganja.hs @@ -114,7 +114,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (GNum(GEPlus, GEZero), GVec(GVec), import Graphics.Slicer.Math.Lossy (eToPLine2, join2PPoint2, normalizePLine2, pPointBetweenPPoints, pToEPoint2) -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), PLine2(PLine2), PPoint2(PPoint2), eToPPoint2, flipL, translateRotatePPoint2, pLineFromEndpointsWithErr, ulpOfLineSeg, outOf, pPointOf, NPLine2(NPLine2)) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), PLine2(PLine2), PPoint2(PPoint2), eToPLine2WithErr, eToPPoint2, flipL, translateRotatePPoint2, ulpOfLineSeg, outOf, pPointOf, NPLine2(NPLine2)) import Graphics.Slicer.Math.Skeleton.Concave (makeENode, getOutsideArc) @@ -671,7 +671,7 @@ randomPLine x y dx dy = fst $ randomPLineWithErr x y dx dy -- | A helper function. constructs a random PLine. randomPLineWithErr :: ℝ -> ℝ -> NonZero ℝ -> NonZero ℝ -> (PLine2, UlpSum) -randomPLineWithErr x y dx dy = pLineFromEndpointsWithErr (Point2 (x, y)) (Point2 (coerce dx, coerce dy)) +randomPLineWithErr x y dx dy = eToPLine2WithErr $ makeLineSeg (Point2 (x, y)) (Point2 (coerce dx, coerce dy)) -- | A helper function. constructs a random LineSeg. randomLineSeg :: ℝ -> ℝ -> ℝ -> ℝ -> LineSeg @@ -685,11 +685,11 @@ randomLineSegWithErr x1 y1 x2 y2 = (res, ulpSum) -- | A PLine that does not follow the X = Y line, and does not follow the other given line. randomPLineThroughOrigin :: ℝ -> ℝ -> (PLine2, UlpSum) -randomPLineThroughOrigin x y = pLineFromEndpointsWithErr (Point2 (x,y)) (Point2 (0,0)) +randomPLineThroughOrigin x y = eToPLine2WithErr $ makeLineSeg (Point2 (x,y)) (Point2 (0,0)) -- | A PLine that does not follow the X = Y line, and does not follow the other given line. randomPLineThroughPoint :: ℝ -> ℝ -> ℝ -> (PLine2, UlpSum) -randomPLineThroughPoint x y d = pLineFromEndpointsWithErr (Point2 (x,y)) (Point2 (d,d)) +randomPLineThroughPoint x y d = eToPLine2WithErr $ makeLineSeg (Point2 (x,y)) (Point2 (d,d)) -- | A line segment ending at the origin. additionally, guaranteed not to be on the X = Y line. randomLineSegFromPointNotX1Y1 :: ℝ -> ℝ -> ℝ -> (LineSeg, UlpSum) diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index ac34ef51d..1ac44b06a 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -44,9 +44,9 @@ import Prelude (($), fst) -- The numeric type in HSlice. import Graphics.Slicer.Definitions (ℝ) -import Graphics.Slicer.Math.Definitions (LineSeg, Point2) +import Graphics.Slicer.Math.Definitions (LineSeg, Point2, makeLineSeg) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PPoint2, ProjectiveLine2, ProjectivePoint2, angleBetweenWithErr, canonicalize, distanceBetweenPPointsWithErr, distanceBetweenPLinesWithErr, distancePPointToPLineWithErr, eToPLine2WithErr, eToPPoint2, getFirstArcWithErr, getInsideArcWithErr, join2PP, normalize, pLineFromEndpointsWithErr, pPointBetweenPPointsWithErr, pPointOnPerpWithErr, pToEP, translateL) +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PPoint2, ProjectiveLine2, ProjectivePoint2, angleBetweenWithErr, canonicalize, distanceBetweenPPointsWithErr, distanceBetweenPLinesWithErr, distancePPointToPLineWithErr, eToPLine2WithErr, eToPPoint2, getFirstArcWithErr, getInsideArcWithErr, join2PP, normalize, pPointBetweenPPointsWithErr, pPointOnPerpWithErr, pToEP, translateL) angleBetween :: NPLine2 -> NPLine2 -> ℝ angleBetween nPLine1 nPLine2 = fst $ angleBetweenWithErr nPLine1 nPLine2 @@ -98,7 +98,7 @@ normalizePLine2 pl = fst $ normalize pl -- | Create a projective line from a pair of euclidian points. pLineFromEndpoints :: Point2 -> Point2 -> PLine2 -pLineFromEndpoints point1 point2 = fst $ pLineFromEndpointsWithErr point1 point2 +pLineFromEndpoints point1 point2 = fst $ eToPLine2WithErr $ makeLineSeg point1 point2 pToEPoint2 :: (ProjectivePoint2 a) => a -> Point2 pToEPoint2 pp = fst $ pToEP pp diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 584d610a7..228d9a797 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -51,7 +51,6 @@ module Graphics.Slicer.Math.PGA( makePPoint2, normalize, outputIntersectsLineSeg, - pLineFromEndpointsWithErr, pLineIntersectionWithErr, pLineIsLeft, pPointBetweenPPointsWithErr, @@ -164,9 +163,9 @@ pLineIsLeft pl1 pl2 pLineIntersectionWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PPoint2, UlpSum) pLineIntersectionWithErr pl1 pl2 = (res, ulpTotal) where - (res, resErr) = meetOf2PL npl1 npl2 - (npl1, npl1Err) = normalize pl1 - (npl2, npl2Err) = normalize pl2 + (res, resErr) = meetOf2PL pl1 pl2 + (_, npl1Err) = normalize pl1 + (_, npl2Err) = normalize pl2 ulpTotal = resErr <> npl1Err <> npl2Err -- FIXME: automatically raise addVecRes to a CPPoint2 if it turns out to be canonical? @@ -309,7 +308,7 @@ translateRotatePPoint2 ppoint d rotation = PPoint2 $ translator•pvec•reverse pvec = vecOfP ppoint xLineThroughPPoint2 = (pvec ⨅ xLineVec) • pvec where - xLineVec = vecOfL $ forceBasisOfL $ fst $ pLineFromEndpointsWithErr (Point2 (0,0)) (Point2 (1,0)) + xLineVec = vecOfL $ forceBasisOfL $ fst $ eToPLine2WithErr (LineSeg (Point2 (0,0)) (Point2 (1,0))) angledLineThroughPPoint2 = vecOfL $ forceBasisOfL $ PLine2 $ rotator•xLineThroughPPoint2•reverseGVec rotator where rotator = addVecPairWithoutErr (fst $ mulScalarVecWithErr (sin $ rotation/2) pvec) (GVec [GVal (cos $ rotation/2) (singleton G0)]) @@ -371,9 +370,9 @@ outputIntersectsLineSeg source (l1, UlpSum l1Err) -- | the multiplier used to expand the hitcircle of an endpoint. ulpScale :: ℝ ulpScale = realToFrac $ ulpMultiplier * realToFrac travelUlpMul * abs (realToFrac angle + angleErr) - (angle, UlpSum angleErr) = angleBetweenWithErr npl1 npl2 - (npl1, UlpSum npl1Err) = normalize pl1 - (npl2, UlpSum npl2Err) = normalize pl2 + (angle, UlpSum angleErr) = angleBetweenWithErr pl1 pl2 + (_, UlpSum npl1Err) = normalize pl1 + (_, UlpSum npl2Err) = normalize pl2 (pl2, UlpSum pl2Err) = eToPLine2WithErr l1 -- the multiplier to account for distance between our Pointable, and where it intersects. travelUlpMul @@ -562,13 +561,13 @@ getFirstArcWithErr p1 p2 p3 where (insideArc, UlpSum insideArcErr) = getInsideArcWithErr (PLine2 side1) (PLine2 side2) (NPLine2 side1, UlpSum side1NormErr) = normalize side1Raw - (side1Raw, UlpSum side1RawErr) = pLineFromEndpointsWithErr p1 p2 + (side1Raw, UlpSum side1RawErr) = eToPLine2WithErr (LineSeg p1 p2) side1Err = side1NormErr+side1RawErr (NPLine2 side2, UlpSum side2NormErr) = normalize side2Raw - (side2Raw, UlpSum side2RawErr) = pLineFromEndpointsWithErr p2 p3 + (side2Raw, UlpSum side2RawErr) = eToPLine2WithErr (LineSeg p2 p3) side2Err = side2NormErr+side2RawErr (NPLine2 quadRes, UlpSum quadResErr) = normalize quad - (quad, UlpSum quadErr) = pLineFromEndpointsWithErr p2 $ scalePoint 0.5 $ addPoints p1 p3 + (quad, UlpSum quadErr) = eToPLine2WithErr $ LineSeg p2 $ scalePoint 0.5 $ addPoints p1 p3 {- scaleSide ps1 ps2 t v | t == True = (PLine2 scaledRes, UlpSum $ scaledUlp + scaledResUlp) @@ -690,7 +689,7 @@ class ProjectiveLine2 a where consLikeL :: a -> (GVec -> a) flipL :: a -> a forceBasisOfL :: a -> a - meetOf2PL :: a -> a -> (PPoint2, UlpSum) + meetOf2PL :: (ProjectiveLine2 b) => a -> b -> (PPoint2, UlpSum) normalize :: a -> (NPLine2, UlpSum) translateL :: a -> ℝ -> (PLine2, UlpSum) vecOfL :: a -> GVec @@ -761,7 +760,7 @@ join2ProjectivePointsWithErr pp1 pp2 = (PLine2 res, errTotal = resUlp <> pv1Ulp <> pv2Ulp -- | A typed meet function. the meeting of two lines is a point. -meet2ProjectiveLinesWithErr :: (ProjectiveLine2 a) => a -> a -> (PPoint2, UlpSum) +meet2ProjectiveLinesWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PPoint2, UlpSum) meet2ProjectiveLinesWithErr line1 line2 = (PPoint2 res, ulpSum) where @@ -875,11 +874,6 @@ eToPLine2WithErr l1 = (res, resErr) where (res, resErr) = join2PP (eToPPoint2 $ startPoint l1) (eToPPoint2 $ endPoint l1) -pLineFromEndpointsWithErr :: Point2 -> Point2 -> (PLine2, UlpSum) -pLineFromEndpointsWithErr start stop = (res, resErr) - where - (res, resErr) = join2PP (eToPPoint2 start) (eToPPoint2 stop) - -- | Get the sum of the error involved in storing the values in a given PLine2. ulpOfPLine2 :: (ProjectiveLine2 a) => a -> UlpSum ulpOfPLine2 line = UlpSum $ sum $ abs . realToFrac . doubleUlp . (\(GVal r _) -> r) <$> catMaybes diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index f19f49f0d..e1264da57 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -59,7 +59,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(GEZero, GEPlu import Graphics.Slicer.Math.Lossy (angleBetween, canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenPLines, distancePPointToPLine, eToCPPoint2, eToPLine2, getFirstArc, join2PPoint2, normalizePLine2, pPointOnPerp) -- Our 2D Projective Geometric Algebra library. -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), canonicalize, pPointBetweenPPointsWithErr, distanceBetweenPPointsWithErr, distancePPointToPLineWithErr, eToPPoint2, pLineIntersectionWithErr, translateL, translateRotatePPoint2, angleBetweenWithErr, flipL, join2PP, makePPoint2, normalize, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, pLineFromEndpointsWithErr, distancePPointToPLineWithErr, pPointOnPerpWithErr, outOf, pPointOf, ulpOfOut, outputIntersectsLineSeg, pPointBetweenPPointsWithErr) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), canonicalize, pPointBetweenPPointsWithErr, distanceBetweenPPointsWithErr, distancePPointToPLineWithErr, eToPLine2WithErr, eToPPoint2, pLineIntersectionWithErr, translateL, translateRotatePPoint2, angleBetweenWithErr, flipL, join2PP, makePPoint2, normalize, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, distancePPointToPLineWithErr, pPointOnPerpWithErr, outOf, pPointOf, ulpOfOut, outputIntersectsLineSeg, pPointBetweenPPointsWithErr) -- Our Contour library. import Graphics.Slicer.Math.Contour (contourContainsContour, getContours, pointsOfContour, numPointsOfContour, justOneContourFrom, lineSegsOfContour, makeLineSegContour, makePointContour, insideIsLeft, innerContourPoint, firstPointPairOfContour, firstLineSegOfContour) @@ -508,7 +508,7 @@ prop_QuadBisectorCrosses rawX1 rawY1 rawX2 rawY2 intersect3 = outputIntersectsLineSeg eNode (lineSeg1, lineSeg1Err) intersect4 = outputIntersectsLineSeg eNode (lineSeg2, lineSeg2Err) -- note that our bisector always intersects the origin. - (bisector, UlpSum bisectorUlp) = pLineFromEndpointsWithErr (Point2 (0,0)) (Point2 (x3,y3)) + (bisector, UlpSum bisectorUlp) = eToPLine2WithErr $ makeLineSeg (Point2 (0,0)) (Point2 (x3,y3)) (NPLine2 bisector1, UlpSum bisector1Ulp) = normalize bisector bisector1Err = bisectorUlp + bisector1Ulp bisector2 = getFirstArc (Point2 (x1,y1)) (Point2 (0,0)) (Point2 (x2,y2)) @@ -564,7 +564,7 @@ prop_QuadBisectorCrossesMultiple rawX1 rawY1 rawX2 rawY2 rawTimes intersect4 = outputIntersectsLineSeg eNode (lineSeg2, lineSeg2Err) -- note that our bisector always intersects the origin. (NPLine2 bisector1, UlpSum bisector1Ulp) = normalize bisector - (bisector, UlpSum bisectorUlp) = pLineFromEndpointsWithErr (Point2 (0,0)) (Point2 (x3,y3)) + (bisector, UlpSum bisectorUlp) = eToPLine2WithErr $ makeLineSeg (Point2 (0,0)) (Point2 (x3,y3)) bisector1Err = bisectorUlp + bisector1Ulp eNode = makeENode (Point2 (x1,y1)) (Point2 (0,0)) (Point2 (x2,y2)) -- X1, Y1 and X2 forced uniqueness. additionally, forced "not 180 degree opposition). @@ -1230,7 +1230,7 @@ prop_PLineWithinErrRange1 x1 y1 rawX2 rawY2 pPoint1 = makePPoint2 x1 y1 pPoint2 = makePPoint2 x2 y2 (nPLine, UlpSum nPLineErr) = normalize pLine - (pLine, UlpSum ulpPLine) = pLineFromEndpointsWithErr (Point2 (x1,y1)) (Point2 (x2,y2)) + (pLine, UlpSum ulpPLine) = eToPLine2WithErr $ makeLineSeg (Point2 (x1,y1)) (Point2 (x2,y2)) ulpTotal1 = ulpPLine + distance1Err + nPLineErr ulpTotal2 = ulpPLine + distance2Err + nPLineErr -- make sure we do not try to create a 0 length line segment. From 715f19ed852b613f0a4f8ccdaa9729f142951443 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 16 Oct 2022 16:02:10 +0000 Subject: [PATCH 020/206] create Arcs.hs, and move arc calculating code there. --- Graphics/Slicer/Math/Arcs.hs | 81 ++++++++++++++++++++ Graphics/Slicer/Math/Intersections.hs | 8 +- Graphics/Slicer/Math/Lossy.hs | 4 +- Graphics/Slicer/Math/PGA.hs | 63 +++------------ Graphics/Slicer/Math/Skeleton/Concave.hs | 4 +- Graphics/Slicer/Math/Skeleton/Definitions.hs | 14 ++-- hslice.cabal | 1 + 7 files changed, 109 insertions(+), 66 deletions(-) create mode 100644 Graphics/Slicer/Math/Arcs.hs diff --git a/Graphics/Slicer/Math/Arcs.hs b/Graphics/Slicer/Math/Arcs.hs new file mode 100644 index 000000000..ea3a8ce00 --- /dev/null +++ b/Graphics/Slicer/Math/Arcs.hs @@ -0,0 +1,81 @@ +{- ORMOLU_DISABLE -} +{- + - Copyright 2021 Julia Longtin + - + - This program is free software: you can redistribute it and/or modify + - it under the terms of the GNU Affero General Public License as published by + - the Free Software Foundation, either version 3 of the License, or + - (at your option) any later version. + - + - This program is distributed in the hope that it will be useful, + - but WITHOUT ANY WARRANTY; without even the implied warranty of + - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + - GNU Affero General Public License for more details. + + - You should have received a copy of the GNU Affero General Public License + - along with this program. If not, see . + -} + +{- + This file contains code for calculating the inside and outside bisectors of two lines. +-} + +module Graphics.Slicer.Math.Arcs (getFirstArcWithErr, getInsideArcWithErr) where + +import Prelude (Bool, ($), (>), (<=), (<>), (==), (&&), (||), (+), error, mempty, otherwise, realToFrac, show) + +import Graphics.Slicer.Definitions (ℝ) + +import Graphics.Slicer.Math.Definitions (Point2, LineSeg(LineSeg), addPoints, distance, makeLineSeg, scalePoint) + +import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum), addVecPairWithErr, sumErrVals, ulpVal) + +import Graphics.Slicer.Math.Intersections (isCollinear, isAntiCollinear, isParallel, isAntiParallel, intersectionOf) + +import Graphics.Slicer.Math.PGA (PLine2Err(PLine2Err), PPoint2Err, ProjectiveLine2, PLine2(PLine2), ProjectivePoint2, angleBetweenWithErr, canonicalize, distanceBetweenPPointsWithErr, eToPLine2WithErr, flipL, join2PP, normalize, vecOfL) + +-- | Get a PLine in the direction of the inside of the contour, at the angle bisector of the intersection of the line segment, and another segment from the end of the given line segment, toward the given point. +-- Note that we normalize our output, but return it as a PLine2. this is safe, because double normalization (if it happens) only raises the ULP. +getFirstArcWithErr :: Point2 -> Point2 -> Point2 -> (PLine2, UlpSum) +getFirstArcWithErr p1 p2 p3 + -- since we hawe two equal sides, we can draw a point ot the other side of the quad, and use it for constructing. + | distance p2 p1 == distance p2 p3 = (PLine2 $ vecOfL quadRes, UlpSum $ quadErr + quadResErr) + {- + | distance p2 p1 > distance p2 p3 = scaleSide p1 p3 True (distance p2 p1 / distance p2 p3) + | otherwise = scaleSide p3 p1 True (distance p2 p3 / distance p2 p1) + -} + | otherwise = (insideArc, UlpSum $ side1Err + side2Err + insideArcErr) + where + (insideArc, UlpSum insideArcErr) = getInsideArcWithErr side1 side2 + (side1, UlpSum side1NormErr) = normalize side1Raw + (side1Raw, UlpSum side1RawErr) = eToPLine2WithErr (LineSeg p1 p2) + side1Err = side1NormErr+side1RawErr + (side2, UlpSum side2NormErr) = normalize side2Raw + (side2Raw, UlpSum side2RawErr) = eToPLine2WithErr (LineSeg p2 p3) + side2Err = side2NormErr+side2RawErr + (quadRes, UlpSum quadResErr) = normalize quad + (quad, UlpSum quadErr) = eToPLine2WithErr $ LineSeg p2 $ scalePoint 0.5 $ addPoints p1 p3 + {- + scaleSide ps1 ps2 t v + | t == True = (PLine2 scaledRes, UlpSum $ scaledUlp + scaledResUlp) + | otherwise = (flipPLine2 $ PLine2 scaledRes, UlpSum $ scaledUlp + scaledResUlp) + where + (NPLine2 scaledRes, UlpSum scaledResUlp) = normalizePLine2WithErr scaled + -- FIXME: poor ULP tracking on this linear math. + (scaled, UlpSum scaledUlp) = pLineFromEndpointsWithErr p2 $ scalePoint 0.5 $ addPoints ps1 $ addPoints p2 $ scalePoint v $ addPoints ps2 $ negatePoint p2 + -} + +-- | Get a PLine along the angle bisector of the intersection of the two given line segments, pointing in the 'acute' direction. +-- Note that we normalize our output, but don't bother normalizing our input lines, as the ones we output and the ones getFirstArcWithErr outputs are normalized. +-- Note that we know that the inside is to the right of the first line given, and that the first line points toward the intersection. +getInsideArcWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PLine2, UlpSum) +getInsideArcWithErr line1 line2 +-- | pline1 == pline2 = error "need to be able to return two PLines." + | otherwise = (PLine2 $ vecOfL normRes, ulpSum) + where + ulpSum = resUlp <> sumErrVals addVecErr + (normRes, resUlp) = normalize $ PLine2 $ addVecRes + (addVecRes, addVecErr) = addVecPairWithErr flippedPV1 pv2 + flippedPV1 = vecOfL $ flipL line1 + pv2 = vecOfL line2 + diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index e453cd63e..186a63c0f 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -20,7 +20,7 @@ module Graphics.Slicer.Math.Intersections (getMotorcycleSegSetIntersections, getMotorcycleContourIntersections, contourIntersectionCount, getPLine2Intersections, intersectionOf, intersectionBetween, noIntersection, isCollinear, isAntiCollinear, isParallel, isAntiParallel) where -import Prelude (Bool, Either(Left,Right), error, otherwise, show, (&&), (<>), ($), (<$>), (/=), (.), zip, Int, (<), (*), (||), (==), length, odd, realToFrac) +import Prelude (Bool, Either(Left,Right), error, otherwise, show, (&&), (<>), ($), (<$>), (/=), (.), zip, Int, (<), (*), (||), (==), fst, length, odd, realToFrac) import Data.Maybe( Maybe(Just,Nothing), catMaybes, isJust, fromJust) @@ -36,9 +36,7 @@ import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, mapWithNeighb import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum)) -import Graphics.Slicer.Math.Lossy (pToEPoint2) - -import Graphics.Slicer.Math.PGA (CPPoint2, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), Intersection(HitEndPoint, HitStartPoint, NoIntersection), PLine2, intersectsWith, distanceBetweenPLinesWithErr, outputIntersectsLineSeg, plinesIntersectIn, ulpOfLineSeg) +import Graphics.Slicer.Math.PGA (CPPoint2, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), Intersection(HitEndPoint, HitStartPoint, NoIntersection), PLine2, intersectsWith, distanceBetweenPLinesWithErr, outputIntersectsLineSeg, plinesIntersectIn, pToEP, ulpOfLineSeg) import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle)) @@ -103,7 +101,7 @@ getPLine2Intersections pLine c getPoints vs = getPoint <$> vs where getPoint (_, Left v) = v - getPoint (_, Right v) = pToEPoint2 v + getPoint (_, Right v) = fst $ pToEP v -- | filter the intersections given. -- The purpose of this function is to ensure we only count the crossing of a line (segment) across a contour's edge more than once. so if it hits a sttartpoint, make sure we don't count the endpoint.. etc. diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index 1ac44b06a..a9fdfac54 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -46,7 +46,9 @@ import Graphics.Slicer.Definitions (ℝ) import Graphics.Slicer.Math.Definitions (LineSeg, Point2, makeLineSeg) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PPoint2, ProjectiveLine2, ProjectivePoint2, angleBetweenWithErr, canonicalize, distanceBetweenPPointsWithErr, distanceBetweenPLinesWithErr, distancePPointToPLineWithErr, eToPLine2WithErr, eToPPoint2, getFirstArcWithErr, getInsideArcWithErr, join2PP, normalize, pPointBetweenPPointsWithErr, pPointOnPerpWithErr, pToEP, translateL) +import Graphics.Slicer.Math.Arcs (getFirstArcWithErr, getInsideArcWithErr) + +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PPoint2, ProjectiveLine2, ProjectivePoint2, angleBetweenWithErr, canonicalize, distanceBetweenPPointsWithErr, distanceBetweenPLinesWithErr, distancePPointToPLineWithErr, eToPLine2WithErr, eToPPoint2, join2PP, normalize, pPointBetweenPPointsWithErr, pPointOnPerpWithErr, pToEP, translateL) angleBetween :: NPLine2 -> NPLine2 -> ℝ angleBetween nPLine1 nPLine2 = fst $ angleBetweenWithErr nPLine1 nPLine2 diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 228d9a797..00357781b 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -30,8 +30,10 @@ module Graphics.Slicer.Math.PGA( NPLine2(NPLine2), PIntersection (PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), PLine2(PLine2), + PLine2Err(PLine2Err), Pointable(canPoint, pPointOf, ePointOf), PPoint2(PPoint2), + PPoint2Err, ProjectiveLine2, ProjectivePoint2, angleBetweenWithErr, @@ -43,8 +45,6 @@ module Graphics.Slicer.Math.PGA( eToPLine2WithErr, eToPPoint2, flipL, - getInsideArcWithErr, - getFirstArcWithErr, intersectsWith, intersectsWithErr, join2PP, @@ -61,7 +61,8 @@ module Graphics.Slicer.Math.PGA( translateL, translateRotatePPoint2, ulpOfLineSeg, - ulpOfPLine2 + ulpOfPLine2, + vecOfL ) where import Prelude (Bool, Eq((==),(/=)), Monoid(mempty), Semigroup((<>)), Show(show), Ord, ($), (*), (-), (>=), (&&), (<$>), otherwise, signum, (>), (<=), (+), sqrt, negate, (/), (||), (<), abs, error, sin, cos, realToFrac, fst, sum, (.)) @@ -88,7 +89,7 @@ import Numeric.Rounded.Hardware (Rounded, RoundingMode(TowardInf, TowardNegInf)) import Graphics.Slicer.Definitions (ℝ) -import Graphics.Slicer.Math.Definitions (Point2(Point2), LineSeg(LineSeg), addPoints, scalePoint, startPoint, endPoint, distance) +import Graphics.Slicer.Math.Definitions (Point2(Point2), LineSeg(LineSeg), addPoints, startPoint, endPoint, distance) import Graphics.Slicer.Math.GeometricAlgebra (ErrVal, GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎣+), (⎤+), (⨅), (⨅+), (∧), (•), addErr, addValWithoutErr, addVecPairWithErr, addVecPairWithoutErr, divVecScalarWithErr, eValOf, getVal, mulScalarVecWithErr, scalarPart, sumErrVals, ulpVal, valOf) @@ -547,51 +548,6 @@ combineConsecutiveLineSegs lines = case lines of sameLineSeg = plinesIntersectIn (fst $ eToPLine2WithErr l1) (fst $ eToPLine2WithErr l2) == PCollinear sameMiddlePoint = p2 == addPoints p1 s1 --- | Get a PLine in the direction of the inside of the contour, at the angle bisector of the intersection of the line segment, and another segment from the end of the given line segment, toward the given point. --- Note that we normalize our output, but return it as a PLine2. this is safe, because double normalization (if it happens) only raises the ULP. -getFirstArcWithErr :: Point2 -> Point2 -> Point2 -> (PLine2, UlpSum) -getFirstArcWithErr p1 p2 p3 - -- since we hawe two equal sides, we can draw a point ot the other side of the quad, and use it for constructing. - | distance p2 p1 == distance p2 p3 = (PLine2 quadRes, UlpSum $ quadErr + quadResErr) - {- - | distance p2 p1 > distance p2 p3 = scaleSide p1 p3 True (distance p2 p1 / distance p2 p3) - | otherwise = scaleSide p3 p1 True (distance p2 p3 / distance p2 p1) - -} - | otherwise = (insideArc, UlpSum $ side1Err + side2Err + insideArcErr) - where - (insideArc, UlpSum insideArcErr) = getInsideArcWithErr (PLine2 side1) (PLine2 side2) - (NPLine2 side1, UlpSum side1NormErr) = normalize side1Raw - (side1Raw, UlpSum side1RawErr) = eToPLine2WithErr (LineSeg p1 p2) - side1Err = side1NormErr+side1RawErr - (NPLine2 side2, UlpSum side2NormErr) = normalize side2Raw - (side2Raw, UlpSum side2RawErr) = eToPLine2WithErr (LineSeg p2 p3) - side2Err = side2NormErr+side2RawErr - (NPLine2 quadRes, UlpSum quadResErr) = normalize quad - (quad, UlpSum quadErr) = eToPLine2WithErr $ LineSeg p2 $ scalePoint 0.5 $ addPoints p1 p3 - {- - scaleSide ps1 ps2 t v - | t == True = (PLine2 scaledRes, UlpSum $ scaledUlp + scaledResUlp) - | otherwise = (flipPLine2 $ PLine2 scaledRes, UlpSum $ scaledUlp + scaledResUlp) - where - (NPLine2 scaledRes, UlpSum scaledResUlp) = normalizePLine2WithErr scaled - -- FIXME: poor ULP tracking on this linear math. - (scaled, UlpSum scaledUlp) = pLineFromEndpointsWithErr p2 $ scalePoint 0.5 $ addPoints ps1 $ addPoints p2 $ scalePoint v $ addPoints ps2 $ negatePoint p2 - -} - --- | Get a PLine along the angle bisector of the intersection of the two given line segments, pointing in the 'acute' direction. --- Note that we normalize our output, but don't bother normalizing our input lines, as the ones we output and the ones getFirstArcWithErr outputs are normalized. --- Note that we know that the inside is to the right of the first line given, and that the first line points toward the intersection. -getInsideArcWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PLine2, UlpSum) -getInsideArcWithErr line1 line2 --- | pline1 == pline2 = error "need to be able to return two PLines." - | otherwise = (PLine2 normRes, ulpSum) - where - ulpSum = resUlp <> sumErrVals addVecErr - (NPLine2 normRes, resUlp) = normalize $ PLine2 $ addVecRes - (addVecRes, addVecErr) = addVecPairWithErr flippedPV1 pv2 - flippedPV1 = vecOfL $ flipL line1 - pv2 = vecOfL line2 - ------------------------------------------------ ----- And now draw the rest of the algebra ----- ------------------------------------------------ @@ -737,6 +693,9 @@ instance Semigroup PLine2Err where (e1 <> e2) (foldl' addErr f1 f2,foldl' addErr g1 g2) +instance Monoid PLine2Err where + mempty = PLine2Err mempty mempty mempty mempty mempty mempty + -- | The join operator in 2D PGA, which is implemented as the meet operator operating in the dual space. (∨+) :: GVec -> GVec -> (GVec, UlpSum) (∨+) a b = (vec @@ -748,7 +707,7 @@ instance Semigroup PLine2Err where infixl 9 ∨+ -- | a typed join function. join two points, returning a line. -join2ProjectivePointsWithErr ::(ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> (PLine2, UlpSum) +join2ProjectivePointsWithErr :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> (PLine2, UlpSum) join2ProjectivePointsWithErr pp1 pp2 = (PLine2 res, errTotal) where @@ -766,8 +725,8 @@ meet2ProjectiveLinesWithErr line1 line2 = (PPoint2 res, where ulpSum = sumErrVals unlikeMulErr <> sumErrVals unlikeAddErr (res, (unlikeMulErr, unlikeAddErr)) = pv1 ⎤+ pv2 - (NPLine2 pv1) = forceBasisOfL npl1 - (NPLine2 pv2) = forceBasisOfL npl2 + pv1 = vecOfL $ forceBasisOfL npl1 + pv2 = vecOfL $ forceBasisOfL npl2 (npl1,_) = normalize line1 (npl2,_) = normalize line2 diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index 2a2c04f5d..db636c469 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -50,6 +50,8 @@ import Slist as SL (head, last, tail) import Graphics.Implicit.Definitions (ℝ) +import Graphics.Slicer.Math.Arcs (getFirstArcWithErr) + import Graphics.Slicer.Math.Contour (lineSegsOfContour) import Graphics.Slicer.Math.Definitions (Contour, LineSeg(LineSeg), Point2, endPoint, mapWithFollower, fudgeFactor, startPoint, distance) @@ -60,7 +62,7 @@ import Graphics.Slicer.Math.Intersections (intersectionOf, intersectionBetween, import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, distancePPointToPLine, eToPLine2, getInsideArc, join2CPPoint2, normalizePLine2) -import Graphics.Slicer.Math.PGA (Arcable(hasArc, outOf), Pointable(canPoint, pPointOf), PLine2(PLine2), ProjectivePoint2, CPPoint2(CPPoint2), PPoint2(PPoint2), canonicalize, flipL, getFirstArcWithErr, distanceBetweenPPointsWithErr, pLineIsLeft, angleBetweenWithErr, distancePPointToPLineWithErr, NPLine2(NPLine2)) +import Graphics.Slicer.Math.PGA (Arcable(hasArc, outOf), Pointable(canPoint, pPointOf), PLine2(PLine2), ProjectivePoint2, CPPoint2(CPPoint2), PPoint2(PPoint2), canonicalize, flipL, distanceBetweenPPointsWithErr, pLineIsLeft, angleBetweenWithErr, distancePPointToPLineWithErr, NPLine2(NPLine2)) import Graphics.Slicer.Math.Skeleton.Definitions (ENode(ENode), ENodeSet(ENodeSet), INode(INode), INodeSet(INodeSet), NodeTree(NodeTree), concavePLines, getFirstLineSeg, getLastLineSeg, finalOutOf, firstInOf, getPairs, indexPLinesTo, insOf, lastINodeOf, linePairs, makeINode, sortedPLines, isLoop) diff --git a/Graphics/Slicer/Math/Skeleton/Definitions.hs b/Graphics/Slicer/Math/Skeleton/Definitions.hs index 6b55c60cc..3ca8e41ea 100644 --- a/Graphics/Slicer/Math/Skeleton/Definitions.hs +++ b/Graphics/Slicer/Math/Skeleton/Definitions.hs @@ -53,9 +53,8 @@ import Slist.Type (Slist(Slist)) import Graphics.Implicit.Definitions (ℝ) -import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, eToPLine2, pToEPoint2) -import Graphics.Slicer.Math.PGA (plinesIntersectIn, PIntersection(IntersectsIn), flipL, PLine2(PLine2), pLineIsLeft, distanceBetweenPPointsWithErr, Pointable(canPoint, pPointOf, ePointOf), Arcable(hasArc, outOf, ulpOfOut, outUlpMag), CPPoint2(CPPoint2), PPoint2(PPoint2), eToPPoint2) +import Graphics.Slicer.Math.PGA (plinesIntersectIn, PIntersection(IntersectsIn), flipL, PLine2(PLine2), pLineIsLeft, distanceBetweenPPointsWithErr, Pointable(canPoint, pPointOf, ePointOf), Arcable(hasArc, outOf, ulpOfOut, outUlpMag), CPPoint2(CPPoint2), PPoint2(PPoint2), canonicalize, eToPLine2WithErr, eToPPoint2, pToEP, vecOfL) import Graphics.Slicer.Math.Definitions (Contour, LineSeg(LineSeg), Point2, mapWithFollower, fudgeFactor, startPoint, distance, endPoint, lineSegsOfContour, makeLineSeg) @@ -126,7 +125,7 @@ instance Pointable INode where where distanceWithinErr a b = res < realToFrac err where - (res, UlpSum err) = distanceBetweenPPointsWithErr (canonicalizePPoint2 a) (canonicalizePPoint2 b) + (res, UlpSum err) = distanceBetweenPPointsWithErr (fst $ canonicalize a) (fst $ canonicalize b) allPLines = if hasArc iNode then slist $ nub $ outOf iNode : firstPLine : secondPLine : rawPLines else slist $ nub $ firstPLine : secondPLine : rawPLines @@ -134,7 +133,7 @@ instance Pointable INode where where saneIntersect (IntersectsIn a _) = Just $ (\(CPPoint2 v) -> PPoint2 v) a saneIntersect _ = Nothing - ePointOf a = pToEPoint2 $ pPointOf a + ePointOf a = fst $ pToEP $ pPointOf a -- Produce a list of the inputs to a given INode. insOf :: INode -> [PLine2] @@ -316,11 +315,12 @@ ancestorsOf (INodeSet generations) -- | Examine two line segments that are part of a Contour, and determine if they are concave toward the interior of the Contour. if they are, construct a PLine2 bisecting them, pointing toward the interior of the Contour. concavePLines :: LineSeg -> LineSeg -> Maybe PLine2 concavePLines seg1 seg2 - | Just True == pLineIsLeft (eToPLine2 seg1) (eToPLine2 seg2) = Just $ PLine2 $ addVecPair pv1 pv2 + | Just True == pLineIsLeft (fst $ eToPLine2WithErr seg1) (fst $ eToPLine2WithErr seg2) = Just $ PLine2 $ addVecPair pv1 pv2 | otherwise = Nothing where - (PLine2 pv1) = eToPLine2 seg1 - (PLine2 pv2) = flipL $ eToPLine2 seg2 + (PLine2 pv1,_) = eToPLine2WithErr seg1 + pv2 = vecOfL $ flipL pl2 + (pl2,_) = eToPLine2WithErr seg2 -- | check if an INodeSet is empty. hasNoINodes :: INodeSet -> Bool diff --git a/hslice.cabal b/hslice.cabal index 6fb2e55d4..9effe95fb 100644 --- a/hslice.cabal +++ b/hslice.cabal @@ -26,6 +26,7 @@ library Graphics.Slicer.Machine.Contour Graphics.Slicer.Mechanics.Definitions Graphics.Slicer.Machine.GCode + Graphics.Slicer.Math.Arcs Graphics.Slicer.Math.CheckFacets Graphics.Slicer.Math.Contour Graphics.Slicer.Math.Definitions From d57dc316bbc0582eefa4e4fd8fc386582e71d4d4 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 16 Oct 2022 19:29:01 +0000 Subject: [PATCH 021/206] separate Primitive operations from complex operations. --- Graphics/Slicer/Math/PGA.hs | 375 +----------------------------------- hslice.cabal | 1 + 2 files changed, 11 insertions(+), 365 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 00357781b..c44be540d 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -28,7 +28,7 @@ module Graphics.Slicer.Math.PGA( CPPoint2(CPPoint2), Intersection(HitStartPoint, HitEndPoint, NoIntersection), NPLine2(NPLine2), - PIntersection (PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), + PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, pPointOf, ePointOf), @@ -65,11 +65,7 @@ module Graphics.Slicer.Math.PGA( vecOfL ) where -import Prelude (Bool, Eq((==),(/=)), Monoid(mempty), Semigroup((<>)), Show(show), Ord, ($), (*), (-), (>=), (&&), (<$>), otherwise, signum, (>), (<=), (+), sqrt, negate, (/), (||), (<), abs, error, sin, cos, realToFrac, fst, sum, (.)) - -import GHC.Generics (Generic) - -import Control.DeepSeq (NFData) +import Prelude (Bool, Eq((==),(/=)), Monoid(mempty), Semigroup((<>)), Show(show), ($), (*), (-), (>=), (&&), (<$>), otherwise, signum, (>), (<=), (+), negate, (/), (||), (<), abs, error, sin, cos, realToFrac, fst, sum, (.)) import Data.Bits.Floating.Ulp (doubleUlp) @@ -77,11 +73,11 @@ import Data.Either (Either(Left, Right)) import Data.List (foldl') -import Data.List.Ordered (sort, foldt) +import Data.List.Ordered (foldt) -import Data.Maybe (Maybe(Just, Nothing), catMaybes, fromJust, fromMaybe, isNothing, maybeToList) +import Data.Maybe (Maybe(Just, Nothing), catMaybes, fromJust, isNothing, maybeToList) -import Data.Set (Set, singleton, fromList, elems) +import Data.Set (singleton, fromList) import Safe (lastMay, initSafe) @@ -91,10 +87,12 @@ import Graphics.Slicer.Definitions (ℝ) import Graphics.Slicer.Math.Definitions (Point2(Point2), LineSeg(LineSeg), addPoints, startPoint, endPoint, distance) -import Graphics.Slicer.Math.GeometricAlgebra (ErrVal, GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎣+), (⎤+), (⨅), (⨅+), (∧), (•), addErr, addValWithoutErr, addVecPairWithErr, addVecPairWithoutErr, divVecScalarWithErr, eValOf, getVal, mulScalarVecWithErr, scalarPart, sumErrVals, ulpVal, valOf) +import Graphics.Slicer.Math.GeometricAlgebra (GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎣+), (⎤+), (⨅), (⨅+), (∧), (•), addValWithoutErr, addVecPairWithErr, addVecPairWithoutErr, getVal, mulScalarVecWithErr, scalarPart, sumErrVals, ulpVal, valOf) import Graphics.Slicer.Math.Line (combineLineSegs) +import Graphics.Slicer.Math.PGAPrimitives(Arcable(hasArc,outOf, outUlpMag, ulpOfOut), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(flipL, forceBasisOfL, meetOf2PL, normalize, normOfL, translateL, vecOfL), ProjectivePoint2(canonicalize, forceBasisOfP, idealNormOfP, join2PP, pToEP, vecOfP)) + -- Our 2D plane coresponds to a Clifford algebra of 2,0,1. ------------------------------------------------------------- @@ -191,7 +189,7 @@ distancePPointToPLineWithErr point line | valOf 0 foundVal == 0 = error "attempted to get the distance of an ideal point." | otherwise = (res, ulpTotal) where - (res, _) = normOfPLine2WithErr newPLine + (res, _) = normOfL newPLine (newPLine, newPLineErr) = join2PP point linePoint (perpLine, (plMulErr,plAddErr))= lvec ⨅+ npvec lvec = vecOfL $ forceBasisOfL (PLine2 nplvec) @@ -223,7 +221,7 @@ pPointsOnSameSideOfPLine point1 point2 line distanceBetweenPPointsWithErr :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> (ℝ, UlpSum) distanceBetweenPPointsWithErr point1 point2 = (res, ulpTotal) where - (res, _) = normOfPLine2WithErr newPLine + (res, _) = normOfL newPLine (newPLine, newPLineUlp) = join2PP cpoint1 cpoint2 ulpTotal = newPLineUlp -- resErr -- <> PLine2Err _ _ _ _ _ newPLineUlp (cpoint1, _) = canonicalize point1 @@ -290,18 +288,6 @@ pPointOnPerpWithErr line ppoint d = (PPoint2 res, gaIErr = UlpSum $ abs $ realToFrac $ doubleUlp $ d/2 ulpTotal = sumErrVals plMulErr <> sumErrVals plAddErr <> gaIErr <>lErr --- | Translate a line a given distance along it's perpendicular bisector. --- Abuses the property that translation of a line is expressed on the GEZero component. -translateProjectiveLine2WithErr :: (ProjectiveLine2 a) => a -> ℝ -> (PLine2, PLine2Err) -translateProjectiveLine2WithErr line d = (PLine2 res, nErr <> PLine2Err resUlp mempty mempty mempty tUlp mempty) - where - (res, resUlp) = addVecPairWithErr m $ vecOfL line - m = GVec [GVal tAdd (singleton (GEZero 1))] - -- the amount to add to the GEZero 1 component. - tAdd = d * n - tUlp = UlpSum $ abs $ realToFrac $ doubleUlp tAdd - (n, nErr) = normOfPLine2WithErr line - -- | Translate a point a given distance away from where it is, rotating it a given amount clockwise (in radians) around it's original location, with 0 degrees being aligned to the X axis. translateRotatePPoint2 :: (ProjectivePoint2 a) => a -> ℝ -> ℝ -> PPoint2 translateRotatePPoint2 ppoint d rotation = PPoint2 $ translator•pvec•reverseGVec translator @@ -552,184 +538,6 @@ combineConsecutiveLineSegs lines = case lines of ----- And now draw the rest of the algebra ----- ------------------------------------------------ --- | A projective point in 2D space. -newtype PPoint2 = PPoint2 GVec - deriving (Eq, Ord, Generic, NFData, Show) - --- | A canonicalized projective point in 2D space. -newtype CPPoint2 = CPPoint2 GVec - deriving (Eq, Generic, NFData, Show) - --- | the error accumulated when calculating a projective point. -data PPoint2Err = - PPoint2Err - -- MeetErr. max error amounts while meeting two PLines to find this point. divided into add err, and multiply err. - ([ErrVal], [ErrVal]) - -- CanonicalizeErr. error caused by the divide used during canonicalization of a point. - [ErrVal] - -- AddErr. error created when adding two points to create a third point. - [ErrVal] - -- WeighedStartErr. error created when scaling one of the two input points used to create this point. - [ErrVal] - -- WeighedStopErr. error created when scaling one of the two input points used to create this point. - [ErrVal] - -- angle between the two input lines, when we generate this point via intersecting two lines. - ℝ - -- angleUnlikeErr - the error of the unlike operation that generates the angle in the previous field. - ([ErrVal], [ErrVal]) - deriving (Eq, Show) - -instance Semigroup PPoint2Err where - (<>) (PPoint2Err (a1,b1) c1 d1 e1 f1 g1 (h1,i1)) (PPoint2Err (a2,b2) c2 d2 e2 f2 g2 (h2,i2)) = - PPoint2Err - (foldl' addErr a1 a2, foldl' addErr b1 b2) - (foldl' addErr c1 c2) - (foldl' addErr d1 d2) - (foldl' addErr e1 e2) - (foldl' addErr f1 f2) - (g1 <> g2) - (foldl' addErr h1 h2, foldl' addErr i1 i2) - -instance Monoid PPoint2Err where - mempty = PPoint2Err mempty mempty mempty mempty mempty mempty mempty - --- | Can this node be resolved into a point in 2d space? -class Pointable a where - canPoint :: a -> Bool - pPointOf :: a -> PPoint2 - ePointOf :: a -> Point2 - --- | does this node have an output (resulting) pLine? -class Arcable a where - hasArc :: a -> Bool - outOf :: a -> PLine2 - ulpOfOut :: a -> UlpSum - outUlpMag :: a -> ℝ - -class ProjectivePoint2 a where - canonicalize :: a -> (CPPoint2, UlpSum) - consLikeP :: a -> (GVec -> a) - forceBasisOfP :: a -> a - idealNormOfP :: a -> (ℝ, UlpSum) - join2PP :: (ProjectivePoint2 b) => a -> b -> (PLine2, UlpSum) - pToEP :: a -> (Point2, UlpSum) - vecOfP :: a -> GVec - -instance ProjectivePoint2 PPoint2 where - canonicalize p = (\(a, PPoint2Err _ c8izeErrs _ _ _ _ _) -> (a,sumPPointErrs c8izeErrs)) $ canonicalizePPoint2WithErr p - consLikeP (PPoint2 _) = PPoint2 - forceBasisOfP a = forceProjectivePointBasis a - idealNormOfP a = idealNormPPoint2WithErr a - join2PP a b = join2ProjectivePointsWithErr a b - pToEP a = fromMaybe (error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point.") $ projectivePointToPoint2 a - vecOfP (PPoint2 a) = a - -instance ProjectivePoint2 CPPoint2 where - canonicalize p = (p, mempty) - consLikeP (CPPoint2 _) = CPPoint2 - forceBasisOfP a = forceProjectivePointBasis a - idealNormOfP a = idealNormPPoint2WithErr a - join2PP a b = join2ProjectivePointsWithErr a b - pToEP a = fromMaybe (error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point.") $ projectivePointToPoint2 a - vecOfP (CPPoint2 a) = a - --- | A projective line in 2D space. -newtype PLine2 = PLine2 GVec - deriving (Eq, Generic, NFData, Show) - --- | A normalized projective line in 2D space. -newtype NPLine2 = NPLine2 GVec - deriving (Eq, Generic, NFData, Show) - -class ProjectiveLine2 a where - consLikeL :: a -> (GVec -> a) - flipL :: a -> a - forceBasisOfL :: a -> a - meetOf2PL :: (ProjectiveLine2 b) => a -> b -> (PPoint2, UlpSum) - normalize :: a -> (NPLine2, UlpSum) - translateL :: a -> ℝ -> (PLine2, UlpSum) - vecOfL :: a -> GVec - -instance ProjectiveLine2 NPLine2 where - consLikeL _ = NPLine2 - flipL l = flipProjectiveLine l - forceBasisOfL l = forceProjectiveLineBasis l - meetOf2PL l1 l2 = meet2ProjectiveLinesWithErr l1 l2 - normalize l = (l, mempty) - translateL l d = (\(r,(PLine2Err _ _ _ _ t _)) -> (r,t)) $ translateProjectiveLine2WithErr l d - vecOfL (NPLine2 v) = v - -instance ProjectiveLine2 PLine2 where - consLikeL _ = PLine2 - flipL l = flipProjectiveLine l - forceBasisOfL l = forceProjectiveLineBasis l - meetOf2PL l1 l2 = meet2ProjectiveLinesWithErr l1 l2 - normalize l = (\(b,(PLine2Err _ _ c d _ _)) -> (b,c <> d)) $ normalizePLine2WithErr l - translateL l d = (\(r,(PLine2Err _ _ _ _ t _)) -> (r,t)) $ translateProjectiveLine2WithErr l d - vecOfL (PLine2 a) = a - --- | the two types of error of a projective line. -data PLine2Err = PLine2Err - -- AddErr - [ErrVal] - -- NormalizationErr - [ErrVal] - -- NormErr - UlpSum - -- SqNormErr - UlpSum - -- Translation Error. always in GEZero 1. - UlpSum - -- Join Error. when a PLine2 is constructed via join. - ([ErrVal], [ErrVal]) - deriving (Eq, Show) - -instance Semigroup PLine2Err where - (<>) (PLine2Err a1 b1 c1 d1 e1 (f1,g1)) (PLine2Err a2 b2 c2 d2 e2 (f2,g2)) = - PLine2Err (foldl' addErr a1 a2) - (foldl' addErr b1 b2) - (c1 <> c2) - (d1 <> d2) - (e1 <> e2) - (foldl' addErr f1 f2,foldl' addErr g1 g2) - -instance Monoid PLine2Err where - mempty = PLine2Err mempty mempty mempty mempty mempty mempty - --- | The join operator in 2D PGA, which is implemented as the meet operator operating in the dual space. -(∨+) :: GVec -> GVec -> (GVec, UlpSum) -(∨+) a b = (vec - , ulpSum) - where - vec = dual2DGVec $ res - ulpSum = sumErrVals unlikeMulErr <> sumErrVals unlikeAddErr - (res, (unlikeAddErr, unlikeMulErr)) = dual2DGVec a ⎤+ dual2DGVec b -infixl 9 ∨+ - --- | a typed join function. join two points, returning a line. -join2ProjectivePointsWithErr :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> (PLine2, UlpSum) -join2ProjectivePointsWithErr pp1 pp2 = (PLine2 res, - errTotal) - where - (res,resUlp) = pv1 ∨+ pv2 - pv1 = vecOfP $ forceBasisOfP cp1 - pv2 = vecOfP $ forceBasisOfP cp2 - (cp1, pv1Ulp) = canonicalize pp1 - (cp2, pv2Ulp) = canonicalize pp2 - errTotal = resUlp <> pv1Ulp <> pv2Ulp - --- | A typed meet function. the meeting of two lines is a point. -meet2ProjectiveLinesWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PPoint2, UlpSum) -meet2ProjectiveLinesWithErr line1 line2 = (PPoint2 res, - ulpSum) - where - ulpSum = sumErrVals unlikeMulErr <> sumErrVals unlikeAddErr - (res, (unlikeMulErr, unlikeAddErr)) = pv1 ⎤+ pv2 - pv1 = vecOfL $ forceBasisOfL npl1 - pv2 = vecOfL $ forceBasisOfL npl2 - (npl1,_) = normalize line1 - (npl2,_) = normalize line2 - eToPPoint2 :: Point2 -> CPPoint2 eToPPoint2 (Point2 (x,y)) = res where @@ -741,18 +549,6 @@ makePPoint2 x y = pPoint where pPoint = CPPoint2 $ GVec $ foldl' addValWithoutErr [GVal 1 (fromList [GEPlus 1, GEPlus 2])] [ GVal (negate x) (fromList [GEZero 1, GEPlus 2]), GVal y (fromList [GEZero 1, GEPlus 1])] --- | Maybe create a euclidian point from a projective point. Will fail if the projective point is ideal. -projectivePointToPoint2 :: (ProjectivePoint2 a) => a -> Maybe (Point2, UlpSum) -projectivePointToPoint2 ppoint - | e12Val == 0 = Nothing - | otherwise = Just (Point2 (xVal, yVal), cpErrs) - where - (CPPoint2 (GVec vals), cpErrs) = canonicalize ppoint - xVal = negate $ valOf 0 $ getVal [GEZero 1, GEPlus 2] vals - yVal = valOf 0 $ getVal [GEZero 1, GEPlus 1] vals - e12Val = valOf 0 (getVal [GEPlus 1, GEPlus 2] rawVals) - (GVec rawVals) = vecOfP ppoint - -- | Reverse a vector. Really, take every value in it, and recompute it in the reverse order of the vectors (so instead of e0∧e1, e1∧e0). which has the effect of negating bi and tri-vectors. reverseGVec :: GVec -> GVec reverseGVec (GVec vals) = GVec $ foldl' addValWithoutErr [] @@ -767,67 +563,6 @@ reverseGVec (GVec vals) = GVec $ foldl' addValWithoutErr [] , GVal (negate $ valOf 0 $ getVal [GEZero 1, GEPlus 1, GEPlus 2] vals) (fromList [GEZero 1, GEPlus 1, GEPlus 2]) ] --- | get the dual of a vector. for a point, find a line, for a line, a point... -dual2DGVec :: GVec -> GVec -dual2DGVec (GVec vals) = GVec $ foldl' addValWithoutErr [] - [ - GVal ( valOf 0 $ getVal [G0] vals) (fromList [GEZero 1, GEPlus 1, GEPlus 2]) - , GVal ( valOf 0 $ getVal [GEZero 1] vals) (fromList [GEPlus 1, GEPlus 2]) - , GVal (negate $ valOf 0 $ getVal [GEPlus 1] vals) (fromList [GEZero 1, GEPlus 2]) - , GVal ( valOf 0 $ getVal [GEPlus 2] vals) (fromList [GEZero 1, GEPlus 1]) - , GVal ( valOf 0 $ getVal [GEZero 1, GEPlus 1] vals) (singleton (GEPlus 2)) - , GVal (negate $ valOf 0 $ getVal [GEZero 1, GEPlus 2] vals) (singleton (GEPlus 1)) - , GVal ( valOf 0 $ getVal [GEPlus 1, GEPlus 2] vals) (singleton (GEZero 1)) - , GVal ( valOf 0 $ getVal [GEZero 1, GEPlus 1, GEPlus 2] vals) (singleton G0) - ] - --- | perform basis coersion. ensure all of the required '0' components exist. required before using basis sensitive raw operators. -forceBasis :: [Set GNum] -> GVec -> GVec -forceBasis numsets (GVec vals) = GVec $ forceVal vals <$> sort numsets - where - forceVal :: [GVal] -> Set GNum -> GVal - forceVal has needs = GVal (valOf 0 $ getVal (elems needs) has) needs - --- | runtime basis coersion. ensure all of the '0' components exist on a Projective Line. -forceProjectiveLineBasis :: (ProjectiveLine2 a) => a -> a -forceProjectiveLineBasis line - | gnums == Just [singleton (GEZero 1), - singleton (GEPlus 1), - singleton (GEPlus 2)] = line - | otherwise = (consLikeL line) res - where - res = forceBasis [singleton (GEZero 1), singleton (GEPlus 1), singleton (GEPlus 2)] pvec - gnums = case vals of - [GVal _ g1, GVal _ g2, GVal _ g3] -> Just [g1,g2,g3] - _ -> Nothing - pvec@(GVec vals) = vecOfL line - --- | runtime basis coersion. ensure all of the '0' components exist on a Projective Point. -forceProjectivePointBasis :: (ProjectivePoint2 a) => a -> a -forceProjectivePointBasis point - | gnums == Just [fromList [GEZero 1, GEPlus 1], - fromList [GEZero 1, GEPlus 2], - fromList [GEPlus 1, GEPlus 2]] = point - | otherwise = (consLikeP point) res - where - res = forceBasis [fromList [GEZero 1, GEPlus 1], fromList [GEZero 1, GEPlus 2], fromList [GEPlus 1, GEPlus 2]] pvec - gnums = case vals of - [GVal _ g1, GVal _ g2, GVal _ g3] -> Just [g1,g2,g3] - _ -> Nothing - pvec@(GVec vals) = vecOfP point - --- | Reverse a line. same line, but pointed in the other direction. -flipProjectiveLine :: (ProjectiveLine2 a) => a -> a -flipProjectiveLine pline = (consLikeL pline) rawRes - where - rawRes = GVec $ foldl' addValWithoutErr [] - [ - GVal (negate $ valOf 0 $ getVal [GEZero 1] vals) (singleton (GEZero 1)) - , GVal (negate $ valOf 0 $ getVal [GEPlus 1] vals) (singleton (GEPlus 1)) - , GVal (negate $ valOf 0 $ getVal [GEPlus 2] vals) (singleton (GEPlus 2)) - ] - (GVec vals) = vecOfL pline - eToPLine2WithErr :: LineSeg -> (PLine2, UlpSum) eToPLine2WithErr l1 = (res, resErr) where @@ -846,56 +581,6 @@ ulpOfPLine2 line = UlpSum $ sum $ abs . realToFrac . doubleUlp . (\(GVal r _) -> ulpOfLineSeg :: LineSeg -> UlpSum ulpOfLineSeg (LineSeg (Point2 (x1,y1)) (Point2 (x2,y2))) = UlpSum $ sum $ abs . realToFrac . doubleUlp <$> [x1, y1, x2, y2] ---------------------------------------------------------------------- ----- Utillity functions that use sqrt(), or divVecScalarWithErr. ---- ---------------------------------------------------------------------- - --- | find the idealized norm of a projective point (ideal or not). -idealNormPPoint2WithErr :: (ProjectivePoint2 a) => a -> (ℝ, UlpSum) -idealNormPPoint2WithErr ppoint - | preRes == 0 = (0, mempty) - | otherwise = (res, ulpTotal) - where - res = sqrt preRes - preRes = x*x+y*y - ulpTotal = UlpSum - $ abs (realToFrac $ doubleUlp $ x*x) - + abs (realToFrac $ doubleUlp $ y*y) - + abs (realToFrac $ doubleUlp preRes) - + abs (realToFrac $ doubleUlp res) - (x,y) - | e12Val == 0 = ( negate $ valOf 0 $ getVal [GEZero 1, GEPlus 2] rawVals - , valOf 0 $ getVal [GEZero 1, GEPlus 1] rawVals) - | otherwise = (\(Point2 (x1,y1),_) -> (x1,y1)) $ pToEP ppoint - e12Val = valOf 0 (getVal [GEPlus 1, GEPlus 2] rawVals) - (GVec rawVals) = vecOfP ppoint - --- | canonicalize a euclidian point. --- Note: Normalization of euclidian points in PGA is really just canonicalization. --- Note: For precision, we go through some work to not bother dividing the GP1,GP2 component with itsself, and just substitute in the answer, as exactly 1. -canonicalizePPoint2WithErr :: (ProjectivePoint2 a, Show a) => a -> (CPPoint2, PPoint2Err) -canonicalizePPoint2WithErr point - | isNothing foundVal = error $ "tried to canonicalize an ideal point: " <> show point <> "\n" - -- Handle the ID case. - | valOf 1 foundVal == 1 = (CPPoint2 $ GVec rawVals, mempty) - | otherwise = (res, PPoint2Err mempty scaledErrs mempty mempty mempty mempty mempty) - where - res = CPPoint2 $ GVec $ foldl' addValWithoutErr [] - $ ( if isNothing (getVal [GEZero 1, GEPlus 1] scaledVals) - then [] - else [GVal (valOf 0 $ getVal [GEZero 1, GEPlus 1] scaledVals) (fromList [GEZero 1, GEPlus 1])] - ) - <> ( if isNothing (getVal [GEZero 1, GEPlus 2] scaledVals) - then [] - else [GVal (valOf 0 $ getVal [GEZero 1, GEPlus 2] scaledVals) (fromList [GEZero 1, GEPlus 2])] - ) - <> [GVal 1 (fromList [GEPlus 1, GEPlus 2])] - newVec = GVec [GVal (valOf 0 $ getVal [GEZero 1, GEPlus 1] rawVals) (fromList [GEZero 1, GEPlus 1]) - ,GVal (valOf 0 $ getVal [GEZero 1, GEPlus 2] rawVals) (fromList [GEZero 1, GEPlus 2])] - (GVec scaledVals, scaledErrs) = divVecScalarWithErr newVec $ valOf 1 foundVal - (GVec rawVals) = vecOfP point - foundVal = getVal [GEPlus 1, GEPlus 2] rawVals - -- | Canonicalize the intersection resulting from two PLines. -- NOTE: Returns nothing when the PLines are (anti)parallel. canonicalizeIntersectionWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Maybe (CPPoint2, UlpSum) @@ -908,43 +593,3 @@ canonicalizeIntersectionWithErr pl1 pl2 ulpTotal = intersectionErr <> canonicalizationErr foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(PPoint2 (GVec vals)) -> vals) pp1 --- | Normalize a Projective Line. -normalizePLine2WithErr :: (ProjectiveLine2 a) => a -> (NPLine2, PLine2Err) -normalizePLine2WithErr line = (res, resErr) - where - (res, resErr) = case norm of - 1.0 -> (NPLine2 vec , normErr) - _ -> (NPLine2 scaledVec, normErr <> PLine2Err mempty scaledVecErrs mempty mempty mempty mempty) - (scaledVec, scaledVecErrs) = divVecScalarWithErr vec norm - (norm, normErr) = normOfPLine2WithErr line - vec = vecOfL line - --- | find the norm of a given Projective Line. -normOfPLine2WithErr :: (ProjectiveLine2 a) => a -> (ℝ, PLine2Err) -normOfPLine2WithErr pline = (res, resErr) - where - (res, resErr) = case sqNormOfPLine2 of - 1.0 -> (1.0 , PLine2Err mempty mempty mempty sqNormUlp mempty mempty) - _ -> (sqrt sqNormOfPLine2, PLine2Err mempty mempty rawResUlp sqNormUlp mempty mempty) - (sqNormOfPLine2, sqNormUlp) = sqNormOfPLine2WithErr pline - rawRes = sqrt sqNormOfPLine2 - rawResUlp = UlpSum (abs $ realToFrac $ doubleUlp rawRes) - --- | find the squared norm of a given Projective Line. -sqNormOfPLine2WithErr :: (ProjectiveLine2 a) => a -> (ℝ, UlpSum) -sqNormOfPLine2WithErr line = (res, ulpTotal) - where - res = a*a+b*b - a = valOf 0 $ getVal [GEPlus 1] vals - b = valOf 0 $ getVal [GEPlus 2] vals - ulpTotal = UlpSum - $ abs (realToFrac $ doubleUlp $ a*a) - + abs (realToFrac $ doubleUlp $ b*b) - + abs (realToFrac $ doubleUlp res) - (GVec vals) = vecOfL line - --- | Get the sum of a set of error values, when dealing with error applied to a Projective Point. -sumPPointErrs :: [ErrVal] -> UlpSum -sumPPointErrs errs = eValOf mempty (getVal [GEZero 1, GEPlus 1] errs) - <> eValOf mempty (getVal [GEZero 1, GEPlus 2] errs) - <> eValOf mempty (getVal [GEPlus 1, GEPlus 2] errs) diff --git a/hslice.cabal b/hslice.cabal index 9effe95fb..cde9bacc6 100644 --- a/hslice.cabal +++ b/hslice.cabal @@ -37,6 +37,7 @@ library Graphics.Slicer.Math.Lossy Graphics.Slicer.Math.Line Graphics.Slicer.Math.PGA + Graphics.Slicer.Math.PGAPrimitives Graphics.Slicer.Math.Skeleton.Cells Graphics.Slicer.Math.Skeleton.Concave Graphics.Slicer.Math.Skeleton.Definitions From e1b12aecef2e9720726abb56b7f8168f74c1f285 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 16 Oct 2022 20:10:36 +0000 Subject: [PATCH 022/206] whoops, actually commit PGAPrimitives.hs . --- Graphics/Slicer/Math/PGAPrimitives.hs | 451 ++++++++++++++++++++++++++ 1 file changed, 451 insertions(+) create mode 100644 Graphics/Slicer/Math/PGAPrimitives.hs diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs new file mode 100644 index 000000000..830bc51df --- /dev/null +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -0,0 +1,451 @@ +{- ORMOLU_DISABLE -} +{- + - Copyright 2020-2022 Julia Longtin + - + - This program is free software: you can redistribute it and/or modify + - it under the terms of the GNU Affero General Public License as published by + - the Free Software Foundation, either version 3 of the License, or + - (at your option) any later version. + - + - This program is distributed in the hope that it will be useful, + - but WITHOUT ANY WARRANTY; without even the implied warranty of + - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + - GNU Affero General Public License for more details. + + - You should have received a copy of the GNU Affero General Public License + - along with this program. If not, see . + -} + +-- for adding Generic and NFData to our types. +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} + +-- | The purpose of this file is to hold primitive projective geometric algebraic arithmatic. +-- Primitives here are defined as functions that work on types which have an implementation of the ProjectivePoint2 or ProjectiveLine2 typeclasses. + +module Graphics.Slicer.Math.PGAPrimitives +( + Arcable( + hasArc, + outOf, + outUlpMag, + ulpOfOut + ), + CPPoint2(CPPoint2), + NPLine2(NPLine2), + PLine2(PLine2), + PLine2Err(PLine2Err), + Pointable( + canPoint, + ePointOf, + pPointOf + ), + PPoint2(PPoint2), + PPoint2Err, + ProjectiveLine2( + flipL, + forceBasisOfL, + meetOf2PL, + normalize, + normOfL, + sqNormOfL, + translateL, + vecOfL + ), + ProjectivePoint2( + canonicalize, + forceBasisOfP, + idealNormOfP, + join2PP, + pToEP, + vecOfP + ), +) where + +import Prelude(Bool, Eq((==)), Monoid(mempty), Ord, Semigroup((<>)), Show(show), ($), (+), (*), (<$>), abs, error, negate, otherwise, realToFrac, sqrt) + +import Control.DeepSeq (NFData) + +import Data.Bits.Floating.Ulp (doubleUlp) + +import Data.List (foldl', sort) + +import Data.Maybe (Maybe(Just,Nothing), fromMaybe, isNothing) + +import Data.Set (Set, elems, fromList, singleton) + +import GHC.Generics (Generic) + +import Graphics.Slicer.Definitions (ℝ) + +import Graphics.Slicer.Math.Definitions (Point2(Point2)) + +import Graphics.Slicer.Math.GeometricAlgebra (ErrVal, GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎤+), addErr, addValWithoutErr, addVecPairWithErr, divVecScalarWithErr, eValOf, getVal, sumErrVals, valOf) + +-------------------------------- +--- common support functions --- +-------------------------------- + +-- | The join operator in 2D PGA, which is implemented as the meet operator operating in the dual space. +(∨+) :: GVec -> GVec -> (GVec, UlpSum) +(∨+) a b = (vec + , ulpSum) + where + vec = dual2DGVec $ res + ulpSum = sumErrVals unlikeMulErr <> sumErrVals unlikeAddErr + (res, (unlikeAddErr, unlikeMulErr)) = dual2DGVec a ⎤+ dual2DGVec b +infixl 9 ∨+ + +-- | get the dual of a vector. for a point, find a line, for a line, a point... +dual2DGVec :: GVec -> GVec +dual2DGVec (GVec vals) = GVec $ foldl' addValWithoutErr [] + [ + GVal ( valOf 0 $ getVal [G0] vals) (fromList [GEZero 1, GEPlus 1, GEPlus 2]) + , GVal ( valOf 0 $ getVal [GEZero 1] vals) (fromList [GEPlus 1, GEPlus 2]) + , GVal (negate $ valOf 0 $ getVal [GEPlus 1] vals) (fromList [GEZero 1, GEPlus 2]) + , GVal ( valOf 0 $ getVal [GEPlus 2] vals) (fromList [GEZero 1, GEPlus 1]) + , GVal ( valOf 0 $ getVal [GEZero 1, GEPlus 1] vals) (singleton (GEPlus 2)) + , GVal (negate $ valOf 0 $ getVal [GEZero 1, GEPlus 2] vals) (singleton (GEPlus 1)) + , GVal ( valOf 0 $ getVal [GEPlus 1, GEPlus 2] vals) (singleton (GEZero 1)) + , GVal ( valOf 0 $ getVal [GEZero 1, GEPlus 1, GEPlus 2] vals) (singleton G0) + ] + +-- | Get the sum of a set of error values, when dealing with error applied to a Projective Point. +sumPPointErrs :: [ErrVal] -> UlpSum +sumPPointErrs errs = eValOf mempty (getVal [GEZero 1, GEPlus 1] errs) + <> eValOf mempty (getVal [GEZero 1, GEPlus 2] errs) + <> eValOf mempty (getVal [GEPlus 1, GEPlus 2] errs) + +------------------------------- +--- Projective Line Support --- +------------------------------- + +-- | A projective line in 2D space. +newtype PLine2 = PLine2 GVec + deriving (Eq, Generic, NFData, Show) + +-- | A normalized projective line in 2D space. +newtype NPLine2 = NPLine2 GVec + deriving (Eq, Generic, NFData, Show) + +class ProjectiveLine2 a where + consLikeL :: a -> (GVec -> a) + flipL :: a -> a + forceBasisOfL :: a -> a + meetOf2PL :: (ProjectiveLine2 b) => a -> b -> (PPoint2, UlpSum) + normalize :: a -> (NPLine2, UlpSum) + normOfL :: a -> (ℝ, PLine2Err) + sqNormOfL :: a -> (ℝ, UlpSum) + translateL :: a -> ℝ -> (PLine2, UlpSum) + vecOfL :: a -> GVec + +instance ProjectiveLine2 NPLine2 where + consLikeL _ = NPLine2 + flipL l = flipProjectiveLine l + forceBasisOfL l = forceProjectiveLineBasis l + meetOf2PL l1 l2 = meet2ProjectiveLinesWithErr l1 l2 + normalize l = (l, mempty) + normOfL l = normOfProjectiveLineWithErr l + sqNormOfL l = sqNormOfProjectiveLineWithErr l + translateL l d = (\(r,(PLine2Err _ _ _ _ t _)) -> (r,t)) $ translateProjectiveLine2WithErr l d + vecOfL (NPLine2 v) = v + +instance ProjectiveLine2 PLine2 where + consLikeL _ = PLine2 + flipL l = flipProjectiveLine l + forceBasisOfL l = forceProjectiveLineBasis l + meetOf2PL l1 l2 = meet2ProjectiveLinesWithErr l1 l2 + normalize l = (\(b,(PLine2Err _ _ c d _ _)) -> (b,c <> d)) $ normalizePLine2WithErr l + normOfL l = normOfProjectiveLineWithErr l + sqNormOfL l = sqNormOfProjectiveLineWithErr l + translateL l d = (\(r,(PLine2Err _ _ _ _ t _)) -> (r,t)) $ translateProjectiveLine2WithErr l d + vecOfL (PLine2 a) = a + +-- | the two types of error of a projective line. +data PLine2Err = PLine2Err + -- AddErr + [ErrVal] + -- NormalizationErr + [ErrVal] + -- NormErr + UlpSum + -- SqNormErr + UlpSum + -- Translation Error. always in GEZero 1. + UlpSum + -- Join Error. when a PLine2 is constructed via join. + ([ErrVal], [ErrVal]) + deriving (Eq, Show) + +instance Semigroup PLine2Err where + (<>) (PLine2Err a1 b1 c1 d1 e1 (f1,g1)) (PLine2Err a2 b2 c2 d2 e2 (f2,g2)) = + PLine2Err (foldl' addErr a1 a2) + (foldl' addErr b1 b2) + (c1 <> c2) + (d1 <> d2) + (e1 <> e2) + (foldl' addErr f1 f2,foldl' addErr g1 g2) + +instance Monoid PLine2Err where + mempty = PLine2Err mempty mempty mempty mempty mempty mempty + +-- | A projective point in 2D space. +newtype PPoint2 = PPoint2 GVec + deriving (Eq, Ord, Generic, NFData, Show) + +-- | Reverse a line. same line, but pointed in the other direction. +flipProjectiveLine :: (ProjectiveLine2 a) => a -> a +flipProjectiveLine pline = (consLikeL pline) rawRes + where + rawRes = GVec $ foldl' addValWithoutErr [] + [ + GVal (negate $ valOf 0 $ getVal [GEZero 1] vals) (singleton (GEZero 1)) + , GVal (negate $ valOf 0 $ getVal [GEPlus 1] vals) (singleton (GEPlus 1)) + , GVal (negate $ valOf 0 $ getVal [GEPlus 2] vals) (singleton (GEPlus 2)) + ] + (GVec vals) = vecOfL pline + +-- | perform basis coersion. ensure all of the required '0' components exist. required before using basis sensitive raw operators. +forceBasis :: [Set GNum] -> GVec -> GVec +forceBasis numsets (GVec vals) = GVec $ forceVal vals <$> sort numsets + where + forceVal :: [GVal] -> Set GNum -> GVal + forceVal has needs = GVal (valOf 0 $ getVal (elems needs) has) needs + +-- | runtime basis coersion. ensure all of the '0' components exist on a Projective Line. +forceProjectiveLineBasis :: (ProjectiveLine2 a) => a -> a +forceProjectiveLineBasis line + | gnums == Just [singleton (GEZero 1), + singleton (GEPlus 1), + singleton (GEPlus 2)] = line + | otherwise = (consLikeL line) res + where + res = forceBasis [singleton (GEZero 1), singleton (GEPlus 1), singleton (GEPlus 2)] pvec + gnums = case vals of + [GVal _ g1, GVal _ g2, GVal _ g3] -> Just [g1,g2,g3] + _ -> Nothing + pvec@(GVec vals) = vecOfL line + +-- | A typed meet function. the meeting of two lines is a point. +meet2ProjectiveLinesWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PPoint2, UlpSum) +meet2ProjectiveLinesWithErr line1 line2 = (PPoint2 res, + ulpSum) + where + ulpSum = sumErrVals unlikeMulErr <> sumErrVals unlikeAddErr + (res, (unlikeMulErr, unlikeAddErr)) = pv1 ⎤+ pv2 + pv1 = vecOfL $ forceBasisOfL npl1 + pv2 = vecOfL $ forceBasisOfL npl2 + (npl1,_) = normalize line1 + (npl2,_) = normalize line2 + +-- | Normalize a Projective Line. +normalizePLine2WithErr :: (ProjectiveLine2 a) => a -> (NPLine2, PLine2Err) +normalizePLine2WithErr line = (res, resErr) + where + (res, resErr) = case norm of + 1.0 -> (NPLine2 vec , normErr) + _ -> (NPLine2 scaledVec, normErr <> PLine2Err mempty scaledVecErrs mempty mempty mempty mempty) + (scaledVec, scaledVecErrs) = divVecScalarWithErr vec norm + (norm, normErr) = normOfL line + vec = vecOfL line + +-- | find the norm of a given Projective Line. +normOfProjectiveLineWithErr :: (ProjectiveLine2 a) => a -> (ℝ, PLine2Err) +normOfProjectiveLineWithErr pline = (res, resErr) + where + (res, resErr) = case sqNormOfPLine2 of + 1.0 -> (1.0 , PLine2Err mempty mempty mempty sqNormUlp mempty mempty) + _ -> (sqrt sqNormOfPLine2, PLine2Err mempty mempty rawResUlp sqNormUlp mempty mempty) + (sqNormOfPLine2, sqNormUlp) = sqNormOfL pline + rawRes = sqrt sqNormOfPLine2 + rawResUlp = UlpSum (abs $ realToFrac $ doubleUlp rawRes) + +-- | find the squared norm of a given Projective Line. +sqNormOfProjectiveLineWithErr :: (ProjectiveLine2 a) => a -> (ℝ, UlpSum) +sqNormOfProjectiveLineWithErr line = (res, ulpTotal) + where + res = a*a+b*b + a = valOf 0 $ getVal [GEPlus 1] vals + b = valOf 0 $ getVal [GEPlus 2] vals + ulpTotal = UlpSum + $ abs (realToFrac $ doubleUlp $ a*a) + + abs (realToFrac $ doubleUlp $ b*b) + + abs (realToFrac $ doubleUlp res) + (GVec vals) = vecOfL line + +-- | Translate a line a given distance along it's perpendicular bisector. +-- Abuses the property that translation of a line is expressed on the GEZero component. +translateProjectiveLine2WithErr :: (ProjectiveLine2 a) => a -> ℝ -> (PLine2, PLine2Err) +translateProjectiveLine2WithErr line d = (PLine2 res, nErr <> PLine2Err resUlp mempty mempty mempty tUlp mempty) + where + (res, resUlp) = addVecPairWithErr m $ vecOfL line + m = GVec [GVal tAdd (singleton (GEZero 1))] + -- the amount to add to the GEZero 1 component. + tAdd = d * n + tUlp = UlpSum $ abs $ realToFrac $ doubleUlp tAdd + (n, nErr) = normOfL line + +----------------------- +--- Point interface --- +----------------------- + +-- | A canonicalized projective point in 2D space. +newtype CPPoint2 = CPPoint2 GVec + deriving (Eq, Generic, NFData, Show) + +-- | the error accumulated when calculating a projective point. +data PPoint2Err = + PPoint2Err + -- MeetErr. max error amounts while meeting two PLines to find this point. divided into add err, and multiply err. + ([ErrVal], [ErrVal]) + -- CanonicalizeErr. error caused by the divide used during canonicalization of a point. + [ErrVal] + -- AddErr. error created when adding two points to create a third point. + [ErrVal] + -- WeighedStartErr. error created when scaling one of the two input points used to create this point. + [ErrVal] + -- WeighedStopErr. error created when scaling one of the two input points used to create this point. + [ErrVal] + -- angle between the two input lines, when we generate this point via intersecting two lines. + ℝ + -- angleUnlikeErr - the error of the unlike operation that generates the angle in the previous field. + ([ErrVal], [ErrVal]) + deriving (Eq, Show) + +instance Semigroup PPoint2Err where + (<>) (PPoint2Err (a1,b1) c1 d1 e1 f1 g1 (h1,i1)) (PPoint2Err (a2,b2) c2 d2 e2 f2 g2 (h2,i2)) = + PPoint2Err + (foldl' addErr a1 a2, foldl' addErr b1 b2) + (foldl' addErr c1 c2) + (foldl' addErr d1 d2) + (foldl' addErr e1 e2) + (foldl' addErr f1 f2) + (g1 <> g2) + (foldl' addErr h1 h2, foldl' addErr i1 i2) + +instance Monoid PPoint2Err where + mempty = PPoint2Err mempty mempty mempty mempty mempty mempty mempty + +-- | Can this node be resolved into a point in 2d space? +class Pointable a where + canPoint :: a -> Bool + pPointOf :: a -> PPoint2 + ePointOf :: a -> Point2 + +-- | does this node have an output (resulting) pLine? +class Arcable a where + hasArc :: a -> Bool + outOf :: a -> PLine2 + ulpOfOut :: a -> UlpSum + outUlpMag :: a -> ℝ + +class ProjectivePoint2 a where + canonicalize :: a -> (CPPoint2, UlpSum) + consLikeP :: a -> (GVec -> a) + forceBasisOfP :: a -> a + idealNormOfP :: a -> (ℝ, UlpSum) + join2PP :: (ProjectivePoint2 b) => a -> b -> (PLine2, UlpSum) + pToEP :: a -> (Point2, UlpSum) + vecOfP :: a -> GVec + +instance ProjectivePoint2 PPoint2 where + canonicalize p = (\(a, PPoint2Err _ c8izeErrs _ _ _ _ _) -> (a,sumPPointErrs c8izeErrs)) $ canonicalizePPoint2WithErr p + consLikeP (PPoint2 _) = PPoint2 + forceBasisOfP a = forceProjectivePointBasis a + idealNormOfP a = idealNormPPoint2WithErr a + join2PP a b = join2ProjectivePointsWithErr a b + pToEP a = fromMaybe (error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point.") $ projectivePointToPoint2 a + vecOfP (PPoint2 a) = a + +instance ProjectivePoint2 CPPoint2 where + canonicalize p = (p, mempty) + consLikeP (CPPoint2 _) = CPPoint2 + forceBasisOfP a = forceProjectivePointBasis a + idealNormOfP a = idealNormPPoint2WithErr a + join2PP a b = join2ProjectivePointsWithErr a b + pToEP a = fromMaybe (error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point.") $ projectivePointToPoint2 a + vecOfP (CPPoint2 a) = a + +-- | canonicalize a euclidian point. +-- Note: Normalization of euclidian points in PGA is really just canonicalization. +-- Note: For precision, we go through some work to not bother dividing the GP1,GP2 component with itsself, and just substitute in the answer, as exactly 1. +canonicalizePPoint2WithErr :: (ProjectivePoint2 a, Show a) => a -> (CPPoint2, PPoint2Err) +canonicalizePPoint2WithErr point + | isNothing foundVal = error $ "tried to canonicalize an ideal point: " <> show point <> "\n" + -- Handle the ID case. + | valOf 1 foundVal == 1 = (CPPoint2 $ GVec rawVals, mempty) + | otherwise = (res, PPoint2Err mempty scaledErrs mempty mempty mempty mempty mempty) + where + res = CPPoint2 $ GVec $ foldl' addValWithoutErr [] + $ ( if isNothing (getVal [GEZero 1, GEPlus 1] scaledVals) + then [] + else [GVal (valOf 0 $ getVal [GEZero 1, GEPlus 1] scaledVals) (fromList [GEZero 1, GEPlus 1])] + ) + <> ( if isNothing (getVal [GEZero 1, GEPlus 2] scaledVals) + then [] + else [GVal (valOf 0 $ getVal [GEZero 1, GEPlus 2] scaledVals) (fromList [GEZero 1, GEPlus 2])] + ) + <> [GVal 1 (fromList [GEPlus 1, GEPlus 2])] + newVec = GVec [GVal (valOf 0 $ getVal [GEZero 1, GEPlus 1] rawVals) (fromList [GEZero 1, GEPlus 1]) + ,GVal (valOf 0 $ getVal [GEZero 1, GEPlus 2] rawVals) (fromList [GEZero 1, GEPlus 2])] + (GVec scaledVals, scaledErrs) = divVecScalarWithErr newVec $ valOf 1 foundVal + (GVec rawVals) = vecOfP point + foundVal = getVal [GEPlus 1, GEPlus 2] rawVals + +-- | runtime basis coersion. ensure all of the '0' components exist on a Projective Point. +forceProjectivePointBasis :: (ProjectivePoint2 a) => a -> a +forceProjectivePointBasis point + | gnums == Just [fromList [GEZero 1, GEPlus 1], + fromList [GEZero 1, GEPlus 2], + fromList [GEPlus 1, GEPlus 2]] = point + | otherwise = (consLikeP point) res + where + res = forceBasis [fromList [GEZero 1, GEPlus 1], fromList [GEZero 1, GEPlus 2], fromList [GEPlus 1, GEPlus 2]] pvec + gnums = case vals of + [GVal _ g1, GVal _ g2, GVal _ g3] -> Just [g1,g2,g3] + _ -> Nothing + pvec@(GVec vals) = vecOfP point + +-- | find the idealized norm of a projective point (ideal or not). +idealNormPPoint2WithErr :: (ProjectivePoint2 a) => a -> (ℝ, UlpSum) +idealNormPPoint2WithErr ppoint + | preRes == 0 = (0, mempty) + | otherwise = (res, ulpTotal) + where + res = sqrt preRes + preRes = x*x+y*y + ulpTotal = UlpSum + $ abs (realToFrac $ doubleUlp $ x*x) + + abs (realToFrac $ doubleUlp $ y*y) + + abs (realToFrac $ doubleUlp preRes) + + abs (realToFrac $ doubleUlp res) + (x,y) + | e12Val == 0 = ( negate $ valOf 0 $ getVal [GEZero 1, GEPlus 2] rawVals + , valOf 0 $ getVal [GEZero 1, GEPlus 1] rawVals) + | otherwise = (\(Point2 (x1,y1),_) -> (x1,y1)) $ pToEP ppoint + e12Val = valOf 0 (getVal [GEPlus 1, GEPlus 2] rawVals) + (GVec rawVals) = vecOfP ppoint + +-- | a typed join function. join two points, returning a line. +join2ProjectivePointsWithErr :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> (PLine2, UlpSum) +join2ProjectivePointsWithErr pp1 pp2 = (PLine2 res, + errTotal) + where + (res,resUlp) = pv1 ∨+ pv2 + pv1 = vecOfP $ forceBasisOfP cp1 + pv2 = vecOfP $ forceBasisOfP cp2 + (cp1, pv1Ulp) = canonicalize pp1 + (cp2, pv2Ulp) = canonicalize pp2 + errTotal = resUlp <> pv1Ulp <> pv2Ulp + +-- | Maybe create a euclidian point from a projective point. Will fail if the projective point is ideal. +projectivePointToPoint2 :: (ProjectivePoint2 a) => a -> Maybe (Point2, UlpSum) +projectivePointToPoint2 ppoint + | e12Val == 0 = Nothing + | otherwise = Just (Point2 (xVal, yVal), cpErrs) + where + (CPPoint2 (GVec vals), cpErrs) = canonicalize ppoint + xVal = negate $ valOf 0 $ getVal [GEZero 1, GEPlus 2] vals + yVal = valOf 0 $ getVal [GEZero 1, GEPlus 1] vals + e12Val = valOf 0 (getVal [GEPlus 1, GEPlus 2] rawVals) + (GVec rawVals) = vecOfP ppoint + From a30967ba89388f7fd623fed546a6d634097b12c3 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Mon, 17 Oct 2022 15:29:38 +0000 Subject: [PATCH 023/206] formatting changes. --- Graphics/Slicer/Math/PGA.hs | 2 +- Graphics/Slicer/Math/PGAPrimitives.hs | 80 +++++++++++++-------------- 2 files changed, 41 insertions(+), 41 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index c44be540d..f685e2579 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -91,7 +91,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (GNum(G0, GEPlus, GEZero), GVal(GVa import Graphics.Slicer.Math.Line (combineLineSegs) -import Graphics.Slicer.Math.PGAPrimitives(Arcable(hasArc,outOf, outUlpMag, ulpOfOut), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(flipL, forceBasisOfL, meetOf2PL, normalize, normOfL, translateL, vecOfL), ProjectivePoint2(canonicalize, forceBasisOfP, idealNormOfP, join2PP, pToEP, vecOfP)) +import Graphics.Slicer.Math.PGAPrimitives(Arcable(hasArc, outOf, outUlpMag, ulpOfOut), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(flipL, forceBasisOfL, meetOf2PL, normalize, normOfL, translateL, vecOfL), ProjectivePoint2(canonicalize, forceBasisOfP, idealNormOfP, join2PP, pToEP, vecOfP)) -- Our 2D plane coresponds to a Clifford algebra of 2,0,1. diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index 830bc51df..7f79f23af 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -23,43 +23,43 @@ -- Primitives here are defined as functions that work on types which have an implementation of the ProjectivePoint2 or ProjectiveLine2 typeclasses. module Graphics.Slicer.Math.PGAPrimitives -( - Arcable( - hasArc, - outOf, - outUlpMag, - ulpOfOut - ), - CPPoint2(CPPoint2), - NPLine2(NPLine2), - PLine2(PLine2), - PLine2Err(PLine2Err), - Pointable( - canPoint, - ePointOf, - pPointOf - ), - PPoint2(PPoint2), - PPoint2Err, - ProjectiveLine2( - flipL, - forceBasisOfL, - meetOf2PL, - normalize, - normOfL, - sqNormOfL, - translateL, - vecOfL - ), - ProjectivePoint2( - canonicalize, - forceBasisOfP, - idealNormOfP, - join2PP, - pToEP, - vecOfP - ), -) where + ( + Arcable( + hasArc, + outOf, + outUlpMag, + ulpOfOut + ), + CPPoint2(CPPoint2), + NPLine2(NPLine2), + PLine2(PLine2), + PLine2Err(PLine2Err), + Pointable( + canPoint, + ePointOf, + pPointOf + ), + PPoint2(PPoint2), + PPoint2Err, + ProjectiveLine2( + flipL, + forceBasisOfL, + meetOf2PL, + normalize, + normOfL, + sqNormOfL, + translateL, + vecOfL + ), + ProjectivePoint2( + canonicalize, + forceBasisOfP, + idealNormOfP, + join2PP, + pToEP, + vecOfP + ) + ) where import Prelude(Bool, Eq((==)), Monoid(mempty), Ord, Semigroup((<>)), Show(show), ($), (+), (*), (<$>), abs, error, negate, otherwise, realToFrac, sqrt) @@ -284,9 +284,9 @@ translateProjectiveLine2WithErr line d = (PLine2 res, nErr <> PLine2Err resUlp m tUlp = UlpSum $ abs $ realToFrac $ doubleUlp tAdd (n, nErr) = normOfL line ------------------------ ---- Point interface --- ------------------------ +-------------------------------- +--- Projective Point Support --- +-------------------------------- -- | A canonicalized projective point in 2D space. newtype CPPoint2 = CPPoint2 GVec From 7d7ec5039516641c9457bf6d26601b4ef85072e3 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Mon, 17 Oct 2022 15:54:52 +0000 Subject: [PATCH 024/206] make projectivePointToPoint2, join2ProjectivePointsWithErr, and canonicalizePPoint2WithErr return error types, instead of UlpSums. --- Graphics/Slicer/Math/PGAPrimitives.hs | 56 ++++++++++++++------------- 1 file changed, 29 insertions(+), 27 deletions(-) diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index 7f79f23af..701748bac 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -86,13 +86,12 @@ import Graphics.Slicer.Math.GeometricAlgebra (ErrVal, GNum(G0, GEPlus, GEZero), -------------------------------- -- | The join operator in 2D PGA, which is implemented as the meet operator operating in the dual space. -(∨+) :: GVec -> GVec -> (GVec, UlpSum) +(∨+) :: GVec -> GVec -> (GVec, ([ErrVal],[ErrVal])) (∨+) a b = (vec - , ulpSum) + , (unlikeMulErr, unlikeAddErr)) where vec = dual2DGVec $ res - ulpSum = sumErrVals unlikeMulErr <> sumErrVals unlikeAddErr - (res, (unlikeAddErr, unlikeMulErr)) = dual2DGVec a ⎤+ dual2DGVec b + (res, (unlikeMulErr, unlikeAddErr)) = dual2DGVec a ⎤+ dual2DGVec b infixl 9 ∨+ -- | get the dual of a vector. for a point, find a line, for a line, a point... @@ -109,12 +108,6 @@ dual2DGVec (GVec vals) = GVec $ foldl' addValWithoutErr [] , GVal ( valOf 0 $ getVal [GEZero 1, GEPlus 1, GEPlus 2] vals) (singleton G0) ] --- | Get the sum of a set of error values, when dealing with error applied to a Projective Point. -sumPPointErrs :: [ErrVal] -> UlpSum -sumPPointErrs errs = eValOf mempty (getVal [GEZero 1, GEPlus 1] errs) - <> eValOf mempty (getVal [GEZero 1, GEPlus 2] errs) - <> eValOf mempty (getVal [GEPlus 1, GEPlus 2] errs) - ------------------------------- --- Projective Line Support --- ------------------------------- @@ -338,7 +331,7 @@ class Arcable a where ulpOfOut :: a -> UlpSum outUlpMag :: a -> ℝ -class ProjectivePoint2 a where +class (Show a) => ProjectivePoint2 a where canonicalize :: a -> (CPPoint2, UlpSum) consLikeP :: a -> (GVec -> a) forceBasisOfP :: a -> a @@ -348,27 +341,37 @@ class ProjectivePoint2 a where vecOfP :: a -> GVec instance ProjectivePoint2 PPoint2 where - canonicalize p = (\(a, PPoint2Err _ c8izeErrs _ _ _ _ _) -> (a,sumPPointErrs c8izeErrs)) $ canonicalizePPoint2WithErr p + canonicalize p = (\(a, PPoint2Err _ c8izeErrs _ _ _ _ _) -> (a,sumErrVals c8izeErrs)) $ canonicalizePPoint2WithErr p consLikeP (PPoint2 _) = PPoint2 forceBasisOfP a = forceProjectivePointBasis a idealNormOfP a = idealNormPPoint2WithErr a - join2PP a b = join2ProjectivePointsWithErr a b - pToEP a = fromMaybe (error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point.") $ projectivePointToPoint2 a + join2PP a b = crushErr $ join2ProjectivePointsWithErr a b + where + crushErr (res, (PPoint2Err _ cp1Ulp _ _ _ _ _ + ,PPoint2Err _ cp2Ulp _ _ _ _ _ + ,PLine2Err _ _ _ _ _ (resMulUlp, resAddUlp))) = (res, sumErrVals resMulUlp <> sumErrVals resAddUlp <> sumErrVals cp1Ulp <> sumErrVals cp2Ulp) + pToEP p = crushErr $ fromMaybe (error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point.") $ projectivePointToPoint2 p + where + crushErr (res, PPoint2Err _ c8izeErrs _ _ _ _ _) = (res, sumErrVals c8izeErrs) vecOfP (PPoint2 a) = a instance ProjectivePoint2 CPPoint2 where canonicalize p = (p, mempty) consLikeP (CPPoint2 _) = CPPoint2 - forceBasisOfP a = forceProjectivePointBasis a - idealNormOfP a = idealNormPPoint2WithErr a - join2PP a b = join2ProjectivePointsWithErr a b - pToEP a = fromMaybe (error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point.") $ projectivePointToPoint2 a - vecOfP (CPPoint2 a) = a + forceBasisOfP p = forceProjectivePointBasis p + idealNormOfP p = idealNormPPoint2WithErr p + join2PP a b = crushErr $ join2ProjectivePointsWithErr a b + where + crushErr (res, (PPoint2Err _ cp1Ulp _ _ _ _ _ + ,PPoint2Err _ cp2Ulp _ _ _ _ _ + ,PLine2Err _ _ _ _ _ (resMulUlp, resAddUlp))) = (res, sumErrVals resMulUlp <> sumErrVals resAddUlp <> sumErrVals cp1Ulp <> sumErrVals cp2Ulp) + pToEP p = (\(b, _) -> (b,mempty)) $ fromMaybe (error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point.") $ projectivePointToPoint2 p + vecOfP (CPPoint2 v) = v -- | canonicalize a euclidian point. -- Note: Normalization of euclidian points in PGA is really just canonicalization. -- Note: For precision, we go through some work to not bother dividing the GP1,GP2 component with itsself, and just substitute in the answer, as exactly 1. -canonicalizePPoint2WithErr :: (ProjectivePoint2 a, Show a) => a -> (CPPoint2, PPoint2Err) +canonicalizePPoint2WithErr :: (ProjectivePoint2 a) => a -> (CPPoint2, PPoint2Err) canonicalizePPoint2WithErr point | isNothing foundVal = error $ "tried to canonicalize an ideal point: " <> show point <> "\n" -- Handle the ID case. @@ -426,24 +429,23 @@ idealNormPPoint2WithErr ppoint (GVec rawVals) = vecOfP ppoint -- | a typed join function. join two points, returning a line. -join2ProjectivePointsWithErr :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> (PLine2, UlpSum) +join2ProjectivePointsWithErr :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> (PLine2, (PPoint2Err, PPoint2Err, PLine2Err)) join2ProjectivePointsWithErr pp1 pp2 = (PLine2 res, - errTotal) + (cp1Ulp, cp2Ulp, PLine2Err mempty mempty mempty mempty mempty resUlp)) where (res,resUlp) = pv1 ∨+ pv2 pv1 = vecOfP $ forceBasisOfP cp1 pv2 = vecOfP $ forceBasisOfP cp2 - (cp1, pv1Ulp) = canonicalize pp1 - (cp2, pv2Ulp) = canonicalize pp2 - errTotal = resUlp <> pv1Ulp <> pv2Ulp + (cp1, cp1Ulp) = canonicalizePPoint2WithErr pp1 + (cp2, cp2Ulp) = canonicalizePPoint2WithErr pp2 -- | Maybe create a euclidian point from a projective point. Will fail if the projective point is ideal. -projectivePointToPoint2 :: (ProjectivePoint2 a) => a -> Maybe (Point2, UlpSum) +projectivePointToPoint2 :: (ProjectivePoint2 a) => a -> Maybe (Point2, PPoint2Err) projectivePointToPoint2 ppoint | e12Val == 0 = Nothing | otherwise = Just (Point2 (xVal, yVal), cpErrs) where - (CPPoint2 (GVec vals), cpErrs) = canonicalize ppoint + (CPPoint2 (GVec vals), cpErrs) = canonicalizePPoint2WithErr ppoint xVal = negate $ valOf 0 $ getVal [GEZero 1, GEPlus 2] vals yVal = valOf 0 $ getVal [GEZero 1, GEPlus 1] vals e12Val = valOf 0 (getVal [GEPlus 1, GEPlus 2] rawVals) From e12c95ec865c42d186093f992e451ef84625d775 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Mon, 17 Oct 2022 16:57:13 +0000 Subject: [PATCH 025/206] remove warnings --- Graphics/Slicer/Math/Arcs.hs | 12 ++++-------- Graphics/Slicer/Math/PGAPrimitives.hs | 2 +- Graphics/Slicer/Math/Skeleton/Concave.hs | 4 ++-- 3 files changed, 7 insertions(+), 11 deletions(-) diff --git a/Graphics/Slicer/Math/Arcs.hs b/Graphics/Slicer/Math/Arcs.hs index ea3a8ce00..9f0c922df 100644 --- a/Graphics/Slicer/Math/Arcs.hs +++ b/Graphics/Slicer/Math/Arcs.hs @@ -22,17 +22,13 @@ module Graphics.Slicer.Math.Arcs (getFirstArcWithErr, getInsideArcWithErr) where -import Prelude (Bool, ($), (>), (<=), (<>), (==), (&&), (||), (+), error, mempty, otherwise, realToFrac, show) +import Prelude (($), (<>), (==), (+), otherwise) -import Graphics.Slicer.Definitions (ℝ) +import Graphics.Slicer.Math.Definitions (Point2, LineSeg(LineSeg), addPoints, distance, scalePoint) -import Graphics.Slicer.Math.Definitions (Point2, LineSeg(LineSeg), addPoints, distance, makeLineSeg, scalePoint) +import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum), addVecPairWithErr, sumErrVals) -import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum), addVecPairWithErr, sumErrVals, ulpVal) - -import Graphics.Slicer.Math.Intersections (isCollinear, isAntiCollinear, isParallel, isAntiParallel, intersectionOf) - -import Graphics.Slicer.Math.PGA (PLine2Err(PLine2Err), PPoint2Err, ProjectiveLine2, PLine2(PLine2), ProjectivePoint2, angleBetweenWithErr, canonicalize, distanceBetweenPPointsWithErr, eToPLine2WithErr, flipL, join2PP, normalize, vecOfL) +import Graphics.Slicer.Math.PGA (ProjectiveLine2, PLine2(PLine2), eToPLine2WithErr, flipL, normalize, vecOfL) -- | Get a PLine in the direction of the inside of the contour, at the angle bisector of the intersection of the line segment, and another segment from the end of the given line segment, toward the given point. -- Note that we normalize our output, but return it as a PLine2. this is safe, because double normalization (if it happens) only raises the ULP. diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index 701748bac..8673dfd28 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -79,7 +79,7 @@ import Graphics.Slicer.Definitions (ℝ) import Graphics.Slicer.Math.Definitions (Point2(Point2)) -import Graphics.Slicer.Math.GeometricAlgebra (ErrVal, GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎤+), addErr, addValWithoutErr, addVecPairWithErr, divVecScalarWithErr, eValOf, getVal, sumErrVals, valOf) +import Graphics.Slicer.Math.GeometricAlgebra (ErrVal, GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎤+), addErr, addValWithoutErr, addVecPairWithErr, divVecScalarWithErr, getVal, sumErrVals, valOf) -------------------------------- --- common support functions --- diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index db636c469..d1aeb3bc5 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -196,7 +196,7 @@ sortedPair n1 n2 = sortedPLines [outOf n1, outOf n2] -- Note: we normalize our output lines. -- FIXME: the outer PLine returned by two PLines in the same direction should be two PLines, whch are the same line in both directions. -- FIXME: should return amount of error. -getOutsideArc :: (ProjectivePoint2 a, Show a) => a -> NPLine2 -> a -> NPLine2 -> PLine2 +getOutsideArc :: (ProjectivePoint2 a) => a -> NPLine2 -> a -> NPLine2 -> PLine2 getOutsideArc ppoint1 npline1 ppoint2 npline2 | npline1 == npline2 = error "need to be able to return two PLines." | noIntersection pline1 pline2 = error $ "no intersection between pline " <> show pline1 <> " and " <> show pline2 <> ".\n" @@ -214,7 +214,7 @@ getOutsideArc ppoint1 npline1 ppoint2 npline2 -- Determine if the line segment formed by the two given points starts with the first point, or the second. -- Note that due to numeric uncertainty, we cannot rely on Eq here, and must check the sign of the angle. -- FIXME: shouldn't we be given an error component in our inputs? -towardIntersection :: (ProjectivePoint2 a, Show a) => a -> PLine2 -> CPPoint2 -> Bool +towardIntersection :: (ProjectivePoint2 a) => a -> PLine2 -> CPPoint2 -> Bool towardIntersection pp1 pl1 pp2 | d <= realToFrac dErr = error $ "cannot resolve points finely enough.\nPPoint1: " <> show pp1 <> "\nPPoint2: " <> show pp2 <> "\nPLineIn: " <> show pl1 <> "\nnewPLine: " <> show newPLine <> "\n" | otherwise = angleFound > realToFrac angleErr From 37e78f289f0fc4cb9ceb62b7a7aed26b7d90b8ad Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Mon, 17 Oct 2022 20:06:27 +0000 Subject: [PATCH 026/206] add error crushing function for pToEP. --- Graphics/Slicer/Math/PGAPrimitives.hs | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index 8673dfd28..da4e8bde4 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -347,12 +347,12 @@ instance ProjectivePoint2 PPoint2 where idealNormOfP a = idealNormPPoint2WithErr a join2PP a b = crushErr $ join2ProjectivePointsWithErr a b where - crushErr (res, (PPoint2Err _ cp1Ulp _ _ _ _ _ - ,PPoint2Err _ cp2Ulp _ _ _ _ _ - ,PLine2Err _ _ _ _ _ (resMulUlp, resAddUlp))) = (res, sumErrVals resMulUlp <> sumErrVals resAddUlp <> sumErrVals cp1Ulp <> sumErrVals cp2Ulp) + crushErr (res, (PPoint2Err _ cp1Errs _ _ _ _ _ + ,PPoint2Err _ cp2Errs _ _ _ _ _ + ,PLine2Err _ _ _ _ _ (resMulErrs, resAddErrs))) = (res, sumErrVals resMulErrs <> sumErrVals resAddErrs <> sumErrVals cp1Errs <> sumErrVals cp2Errs) pToEP p = crushErr $ fromMaybe (error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point.") $ projectivePointToPoint2 p where - crushErr (res, PPoint2Err _ c8izeErrs _ _ _ _ _) = (res, sumErrVals c8izeErrs) + crushErr (res, PPoint2Err _ cp1Errs _ _ _ _ _) = (res, sumErrVals c8izeErrs) vecOfP (PPoint2 a) = a instance ProjectivePoint2 CPPoint2 where @@ -362,10 +362,12 @@ instance ProjectivePoint2 CPPoint2 where idealNormOfP p = idealNormPPoint2WithErr p join2PP a b = crushErr $ join2ProjectivePointsWithErr a b where - crushErr (res, (PPoint2Err _ cp1Ulp _ _ _ _ _ - ,PPoint2Err _ cp2Ulp _ _ _ _ _ - ,PLine2Err _ _ _ _ _ (resMulUlp, resAddUlp))) = (res, sumErrVals resMulUlp <> sumErrVals resAddUlp <> sumErrVals cp1Ulp <> sumErrVals cp2Ulp) - pToEP p = (\(b, _) -> (b,mempty)) $ fromMaybe (error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point.") $ projectivePointToPoint2 p + crushErr (res, (PPoint2Err _ cp1Errs _ _ _ _ _ + ,PPoint2Err _ cp2Errs _ _ _ _ _ + ,PLine2Err _ _ _ _ _ (resMulErrs, resAddErrs))) = (res, sumErrVals resMulErrs <> sumErrVals resAddErrs <> sumErrVals cp1Errs <> sumErrVals cp2Errs) + pToEP p = crushErr $ fromMaybe (error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point.") $ projectivePointToPoint2 p + where + crushErr (res, PPoint2Err _ cp1Errs _ _ _ _ _) = (res, sumErrVals cp1Errs) vecOfP (CPPoint2 v) = v -- | canonicalize a euclidian point. From ee26c148ab56d09b9243d50531348f44ca8a615b Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Mon, 17 Oct 2022 20:13:31 +0000 Subject: [PATCH 027/206] change some of the variable names. --- Graphics/Slicer/Math/PGAPrimitives.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index da4e8bde4..8f8b45c14 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -341,7 +341,7 @@ class (Show a) => ProjectivePoint2 a where vecOfP :: a -> GVec instance ProjectivePoint2 PPoint2 where - canonicalize p = (\(a, PPoint2Err _ c8izeErrs _ _ _ _ _) -> (a,sumErrVals c8izeErrs)) $ canonicalizePPoint2WithErr p + canonicalize p = (\(a, PPoint2Err _ cp1Errs _ _ _ _ _) -> (a,sumErrVals cp1Errs)) $ canonicalizePPoint2WithErr p consLikeP (PPoint2 _) = PPoint2 forceBasisOfP a = forceProjectivePointBasis a idealNormOfP a = idealNormPPoint2WithErr a @@ -352,7 +352,7 @@ instance ProjectivePoint2 PPoint2 where ,PLine2Err _ _ _ _ _ (resMulErrs, resAddErrs))) = (res, sumErrVals resMulErrs <> sumErrVals resAddErrs <> sumErrVals cp1Errs <> sumErrVals cp2Errs) pToEP p = crushErr $ fromMaybe (error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point.") $ projectivePointToPoint2 p where - crushErr (res, PPoint2Err _ cp1Errs _ _ _ _ _) = (res, sumErrVals c8izeErrs) + crushErr (res, PPoint2Err _ cp1Errs _ _ _ _ _) = (res, sumErrVals cp1Errs) vecOfP (PPoint2 a) = a instance ProjectivePoint2 CPPoint2 where From a20390f3e614b67ac649c40309479ef5930039f7 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Tue, 18 Oct 2022 00:40:28 +0000 Subject: [PATCH 028/206] move angleBetweenWithErr into our ProjectiveLine2 typeclass, as angleBetween2PL --- Graphics/Slicer/Math/Lossy.hs | 4 +-- Graphics/Slicer/Math/PGA.hs | 35 ++++++-------------- Graphics/Slicer/Math/PGAPrimitives.hs | 32 +++++++++++++++--- Graphics/Slicer/Math/Skeleton/Cells.hs | 4 +-- Graphics/Slicer/Math/Skeleton/Concave.hs | 4 +-- Graphics/Slicer/Math/Skeleton/Motorcycles.hs | 12 +++---- tests/Math/PGA.hs | 8 ++--- 7 files changed, 54 insertions(+), 45 deletions(-) diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index a9fdfac54..c8b62e30c 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -48,10 +48,10 @@ import Graphics.Slicer.Math.Definitions (LineSeg, Point2, makeLineSeg) import Graphics.Slicer.Math.Arcs (getFirstArcWithErr, getInsideArcWithErr) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PPoint2, ProjectiveLine2, ProjectivePoint2, angleBetweenWithErr, canonicalize, distanceBetweenPPointsWithErr, distanceBetweenPLinesWithErr, distancePPointToPLineWithErr, eToPLine2WithErr, eToPPoint2, join2PP, normalize, pPointBetweenPPointsWithErr, pPointOnPerpWithErr, pToEP, translateL) +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PPoint2, ProjectiveLine2, ProjectivePoint2, angleBetween2PL, canonicalize, distanceBetweenPPointsWithErr, distanceBetweenPLinesWithErr, distancePPointToPLineWithErr, eToPLine2WithErr, eToPPoint2, join2PP, normalize, pPointBetweenPPointsWithErr, pPointOnPerpWithErr, pToEP, translateL) angleBetween :: NPLine2 -> NPLine2 -> ℝ -angleBetween nPLine1 nPLine2 = fst $ angleBetweenWithErr nPLine1 nPLine2 +angleBetween nPLine1 nPLine2 = fst $ angleBetween2PL nPLine1 nPLine2 -- | canonicalize a euclidian point. canonicalizePPoint2 :: PPoint2 -> CPPoint2 diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index f685e2579..f98af2db4 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -36,7 +36,7 @@ module Graphics.Slicer.Math.PGA( PPoint2Err, ProjectiveLine2, ProjectivePoint2, - angleBetweenWithErr, + angleBetween2PL, canonicalize, combineConsecutiveLineSegs, distanceBetweenPPointsWithErr, @@ -87,11 +87,11 @@ import Graphics.Slicer.Definitions (ℝ) import Graphics.Slicer.Math.Definitions (Point2(Point2), LineSeg(LineSeg), addPoints, startPoint, endPoint, distance) -import Graphics.Slicer.Math.GeometricAlgebra (GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎣+), (⎤+), (⨅), (⨅+), (∧), (•), addValWithoutErr, addVecPairWithErr, addVecPairWithoutErr, getVal, mulScalarVecWithErr, scalarPart, sumErrVals, ulpVal, valOf) +import Graphics.Slicer.Math.GeometricAlgebra (GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎣+), (⎤+), (⨅), (⨅+), (∧), (•), addValWithoutErr, addVecPairWithErr, addVecPairWithoutErr, getVal, mulScalarVecWithErr, sumErrVals, ulpVal, valOf) import Graphics.Slicer.Math.Line (combineLineSegs) -import Graphics.Slicer.Math.PGAPrimitives(Arcable(hasArc, outOf, outUlpMag, ulpOfOut), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(flipL, forceBasisOfL, meetOf2PL, normalize, normOfL, translateL, vecOfL), ProjectivePoint2(canonicalize, forceBasisOfP, idealNormOfP, join2PP, pToEP, vecOfP)) +import Graphics.Slicer.Math.PGAPrimitives(Arcable(hasArc, outOf, outUlpMag, ulpOfOut), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(angleBetween2PL, flipL, forceBasisOfL, meetOf2PL, normalize, normOfL, translateL, vecOfL), ProjectivePoint2(canonicalize, forceBasisOfP, idealNormOfP, join2PP, pToEP, vecOfP)) -- Our 2D plane coresponds to a Clifford algebra of 2,0,1. @@ -122,7 +122,7 @@ plinesIntersectIn pl1 pl2 | otherwise = IntersectsIn res (resUlp, intersectUlp, npl1Ulp, npl2Ulp, iaErr, mempty) where (idealNorm, idnErr) = idealNormOfP intersectPoint - (_, iaErr) = angleBetweenWithErr pl1 pl2 + (_, iaErr) = angleBetween2PL pl1 pl2 -- FIXME: how much do the potential normalization errors have an effect on the resultant angle? (intersectPoint, intersectUlp) = pLineIntersectionWithErr pl1 pl2 -- FIXME: remove the canonicalization from this function, moving it to the callers. @@ -239,19 +239,6 @@ distanceBetweenPLinesWithErr line1 line2 = (ideal, resUlpSum) (npl1, _) = normalize line1 (npl2, _) = normalize line2 --- | Return the sine of the angle between the two lines, along with the error. results in a value that is ~+1 when a line points in the same direction of the other given line, and ~-1 when pointing backwards. --- FIXME: not generating large enough ULPs. why? -angleBetweenWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, UlpSum) -angleBetweenWithErr pl1 pl2 = (scalarPart likeRes - , ulpSum) - where - ulpSum = sumErrVals likeMulErr <> sumErrVals likeAddErr - (likeRes, (likeMulErr, likeAddErr)) = p1 ⎣+ p2 - p1 = vecOfL $ forceBasisOfL $ PLine2 pv1 - p2 = vecOfL $ forceBasisOfL $ PLine2 pv2 - (NPLine2 pv1, _) = normalize pl1 - (NPLine2 pv2, _) = normalize pl2 - -- | A checker, to ensure two Projective Lines are going the same direction, and are parallel. -- FIXME: precision on inputs? sameDirection :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Bool @@ -259,8 +246,8 @@ sameDirection a b = res >= maxAngle where -- ceiling value. a value bigger than maxAngle is considered to be going the same direction. maxAngle :: ℝ - maxAngle = 1.0 - realToFrac (ulpVal resErr) - (res, resErr) = angleBetweenWithErr a b + maxAngle = realToFrac (1 - ulpVal resErr :: Rounded 'TowardInf ℝ) + (res, resErr) = angleBetween2PL a b -- | A checker, to ensure two Projective Lines are going the opposite direction, and are parallel. -- FIXME: precision on inputs? @@ -270,7 +257,7 @@ oppositeDirection a b = res <= minAngle -- floor value. a value smaller than minAngle is considered to be going the opposite direction. minAngle :: ℝ minAngle = realToFrac (realToFrac (ulpVal resErr) + (-1) :: Rounded 'TowardNegInf ℝ) - (res, resErr) = angleBetweenWithErr a b + (res, resErr) = angleBetween2PL a b -- | Find a projective point a given distance along a line perpendicularly bisecting the given line at a given point. pPointOnPerpWithErr :: (ProjectiveLine2 a, ProjectivePoint2 b) => a -> b -> ℝ -> (PPoint2, UlpSum) @@ -357,7 +344,7 @@ outputIntersectsLineSeg source (l1, UlpSum l1Err) -- | the multiplier used to expand the hitcircle of an endpoint. ulpScale :: ℝ ulpScale = realToFrac $ ulpMultiplier * realToFrac travelUlpMul * abs (realToFrac angle + angleErr) - (angle, UlpSum angleErr) = angleBetweenWithErr pl1 pl2 + (angle, UlpSum angleErr) = angleBetween2PL pl1 pl2 (_, UlpSum npl1Err) = normalize pl1 (_, UlpSum npl2Err) = normalize pl2 (pl2, UlpSum pl2Err) = eToPLine2WithErr l1 @@ -388,7 +375,7 @@ intersectsWithErr (Left l1@(rawL1,_)) (Right pl1@(rawPL1,_)) = where ulpScale :: ℝ ulpScale = realToFrac $ ulpMultiplier * (abs (realToFrac angle) + angleErr) - (angle, UlpSum angleErr) = angleBetweenWithErr npl1 npl2 + (angle, UlpSum angleErr) = angleBetween2PL npl1 npl2 (npl1, _) = normalize rawPL1 (npl2, _) = normalize pl2 (pl2, _) = eToPLine2WithErr rawL1 @@ -396,7 +383,7 @@ intersectsWithErr (Right pl1@(rawPL1,_)) (Left l1@(rawL1,_)) = where ulpScale :: ℝ ulpScale = realToFrac $ ulpMultiplier * (abs (realToFrac angle) + angleErr) - (angle, UlpSum angleErr) = angleBetweenWithErr npl1 npl2 + (angle, UlpSum angleErr) = angleBetween2PL npl1 npl2 (npl1, _) = normalize rawPL1 (npl2, _) = normalize pl2 (pl2, _) = eToPLine2WithErr rawL1 @@ -475,7 +462,7 @@ lineSegIntersectsLineSeg (l1, UlpSum l1Err) (l2, UlpSum ulpL2) | pl1Err < 0 || pl2Err < 0 || l1Err < 0 || ulpL2 < 0 || rawIntersectErr < 0 || rawIntersectionErr < 0 = error "negative ULP?\n" | otherwise = pl1Err + pl2Err + l1Err + ulpL2 + (rawIntersectErr * ulpScale) ulpScale = 120 + ulpMultiplier * (realToFrac angle+angleErr) * (realToFrac angle+angleErr) - (angle, UlpSum angleErr) = angleBetweenWithErr npl1 npl2 + (angle, UlpSum angleErr) = angleBetween2PL npl1 npl2 (npl1, _) = normalize pl1 (npl2, _) = normalize pl2 dumpULPs = "pl1Err: " <> show pl1Err <> "\npl2Err: " <> show pl2Err <> "\nl1Err: " <> show l1Err <> "\nrawIntersectErr: " <> show rawIntersectErr <> "\n" diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index 8f8b45c14..cd7790d4b 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -42,6 +42,7 @@ module Graphics.Slicer.Math.PGAPrimitives PPoint2(PPoint2), PPoint2Err, ProjectiveLine2( + angleBetween2PL, flipL, forceBasisOfL, meetOf2PL, @@ -79,7 +80,7 @@ import Graphics.Slicer.Definitions (ℝ) import Graphics.Slicer.Math.Definitions (Point2(Point2)) -import Graphics.Slicer.Math.GeometricAlgebra (ErrVal, GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎤+), addErr, addValWithoutErr, addVecPairWithErr, divVecScalarWithErr, getVal, sumErrVals, valOf) +import Graphics.Slicer.Math.GeometricAlgebra (ErrVal, GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎣+), (⎤+), addErr, addValWithoutErr, addVecPairWithErr, divVecScalarWithErr, getVal, scalarPart, sumErrVals, valOf) -------------------------------- --- common support functions --- @@ -121,6 +122,7 @@ newtype NPLine2 = NPLine2 GVec deriving (Eq, Generic, NFData, Show) class ProjectiveLine2 a where + angleBetween2PL :: (ProjectiveLine2 b) => a -> b -> (ℝ, UlpSum) consLikeL :: a -> (GVec -> a) flipL :: a -> a forceBasisOfL :: a -> a @@ -132,6 +134,9 @@ class ProjectiveLine2 a where vecOfL :: a -> GVec instance ProjectiveLine2 NPLine2 where + angleBetween2PL l1 l2 = crushErr $ angleBetweenWithErr l1 l2 + where + crushErr (res, (_,_,_,ulpSum)) = (res, ulpSum) consLikeL _ = NPLine2 flipL l = flipProjectiveLine l forceBasisOfL l = forceProjectiveLineBasis l @@ -143,6 +148,9 @@ instance ProjectiveLine2 NPLine2 where vecOfL (NPLine2 v) = v instance ProjectiveLine2 PLine2 where + angleBetween2PL l1 l2 = crushErr $ angleBetweenWithErr l1 l2 + where + crushErr (res, (_,_,_,ulpSum)) = (res, ulpSum) consLikeL _ = PLine2 flipL l = flipProjectiveLine l forceBasisOfL l = forceProjectiveLineBasis l @@ -185,6 +193,20 @@ instance Monoid PLine2Err where newtype PPoint2 = PPoint2 GVec deriving (Eq, Ord, Generic, NFData, Show) +-- | Return the sine of the angle between the two lines, along with the error. +-- Results in a value that is ~+1 when a line points in the same direction of the other given line, and ~-1 when pointing backwards. +angleBetweenWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, ([ErrVal], [ErrVal]), UlpSum)) +angleBetweenWithErr pl1 pl2 = (scalarPart likeRes + , resErr) + where + resErr = (npl1Err, npl2Err, (likeMulErr,likeAddErr), ulpSum) + ulpSum = sumErrVals likeMulErr <> sumErrVals likeAddErr + (likeRes, (likeMulErr, likeAddErr)) = l1 ⎣+ l2 + l1 = vecOfL $ forceBasisOfL npl1 + l2 = vecOfL $ forceBasisOfL npl2 + (npl1, npl1Err) = normalizePLine2WithErr pl1 + (npl2, npl2Err) = normalizePLine2WithErr pl2 + -- | Reverse a line. same line, but pointed in the other direction. flipProjectiveLine :: (ProjectiveLine2 a) => a -> a flipProjectiveLine pline = (consLikeL pline) rawRes @@ -268,14 +290,14 @@ sqNormOfProjectiveLineWithErr line = (res, ulpTotal) -- | Translate a line a given distance along it's perpendicular bisector. -- Abuses the property that translation of a line is expressed on the GEZero component. translateProjectiveLine2WithErr :: (ProjectiveLine2 a) => a -> ℝ -> (PLine2, PLine2Err) -translateProjectiveLine2WithErr line d = (PLine2 res, nErr <> PLine2Err resUlp mempty mempty mempty tUlp mempty) +translateProjectiveLine2WithErr line d = (PLine2 res, normErr <> PLine2Err resErrs mempty mempty mempty tUlp mempty) where - (res, resUlp) = addVecPairWithErr m $ vecOfL line + (res, resErrs) = addVecPairWithErr m $ vecOfL line m = GVec [GVal tAdd (singleton (GEZero 1))] -- the amount to add to the GEZero 1 component. - tAdd = d * n + tAdd = d * norm tUlp = UlpSum $ abs $ realToFrac $ doubleUlp tAdd - (n, nErr) = normOfL line + (norm, normErr) = normOfL line -------------------------------- --- Projective Point Support --- diff --git a/Graphics/Slicer/Math/Skeleton/Cells.hs b/Graphics/Slicer/Math/Skeleton/Cells.hs index c2df6f8bd..113444e4a 100644 --- a/Graphics/Slicer/Math/Skeleton/Cells.hs +++ b/Graphics/Slicer/Math/Skeleton/Cells.hs @@ -58,7 +58,7 @@ import Graphics.Slicer.Math.Intersections (intersectionOf) import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, eToCPPoint2, eToNPLine2, eToPLine2, join2PPoint2, normalizePLine2, pToEPoint2) -import Graphics.Slicer.Math.PGA (Arcable(outOf), CPPoint2(CPPoint2), Pointable(canPoint, ePointOf, pPointOf), PIntersection(PAntiCollinear, IntersectsIn), PPoint2(PPoint2), angleBetweenWithErr, distanceBetweenPPointsWithErr, eToPPoint2, plinesIntersectIn) +import Graphics.Slicer.Math.PGA (Arcable(outOf), CPPoint2(CPPoint2), Pointable(canPoint, ePointOf, pPointOf), PIntersection(PAntiCollinear, IntersectsIn), PPoint2(PPoint2), angleBetween2PL, distanceBetweenPPointsWithErr, eToPPoint2, plinesIntersectIn) data UnsupportedReason = INodeCrossesDivide ![(INode,CellDivide)] !NodeTree deriving (Show, Eq) @@ -111,7 +111,7 @@ findDivisions contour crashTree = case motorcyclesIn crashTree of where intersectionIsBehind m = angleFound < realToFrac angleErr where - (angleFound, UlpSum angleErr) = angleBetweenWithErr (normalizePLine2 $ outOf m) (eToNPLine2 $ lineSegToIntersection m) + (angleFound, UlpSum angleErr) = angleBetween2PL (normalizePLine2 $ outOf m) (eToNPLine2 $ lineSegToIntersection m) lineSegToIntersection m = makeLineSeg (ePointOf m) (pToEPoint2 intersectionPPoint) intersectionPPoint = intersectionOf (outOf firstMC) (outOf secondMC) (Slist (_:_) _) -> error "too many motorcycles." diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index d1aeb3bc5..7c854c37a 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -62,7 +62,7 @@ import Graphics.Slicer.Math.Intersections (intersectionOf, intersectionBetween, import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, distancePPointToPLine, eToPLine2, getInsideArc, join2CPPoint2, normalizePLine2) -import Graphics.Slicer.Math.PGA (Arcable(hasArc, outOf), Pointable(canPoint, pPointOf), PLine2(PLine2), ProjectivePoint2, CPPoint2(CPPoint2), PPoint2(PPoint2), canonicalize, flipL, distanceBetweenPPointsWithErr, pLineIsLeft, angleBetweenWithErr, distancePPointToPLineWithErr, NPLine2(NPLine2)) +import Graphics.Slicer.Math.PGA (Arcable(hasArc, outOf), Pointable(canPoint, pPointOf), PLine2(PLine2), ProjectivePoint2, CPPoint2(CPPoint2), PPoint2(PPoint2), canonicalize, flipL, distanceBetweenPPointsWithErr, pLineIsLeft, angleBetween2PL, distancePPointToPLineWithErr, NPLine2(NPLine2)) import Graphics.Slicer.Math.Skeleton.Definitions (ENode(ENode), ENodeSet(ENodeSet), INode(INode), INodeSet(INodeSet), NodeTree(NodeTree), concavePLines, getFirstLineSeg, getLastLineSeg, finalOutOf, firstInOf, getPairs, indexPLinesTo, insOf, lastINodeOf, linePairs, makeINode, sortedPLines, isLoop) @@ -219,7 +219,7 @@ towardIntersection pp1 pl1 pp2 | d <= realToFrac dErr = error $ "cannot resolve points finely enough.\nPPoint1: " <> show pp1 <> "\nPPoint2: " <> show pp2 <> "\nPLineIn: " <> show pl1 <> "\nnewPLine: " <> show newPLine <> "\n" | otherwise = angleFound > realToFrac angleErr where - (angleFound, UlpSum angleErr) = angleBetweenWithErr newPLine (normalizePLine2 pl1) + (angleFound, UlpSum angleErr) = angleBetween2PL newPLine (normalizePLine2 pl1) (d, UlpSum dErr) = distanceBetweenPPointsWithErr (fst $ canonicalize pp1) pp2 newPLine = normalizePLine2 $ join2CPPoint2 (fst $ canonicalize pp1) pp2 diff --git a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs index be8be4271..9ac228267 100644 --- a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs +++ b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs @@ -50,7 +50,7 @@ import Graphics.Slicer.Math.Intersections (getMotorcycleSegSetIntersections, get import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, pPointBetweenPPoints, distanceBetweenPPoints, eToNPLine2, eToCPPoint2, eToPLine2, normalizePLine2, pLineFromEndpoints, pToEPoint2, translatePLine2) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2(NPLine2), PLine2(PLine2), PPoint2, Arcable(outOf), Pointable(canPoint, ePointOf, pPointOf), flipL, pLineIsLeft, pPointsOnSameSideOfPLine, PIntersection(IntersectsIn,PAntiCollinear), plinesIntersectIn, angleBetweenWithErr, outputIntersectsLineSeg, ulpOfPLine2, ulpOfLineSeg) +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2(NPLine2), PLine2(PLine2), PPoint2, Arcable(outOf), Pointable(canPoint, ePointOf, pPointOf), flipL, pLineIsLeft, pPointsOnSameSideOfPLine, PIntersection(IntersectsIn,PAntiCollinear), plinesIntersectIn, angleBetween2PL, outputIntersectsLineSeg, ulpOfPLine2, ulpOfLineSeg) import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle), ENode(ENode), getFirstLineSeg, linePairs, CellDivide(CellDivide), DividingMotorcycles(DividingMotorcycles), MotorcycleIntersection(WithLineSeg, WithENode, WithMotorcycle)) @@ -157,7 +157,7 @@ crashMotorcycles contour holes intersectionPPoint = intersectionOf (outOf mot1) (outOf mot2) intersectionIsBehind m = angleFound < realToFrac angleErr where - (angleFound, UlpSum angleErr) = angleBetweenWithErr (normalizePLine2 $ outOf m) (eToNPLine2 $ lineSegToIntersection m) + (angleFound, UlpSum angleErr) = angleBetween2PL (normalizePLine2 $ outOf m) (eToNPLine2 $ lineSegToIntersection m) lineSegToIntersection m = makeLineSeg (ePointOf m) (pToEPoint2 intersectionPPoint) -- | Find the non-reflex virtexes of a contour and draw motorcycles from them. Useful for contours that are a 'hole' in a bigger contour. @@ -254,10 +254,10 @@ motorcycleMightIntersectWith lineSegs motorcycle where intersectionPointIsBehind point = angleFound < realToFrac angleErr where - (angleFound, UlpSum angleErr) = angleBetweenWithErr (normalizePLine2 $ outOf motorcycle) (eToNPLine2 $ lineSegToIntersection point) + (angleFound, UlpSum angleErr) = angleBetween2PL (normalizePLine2 $ outOf motorcycle) (eToNPLine2 $ lineSegToIntersection point) intersectionCPPointIsBehind pPoint = angleFound < realToFrac angleErr where - (angleFound, UlpSum angleErr) = angleBetweenWithErr (normalizePLine2 $ outOf motorcycle) (eToNPLine2 $ lineSegToIntersectionP pPoint) + (angleFound, UlpSum angleErr) = angleBetween2PL (normalizePLine2 $ outOf motorcycle) (eToNPLine2 $ lineSegToIntersectionP pPoint) lineSegToIntersection myPoint = makeLineSeg (ePointOf motorcycle) myPoint lineSegToIntersectionP myPPoint = makeLineSeg (ePointOf motorcycle) (pToEPoint2 myPPoint) @@ -297,10 +297,10 @@ motorcycleIntersectsAt contour motorcycle = case intersections of where intersectionPointIsBehind point = angleFound < realToFrac angleErr where - (angleFound, UlpSum angleErr) = angleBetweenWithErr (normalizePLine2 $ outOf motorcycle) (eToNPLine2 $ lineSegToIntersection point) + (angleFound, UlpSum angleErr) = angleBetween2PL (normalizePLine2 $ outOf motorcycle) (eToNPLine2 $ lineSegToIntersection point) intersectionPPointIsBehind pPoint = angleFound < realToFrac angleErr where - (angleFound, UlpSum angleErr) = angleBetweenWithErr (normalizePLine2 $ outOf motorcycle) (eToNPLine2 $ lineSegToIntersectionP pPoint) + (angleFound, UlpSum angleErr) = angleBetween2PL (normalizePLine2 $ outOf motorcycle) (eToNPLine2 $ lineSegToIntersectionP pPoint) lineSegToIntersection myPoint = makeLineSeg (ePointOf motorcycle) myPoint lineSegToIntersectionP myPPoint = makeLineSeg (ePointOf motorcycle) (pToEPoint2 myPPoint) motorcyclePoint = canonicalizePPoint2 $ pPointOf motorcycle diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index e1264da57..d11e0cabf 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -59,7 +59,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(GEZero, GEPlu import Graphics.Slicer.Math.Lossy (angleBetween, canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenPLines, distancePPointToPLine, eToCPPoint2, eToPLine2, getFirstArc, join2PPoint2, normalizePLine2, pPointOnPerp) -- Our 2D Projective Geometric Algebra library. -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), canonicalize, pPointBetweenPPointsWithErr, distanceBetweenPPointsWithErr, distancePPointToPLineWithErr, eToPLine2WithErr, eToPPoint2, pLineIntersectionWithErr, translateL, translateRotatePPoint2, angleBetweenWithErr, flipL, join2PP, makePPoint2, normalize, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, distancePPointToPLineWithErr, pPointOnPerpWithErr, outOf, pPointOf, ulpOfOut, outputIntersectsLineSeg, pPointBetweenPPointsWithErr) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), canonicalize, pPointBetweenPPointsWithErr, distanceBetweenPPointsWithErr, distancePPointToPLineWithErr, eToPLine2WithErr, eToPPoint2, pLineIntersectionWithErr, translateL, translateRotatePPoint2, angleBetween2PL, flipL, join2PP, makePPoint2, normalize, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, distancePPointToPLineWithErr, pPointOnPerpWithErr, outOf, pPointOf, ulpOfOut, outputIntersectsLineSeg, pPointBetweenPPointsWithErr) -- Our Contour library. import Graphics.Slicer.Math.Contour (contourContainsContour, getContours, pointsOfContour, numPointsOfContour, justOneContourFrom, lineSegsOfContour, makeLineSegContour, makePointContour, insideIsLeft, innerContourPoint, firstPointPairOfContour, firstLineSegOfContour) @@ -399,7 +399,7 @@ prop_perpAt90Degrees x y rawX2 y2 rawD <> "angle2: " <> show angle2 <> "\n" <> "angle2Err: " <> show angle2Err <> "\n" where - (angle2, UlpSum angle2Err) = angleBetweenWithErr normedPLine3 normedPLine4 + (angle2, UlpSum angle2Err) = angleBetween2PL normedPLine3 normedPLine4 (PPoint2 rawBisectorStart, UlpSum bisectorStartErr) = pPointBetweenPPointsWithErr sourceStart sourceEnd 0.5 0.5 (bisectorEndRaw, UlpSum bisectorEndRawErr) = pPointOnPerpWithErr pline4 (PPoint2 rawBisectorStart) d (bisectorEnd, UlpSum bisectorEndErr) = canonicalize bisectorEndRaw @@ -714,7 +714,7 @@ myAngleBetween a b <> show res <> "\n" <> show resErr <> "\n" where - (res, UlpSum resErr) = angleBetweenWithErr a b + (res, UlpSum resErr) = angleBetween2PL a b -- | ensure that a right angle with one side parallel with an axis and the other side parallel to the other axis results in a line through the origin point. -- NOTE: hack, using angleBetween to filter out minor numerical imprecision. @@ -1320,7 +1320,7 @@ prop_obtuseBisectorOnBiggerSide_makeENode x y d1 rawR1 d2 rawR2 testFirstLine prop_obtuseBisectorOnBiggerSide_makeINode :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> Positive ℝ -> Radian ℝ -> Bool -> Bool -> Expectation prop_obtuseBisectorOnBiggerSide_makeINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 = (angleFound > realToFrac (1-angleErr), angleFound < realToFrac (-1 + angleErr :: Rounded 'TowardInf ℝ)) --> (True, False) where - (angleFound, UlpSum angleErr) = angleBetweenWithErr bisector1 bisector2 + (angleFound, UlpSum angleErr) = angleBetween2PL bisector1 bisector2 eNode = randomENode x y d1 rawR1 d2 rawR2 iNode = randomINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 bisector1 = normalizePLine2 $ outOf iNode From 13c0271e9903fe9ccaabbc5e69b91fcd301017b6 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Tue, 18 Oct 2022 10:37:32 +0000 Subject: [PATCH 029/206] do not forget to dual the error values of the join operation. --- Graphics/Slicer/Math/PGAPrimitives.hs | 23 ++++++++++++++++++----- 1 file changed, 18 insertions(+), 5 deletions(-) diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index cd7790d4b..5094d0100 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -62,7 +62,7 @@ module Graphics.Slicer.Math.PGAPrimitives ) ) where -import Prelude(Bool, Eq((==)), Monoid(mempty), Ord, Semigroup((<>)), Show(show), ($), (+), (*), (<$>), abs, error, negate, otherwise, realToFrac, sqrt) +import Prelude(Bool, Eq((==),(/=)), Monoid(mempty), Ord, Semigroup((<>)), Show(show), ($), (+), (*), (<$>), abs, error, filter, negate, otherwise, realToFrac, sqrt) import Control.DeepSeq (NFData) @@ -80,7 +80,7 @@ import Graphics.Slicer.Definitions (ℝ) import Graphics.Slicer.Math.Definitions (Point2(Point2)) -import Graphics.Slicer.Math.GeometricAlgebra (ErrVal, GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎣+), (⎤+), addErr, addValWithoutErr, addVecPairWithErr, divVecScalarWithErr, getVal, scalarPart, sumErrVals, valOf) +import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎣+), (⎤+), addErr, addValWithoutErr, addVecPairWithErr, divVecScalarWithErr, eValOf, getVal, scalarPart, sumErrVals, valOf) -------------------------------- --- common support functions --- @@ -88,10 +88,9 @@ import Graphics.Slicer.Math.GeometricAlgebra (ErrVal, GNum(G0, GEPlus, GEZero), -- | The join operator in 2D PGA, which is implemented as the meet operator operating in the dual space. (∨+) :: GVec -> GVec -> (GVec, ([ErrVal],[ErrVal])) -(∨+) a b = (vec - , (unlikeMulErr, unlikeAddErr)) +(∨+) a b = ( dual2DGVec res + , (dual2DErrs unlikeMulErr, dual2DErrs unlikeAddErr)) where - vec = dual2DGVec $ res (res, (unlikeMulErr, unlikeAddErr)) = dual2DGVec a ⎤+ dual2DGVec b infixl 9 ∨+ @@ -109,6 +108,20 @@ dual2DGVec (GVec vals) = GVec $ foldl' addValWithoutErr [] , GVal ( valOf 0 $ getVal [GEZero 1, GEPlus 1, GEPlus 2] vals) (singleton G0) ] +-- | get the dual of the error component of a vector. for a point, find a line, for a line, a point... +dual2DErrs :: [ErrVal] -> [ErrVal] +dual2DErrs vals = filter (\(ErrVal a _) -> a /= mempty) + [ + ErrVal (eValOf mempty $ getVal [G0] vals) (fromList [GEZero 1, GEPlus 1, GEPlus 2]) + , ErrVal (eValOf mempty $ getVal [GEZero 1] vals) (fromList [GEPlus 1, GEPlus 2]) + , ErrVal (eValOf mempty $ getVal [GEPlus 1] vals) (fromList [GEZero 1, GEPlus 2]) + , ErrVal (eValOf mempty $ getVal [GEPlus 2] vals) (fromList [GEZero 1, GEPlus 1]) + , ErrVal (eValOf mempty $ getVal [GEZero 1, GEPlus 1] vals) (singleton (GEPlus 2)) + , ErrVal (eValOf mempty $ getVal [GEZero 1, GEPlus 2] vals) (singleton (GEPlus 1)) + , ErrVal (eValOf mempty $ getVal [GEPlus 1, GEPlus 2] vals) (singleton (GEZero 1)) + , ErrVal (eValOf mempty $ getVal [GEZero 1, GEPlus 1, GEPlus 2] vals) (singleton G0) + ] + ------------------------------- --- Projective Line Support --- ------------------------------- From 3455ad3846342eae437d0d06fa792461b24ebacc Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Tue, 18 Oct 2022 18:07:20 +0000 Subject: [PATCH 030/206] relabel some variables and formatting. --- Graphics/Slicer/Math/PGAPrimitives.hs | 73 ++++++++++++++------------- 1 file changed, 39 insertions(+), 34 deletions(-) diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index 5094d0100..1b88c26cc 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -87,9 +87,9 @@ import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(G0, GEPlus, G -------------------------------- -- | The join operator in 2D PGA, which is implemented as the meet operator operating in the dual space. -(∨+) :: GVec -> GVec -> (GVec, ([ErrVal],[ErrVal])) -(∨+) a b = ( dual2DGVec res - , (dual2DErrs unlikeMulErr, dual2DErrs unlikeAddErr)) +(∨+) :: GVec -> GVec -> (GVec, ([ErrVal], [ErrVal])) +(∨+) a b = (dual2DGVec res + ,(dual2DErrs unlikeMulErr, dual2DErrs unlikeAddErr)) where (res, (unlikeMulErr, unlikeAddErr)) = dual2DGVec a ⎤+ dual2DGVec b infixl 9 ∨+ @@ -122,6 +122,14 @@ dual2DErrs vals = filter (\(ErrVal a _) -> a /= mempty) , ErrVal (eValOf mempty $ getVal [GEZero 1, GEPlus 1, GEPlus 2] vals) (singleton G0) ] +-- | Perform basis coersion. +-- Ensure that all of the required '0' components exist. Required before using basis sensitive raw operators directly. +forceBasis :: [Set GNum] -> GVec -> GVec +forceBasis numsets (GVec vals) = GVec $ forceVal vals <$> sort numsets + where + forceVal :: [GVal] -> Set GNum -> GVal + forceVal has needs = GVal (valOf 0 $ getVal (elems needs) has) needs + ------------------------------- --- Projective Line Support --- ------------------------------- @@ -172,7 +180,7 @@ instance ProjectiveLine2 PLine2 where normOfL l = normOfProjectiveLineWithErr l sqNormOfL l = sqNormOfProjectiveLineWithErr l translateL l d = (\(r,(PLine2Err _ _ _ _ t _)) -> (r,t)) $ translateProjectiveLine2WithErr l d - vecOfL (PLine2 a) = a + vecOfL (PLine2 v) = v -- | the two types of error of a projective line. data PLine2Err = PLine2Err @@ -202,27 +210,24 @@ instance Semigroup PLine2Err where instance Monoid PLine2Err where mempty = PLine2Err mempty mempty mempty mempty mempty mempty --- | A projective point in 2D space. -newtype PPoint2 = PPoint2 GVec - deriving (Eq, Ord, Generic, NFData, Show) - -- | Return the sine of the angle between the two lines, along with the error. -- Results in a value that is ~+1 when a line points in the same direction of the other given line, and ~-1 when pointing backwards. angleBetweenWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, ([ErrVal], [ErrVal]), UlpSum)) -angleBetweenWithErr pl1 pl2 = (scalarPart likeRes - , resErr) +angleBetweenWithErr line1 line2 = (scalarPart likeRes + , resErr) where resErr = (npl1Err, npl2Err, (likeMulErr,likeAddErr), ulpSum) + -- FIXME: this returned ULPsum is wrong. actually try to interpret it. ulpSum = sumErrVals likeMulErr <> sumErrVals likeAddErr (likeRes, (likeMulErr, likeAddErr)) = l1 ⎣+ l2 l1 = vecOfL $ forceBasisOfL npl1 l2 = vecOfL $ forceBasisOfL npl2 - (npl1, npl1Err) = normalizePLine2WithErr pl1 - (npl2, npl2Err) = normalizePLine2WithErr pl2 + (npl1, npl1Err) = normalizePLine2WithErr line1 + (npl2, npl2Err) = normalizePLine2WithErr line2 -- | Reverse a line. same line, but pointed in the other direction. flipProjectiveLine :: (ProjectiveLine2 a) => a -> a -flipProjectiveLine pline = (consLikeL pline) rawRes +flipProjectiveLine line = (consLikeL line) rawRes where rawRes = GVec $ foldl' addValWithoutErr [] [ @@ -230,14 +235,7 @@ flipProjectiveLine pline = (consLikeL pline) rawRes , GVal (negate $ valOf 0 $ getVal [GEPlus 1] vals) (singleton (GEPlus 1)) , GVal (negate $ valOf 0 $ getVal [GEPlus 2] vals) (singleton (GEPlus 2)) ] - (GVec vals) = vecOfL pline - --- | perform basis coersion. ensure all of the required '0' components exist. required before using basis sensitive raw operators. -forceBasis :: [Set GNum] -> GVec -> GVec -forceBasis numsets (GVec vals) = GVec $ forceVal vals <$> sort numsets - where - forceVal :: [GVal] -> Set GNum -> GVal - forceVal has needs = GVal (valOf 0 $ getVal (elems needs) has) needs + (GVec vals) = vecOfL line -- | runtime basis coersion. ensure all of the '0' components exist on a Projective Line. forceProjectiveLineBasis :: (ProjectiveLine2 a) => a -> a @@ -247,11 +245,11 @@ forceProjectiveLineBasis line singleton (GEPlus 2)] = line | otherwise = (consLikeL line) res where - res = forceBasis [singleton (GEZero 1), singleton (GEPlus 1), singleton (GEPlus 2)] pvec + res = forceBasis [singleton (GEZero 1), singleton (GEPlus 1), singleton (GEPlus 2)] vec gnums = case vals of [GVal _ g1, GVal _ g2, GVal _ g3] -> Just [g1,g2,g3] _ -> Nothing - pvec@(GVec vals) = vecOfL line + vec@(GVec vals) = vecOfL line -- | A typed meet function. the meeting of two lines is a point. meet2ProjectiveLinesWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PPoint2, UlpSum) @@ -276,18 +274,18 @@ normalizePLine2WithErr line = (res, resErr) (norm, normErr) = normOfL line vec = vecOfL line --- | find the norm of a given Projective Line. +-- | Find the norm of a given Projective Line. normOfProjectiveLineWithErr :: (ProjectiveLine2 a) => a -> (ℝ, PLine2Err) -normOfProjectiveLineWithErr pline = (res, resErr) +normOfProjectiveLineWithErr line = (res, resErr) where (res, resErr) = case sqNormOfPLine2 of 1.0 -> (1.0 , PLine2Err mempty mempty mempty sqNormUlp mempty mempty) _ -> (sqrt sqNormOfPLine2, PLine2Err mempty mempty rawResUlp sqNormUlp mempty mempty) - (sqNormOfPLine2, sqNormUlp) = sqNormOfL pline rawRes = sqrt sqNormOfPLine2 rawResUlp = UlpSum (abs $ realToFrac $ doubleUlp rawRes) + (sqNormOfPLine2, sqNormUlp) = sqNormOfL line --- | find the squared norm of a given Projective Line. +-- | Find the squared norm of a given Projective Line. sqNormOfProjectiveLineWithErr :: (ProjectiveLine2 a) => a -> (ℝ, UlpSum) sqNormOfProjectiveLineWithErr line = (res, ulpTotal) where @@ -301,7 +299,7 @@ sqNormOfProjectiveLineWithErr line = (res, ulpTotal) (GVec vals) = vecOfL line -- | Translate a line a given distance along it's perpendicular bisector. --- Abuses the property that translation of a line is expressed on the GEZero component. +-- Uses the property that translation of a line is expressed on the GEZero component. translateProjectiveLine2WithErr :: (ProjectiveLine2 a) => a -> ℝ -> (PLine2, PLine2Err) translateProjectiveLine2WithErr line d = (PLine2 res, normErr <> PLine2Err resErrs mempty mempty mempty tUlp mempty) where @@ -316,6 +314,10 @@ translateProjectiveLine2WithErr line d = (PLine2 res, normErr <> PLine2Err resEr --- Projective Point Support --- -------------------------------- +-- | A projective point in 2D space. +newtype PPoint2 = PPoint2 GVec + deriving (Eq, Ord, Generic, NFData, Show) + -- | A canonicalized projective point in 2D space. newtype CPPoint2 = CPPoint2 GVec deriving (Eq, Generic, NFData, Show) @@ -353,10 +355,13 @@ instance Semigroup PPoint2Err where instance Monoid PPoint2Err where mempty = PPoint2Err mempty mempty mempty mempty mempty mempty mempty --- | Can this node be resolved into a point in 2d space? +-- | typeclass for points and projective points. class Pointable a where + -- | Can this node be resolved into a point in 2d space? canPoint :: a -> Bool + -- | get a projective representation of this point. pPointOf :: a -> PPoint2 + -- | get a euclidian representation of this point. ePointOf :: a -> Point2 -- | does this node have an output (resulting) pLine? @@ -439,11 +444,11 @@ forceProjectivePointBasis point fromList [GEPlus 1, GEPlus 2]] = point | otherwise = (consLikeP point) res where - res = forceBasis [fromList [GEZero 1, GEPlus 1], fromList [GEZero 1, GEPlus 2], fromList [GEPlus 1, GEPlus 2]] pvec + res = forceBasis [fromList [GEZero 1, GEPlus 1], fromList [GEZero 1, GEPlus 2], fromList [GEPlus 1, GEPlus 2]] vec gnums = case vals of [GVal _ g1, GVal _ g2, GVal _ g3] -> Just [g1,g2,g3] _ -> Nothing - pvec@(GVec vals) = vecOfP point + vec@(GVec vals) = vecOfP point -- | find the idealized norm of a projective point (ideal or not). idealNormPPoint2WithErr :: (ProjectivePoint2 a) => a -> (ℝ, UlpSum) @@ -468,13 +473,13 @@ idealNormPPoint2WithErr ppoint -- | a typed join function. join two points, returning a line. join2ProjectivePointsWithErr :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> (PLine2, (PPoint2Err, PPoint2Err, PLine2Err)) join2ProjectivePointsWithErr pp1 pp2 = (PLine2 res, - (cp1Ulp, cp2Ulp, PLine2Err mempty mempty mempty mempty mempty resUlp)) + (cp1Errs, cp2Errs, PLine2Err mempty mempty mempty mempty mempty resUlp)) where (res,resUlp) = pv1 ∨+ pv2 pv1 = vecOfP $ forceBasisOfP cp1 pv2 = vecOfP $ forceBasisOfP cp2 - (cp1, cp1Ulp) = canonicalizePPoint2WithErr pp1 - (cp2, cp2Ulp) = canonicalizePPoint2WithErr pp2 + (cp1, cp1Errs) = canonicalizePPoint2WithErr pp1 + (cp2, cp2Errs) = canonicalizePPoint2WithErr pp2 -- | Maybe create a euclidian point from a projective point. Will fail if the projective point is ideal. projectivePointToPoint2 :: (ProjectivePoint2 a) => a -> Maybe (Point2, PPoint2Err) From bd9dbeecc6741eceb002adfe2d7be7f0ffeabf9c Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Tue, 18 Oct 2022 21:22:11 +0000 Subject: [PATCH 031/206] move intersection into our ProjectiveLine2 typeclass. --- Graphics/Slicer/Math/PGA.hs | 38 ++++++----------- Graphics/Slicer/Math/PGAPrimitives.hs | 48 ++++++++++++++-------- tests/Math/PGA.hs | 14 ++++--- tests/golden/C0-Faces-Default.ganja.js | 8 ++-- tests/golden/C0-Faces-Ordered.ganja.js | 8 ++-- tests/golden/C0-Straight_Skeleton.ganja.js | 8 ++-- tests/golden/C1-Straight_Skeleton.ganja.js | 8 ++-- tests/golden/C2-Straight_Skeleton.ganja.js | 8 ++-- tests/golden/C3-Straight_Skeleton.ganja.js | 8 ++-- tests/golden/C4-Straight_Skeleton.ganja.js | 8 ++-- 10 files changed, 81 insertions(+), 75 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index f98af2db4..b9de69eea 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -45,13 +45,13 @@ module Graphics.Slicer.Math.PGA( eToPLine2WithErr, eToPPoint2, flipL, + intersect2PL, intersectsWith, intersectsWithErr, join2PP, makePPoint2, normalize, outputIntersectsLineSeg, - pLineIntersectionWithErr, pLineIsLeft, pPointBetweenPPointsWithErr, pPointOnPerpWithErr, @@ -91,7 +91,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (GNum(G0, GEPlus, GEZero), GVal(GVa import Graphics.Slicer.Math.Line (combineLineSegs) -import Graphics.Slicer.Math.PGAPrimitives(Arcable(hasArc, outOf, outUlpMag, ulpOfOut), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(angleBetween2PL, flipL, forceBasisOfL, meetOf2PL, normalize, normOfL, translateL, vecOfL), ProjectivePoint2(canonicalize, forceBasisOfP, idealNormOfP, join2PP, pToEP, vecOfP)) +import Graphics.Slicer.Math.PGAPrimitives(Arcable(hasArc, outOf, outUlpMag, ulpOfOut), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(angleBetween2PL, flipL, forceBasisOfL, intersect2PL, normalize, normOfL, translateL, vecOfL), ProjectivePoint2(canonicalize, forceBasisOfP, idealNormOfP, join2PP, pToEP, vecOfP)) -- Our 2D plane coresponds to a Clifford algebra of 2,0,1. @@ -119,12 +119,12 @@ plinesIntersectIn pl1 pl2 else PAntiCollinear | sameDirection pl1 pl2 = PParallel | oppositeDirection pl1 pl2 = PAntiParallel - | otherwise = IntersectsIn res (resUlp, intersectUlp, npl1Ulp, npl2Ulp, iaErr, mempty) + | otherwise = IntersectsIn res (resUlp, mempty, npl1Ulp, npl2Ulp, iaErr, mempty) where (idealNorm, idnErr) = idealNormOfP intersectPoint (_, iaErr) = angleBetween2PL pl1 pl2 -- FIXME: how much do the potential normalization errors have an effect on the resultant angle? - (intersectPoint, intersectUlp) = pLineIntersectionWithErr pl1 pl2 + (intersectPoint, intersectUlp) = intersect2PL pl1 pl2 -- FIXME: remove the canonicalization from this function, moving it to the callers. (res, resUlp) = fromJust canonicalizedIntersection canonicalizedIntersection = canonicalizeIntersectionWithErr pl1 pl2 @@ -158,15 +158,6 @@ pLineIsLeft pl1 pl2 lvec1 = vecOfL l1 lvec2 = vecOfL l2 --- | Find out where two lines intersect, returning a projective point, and the error quotent. Note that this should only be used when you can guarantee these are not collinear, or parallel. -pLineIntersectionWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PPoint2, UlpSum) -pLineIntersectionWithErr pl1 pl2 = (res, ulpTotal) - where - (res, resErr) = meetOf2PL pl1 pl2 - (_, npl1Err) = normalize pl1 - (_, npl2Err) = normalize pl2 - ulpTotal = resErr <> npl1Err <> npl2Err - -- FIXME: automatically raise addVecRes to a CPPoint2 if it turns out to be canonical? pPointBetweenPPointsWithErr :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> ℝ -> ℝ -> (PPoint2, UlpSum) pPointBetweenPPointsWithErr startP stopP weight1 weight2 @@ -399,7 +390,7 @@ pLineIntersectsLineSeg (pl1, UlpSum pl1Err) (l1, UlpSum l1Err) ulpScale | hasIntersection && valOf 0 foundVal == 0 = error "intersection, but cannot cannonicalize." | hasIntersection && startDistance <= ulpStartSum = Left $ HitStartPoint l1 | hasIntersection && endDistance <= ulpEndSum = Left $ HitEndPoint l1 - | hasIntersection = Right $ IntersectsIn rawIntersection (UlpSum $ realToFrac ulpStartSum, UlpSum $ realToFrac ulpEndSum, UlpSum pl1Err, UlpSum pl2Err, UlpSum rawIntersectErr, UlpSum rawIntersectionErr) + | hasIntersection = Right $ IntersectsIn rawIntersection (UlpSum $ realToFrac ulpStartSum, UlpSum $ realToFrac ulpEndSum, UlpSum pl1Err, UlpSum pl2Err, mempty, UlpSum rawIntersectionErr) | hasRawIntersection = Left $ NoIntersection rawIntersection (UlpSum $ realToFrac ulpStartSum, UlpSum $ realToFrac ulpEndSum, mempty, mempty) | otherwise = Left $ NoIntersection ((\(PPoint2 v) -> CPPoint2 v) rawIntersect) (mempty, mempty, mempty, mempty) where @@ -412,16 +403,14 @@ pLineIntersectsLineSeg (pl1, UlpSum pl1Err) (l1, UlpSum l1Err) ulpScale ulpEndSum = realToFrac $ ulpTotal+endDistanceErr -- | the sum of all ULPs. used to expand the hitcircle of an endpoint. -- Note: we do not use rawIntersectionErr here. - ulpTotal - | pl1Err < 0 || pl2Err < 0 || l1Err < 0 || rawIntersectErr < 0 = error "negative ULP?\n" - | otherwise = pl1Err + pl2Err + l1Err + (rawIntersectErr * realToFrac ulpScale) + ulpTotal = pl1Err + pl2Err + l1Err dumpULPs = "pl1Err: " <> show pl1Err <> "\npl2Err: " <> show pl2Err <> "\nl1Err: " <> show l1Err <> "\nrawIntersectErr: " <> show rawIntersectErr <> "\n" hasIntersection = hasRawIntersection && onSegment l1 rawIntersection ulpStartSum ulpEndSum hasRawIntersection = valOf 0 foundVal /= 0 foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(PPoint2 (GVec vals)) -> vals) rawIntersect -- FIXME: remove the canonicalization from this function, moving it to the callers. (rawIntersection, UlpSum rawIntersectionErr) = canonicalize rawIntersect - (rawIntersect, UlpSum rawIntersectErr) = pLineIntersectionWithErr pl1 pl2 + (rawIntersect, rawIntersectErr) = intersect2PL pl1 pl2 (pl2, UlpSum pl2Err) = eToPLine2WithErr l1 -- | Check if/where two line segments intersect. @@ -438,7 +427,7 @@ lineSegIntersectsLineSeg (l1, UlpSum l1Err) (l2, UlpSum ulpL2) | hasIntersection && end1Distance <= ulpEndSum1 = Left $ HitEndPoint l1 | hasIntersection && start2Distance <= ulpStartSum2 = Left $ HitStartPoint l2 | hasIntersection && end2Distance <= ulpEndSum2 = Left $ HitEndPoint l2 - | hasIntersection = Right $ IntersectsIn rawIntersection (UlpSum $ realToFrac ulpStartSum1, UlpSum $ realToFrac ulpEndSum1, UlpSum $ realToFrac ulpStartSum2, UlpSum $ realToFrac ulpEndSum2, UlpSum ulpTotal, UlpSum rawIntersectErr) + | hasIntersection = Right $ IntersectsIn rawIntersection (UlpSum $ realToFrac ulpStartSum1, UlpSum $ realToFrac ulpEndSum1, UlpSum $ realToFrac ulpStartSum2, UlpSum $ realToFrac ulpEndSum2, UlpSum ulpTotal, mempty) | hasRawIntersection = Left $ NoIntersection rawIntersection (UlpSum $ realToFrac ulpStartSum1, UlpSum $ realToFrac ulpEndSum1, UlpSum $ realToFrac ulpStartSum2, UlpSum $ realToFrac ulpEndSum2) | otherwise = Left $ NoIntersection ((\(PPoint2 p) -> CPPoint2 p) rawIntersect) (mempty, mempty, mempty, mempty) where @@ -458,9 +447,7 @@ lineSegIntersectsLineSeg (l1, UlpSum l1Err) (l2, UlpSum ulpL2) (pl1, UlpSum pl1Err) = eToPLine2WithErr l1 (pl2, UlpSum pl2Err) = eToPLine2WithErr l2 -- | the sum of all ULPs. used to expand the hitcircle of an endpoint. - ulpTotal - | pl1Err < 0 || pl2Err < 0 || l1Err < 0 || ulpL2 < 0 || rawIntersectErr < 0 || rawIntersectionErr < 0 = error "negative ULP?\n" - | otherwise = pl1Err + pl2Err + l1Err + ulpL2 + (rawIntersectErr * ulpScale) + ulpTotal = pl1Err + pl2Err + l1Err + ulpL2 ulpScale = 120 + ulpMultiplier * (realToFrac angle+angleErr) * (realToFrac angle+angleErr) (angle, UlpSum angleErr) = angleBetween2PL npl1 npl2 (npl1, _) = normalize pl1 @@ -471,7 +458,7 @@ lineSegIntersectsLineSeg (l1, UlpSum l1Err) (l2, UlpSum ulpL2) foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(PPoint2 (GVec vals)) -> vals) rawIntersect -- FIXME: remove the canonicalization from this function, moving it to the callers. (rawIntersection, UlpSum rawIntersectionErr) = canonicalize rawIntersect - (rawIntersect, UlpSum rawIntersectErr) = pLineIntersectionWithErr pl1 pl2 + (rawIntersect, rawIntersectErr) = intersect2PL pl1 pl2 -- | Given the result of intersectionPoint, find out whether this intersection point is on the given segment, or not. onSegment :: LineSeg -> CPPoint2 -> ℝ -> ℝ -> Bool @@ -570,13 +557,14 @@ ulpOfLineSeg (LineSeg (Point2 (x1,y1)) (Point2 (x2,y2))) = UlpSum $ sum $ abs . -- | Canonicalize the intersection resulting from two PLines. -- NOTE: Returns nothing when the PLines are (anti)parallel. +-- FIXME: this ulpsum is wrong. try to actually calculate a range here. canonicalizeIntersectionWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Maybe (CPPoint2, UlpSum) canonicalizeIntersectionWithErr pl1 pl2 | isNothing foundVal = Nothing | otherwise = Just (cpp1, ulpTotal) where (cpp1, canonicalizationErr) = canonicalize pp1 - (pp1, intersectionErr) = pLineIntersectionWithErr pl1 pl2 - ulpTotal = intersectionErr <> canonicalizationErr + (pp1, (_, _, intersectionErr)) = intersect2PL pl1 pl2 + ulpTotal = canonicalizationErr foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(PPoint2 (GVec vals)) -> vals) pp1 diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index 1b88c26cc..99e79558f 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -45,7 +45,7 @@ module Graphics.Slicer.Math.PGAPrimitives angleBetween2PL, flipL, forceBasisOfL, - meetOf2PL, + intersect2PL, normalize, normOfL, sqNormOfL, @@ -147,7 +147,7 @@ class ProjectiveLine2 a where consLikeL :: a -> (GVec -> a) flipL :: a -> a forceBasisOfL :: a -> a - meetOf2PL :: (ProjectiveLine2 b) => a -> b -> (PPoint2, UlpSum) + intersect2PL :: (ProjectiveLine2 b) => a -> b -> (PPoint2, (PLine2Err, PLine2Err, PPoint2Err)) normalize :: a -> (NPLine2, UlpSum) normOfL :: a -> (ℝ, PLine2Err) sqNormOfL :: a -> (ℝ, UlpSum) @@ -161,7 +161,7 @@ instance ProjectiveLine2 NPLine2 where consLikeL _ = NPLine2 flipL l = flipProjectiveLine l forceBasisOfL l = forceProjectiveLineBasis l - meetOf2PL l1 l2 = meet2ProjectiveLinesWithErr l1 l2 + intersect2PL l1 l2 = intersectionOfProjectiveLinesWithErr l1 l2 normalize l = (l, mempty) normOfL l = normOfProjectiveLineWithErr l sqNormOfL l = sqNormOfProjectiveLineWithErr l @@ -175,8 +175,8 @@ instance ProjectiveLine2 PLine2 where consLikeL _ = PLine2 flipL l = flipProjectiveLine l forceBasisOfL l = forceProjectiveLineBasis l - meetOf2PL l1 l2 = meet2ProjectiveLinesWithErr l1 l2 - normalize l = (\(b,(PLine2Err _ _ c d _ _)) -> (b,c <> d)) $ normalizePLine2WithErr l + intersect2PL l1 l2 = intersectionOfProjectiveLinesWithErr l1 l2 + normalize l = (\(b,(PLine2Err _ _ c d _ _)) -> (b,c <> d)) $ normalizeProjectiveLineWithErr l normOfL l = normOfProjectiveLineWithErr l sqNormOfL l = sqNormOfProjectiveLineWithErr l translateL l d = (\(r,(PLine2Err _ _ _ _ t _)) -> (r,t)) $ translateProjectiveLine2WithErr l d @@ -222,8 +222,8 @@ angleBetweenWithErr line1 line2 = (scalarPart likeRes (likeRes, (likeMulErr, likeAddErr)) = l1 ⎣+ l2 l1 = vecOfL $ forceBasisOfL npl1 l2 = vecOfL $ forceBasisOfL npl2 - (npl1, npl1Err) = normalizePLine2WithErr line1 - (npl2, npl2Err) = normalizePLine2WithErr line2 + (npl1, npl1Err) = normalizeProjectiveLineWithErr line1 + (npl2, npl2Err) = normalizeProjectiveLineWithErr line2 -- | Reverse a line. same line, but pointed in the other direction. flipProjectiveLine :: (ProjectiveLine2 a) => a -> a @@ -251,21 +251,37 @@ forceProjectiveLineBasis line _ -> Nothing vec@(GVec vals) = vecOfL line +-- | Find out where two lines intersect, returning a projective point, and the error quotent. +-- Note that this should only be used when you can guarantee these are not collinear, or parallel. +intersectionOfProjectiveLinesWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PPoint2, (PLine2Err, PLine2Err, PPoint2Err)) +intersectionOfProjectiveLinesWithErr line1 line2 = (res, + (npl1Err, + npl2Err, + PPoint2Err resErrs mempty mempty mempty mempty iAngleErr iAngleUnlikeErr)) + where + -- Since the angle of intersection has an effect on how well this point was resolved, save it with the point. + (iAngleErr,(_,_,iAngleUnlikeErr,_)) = angleBetweenWithErr npl1 npl2 + (res, (_,_, resErrs)) = meetOfProjectiveLinesWithErr npl1 npl2 + (npl1, npl1Err) = normalizeProjectiveLineWithErr line1 + (npl2, npl2Err) = normalizeProjectiveLineWithErr line2 + -- | A typed meet function. the meeting of two lines is a point. -meet2ProjectiveLinesWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PPoint2, UlpSum) -meet2ProjectiveLinesWithErr line1 line2 = (PPoint2 res, - ulpSum) +-- kept separate from pLineIntersection for verification reasons. +meetOfProjectiveLinesWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PPoint2, (PLine2Err, PLine2Err, ([ErrVal], [ErrVal]))) +meetOfProjectiveLinesWithErr line1 line2 = (PPoint2 res, + (npl1Err, + npl2Err, + resUnlikeErr)) where - ulpSum = sumErrVals unlikeMulErr <> sumErrVals unlikeAddErr - (res, (unlikeMulErr, unlikeAddErr)) = pv1 ⎤+ pv2 + (res, resUnlikeErr) = pv1 ⎤+ pv2 pv1 = vecOfL $ forceBasisOfL npl1 pv2 = vecOfL $ forceBasisOfL npl2 - (npl1,_) = normalize line1 - (npl2,_) = normalize line2 + (npl1, npl1Err) = normalizeProjectiveLineWithErr line1 + (npl2, npl2Err) = normalizeProjectiveLineWithErr line2 -- | Normalize a Projective Line. -normalizePLine2WithErr :: (ProjectiveLine2 a) => a -> (NPLine2, PLine2Err) -normalizePLine2WithErr line = (res, resErr) +normalizeProjectiveLineWithErr :: (ProjectiveLine2 a) => a -> (NPLine2, PLine2Err) +normalizeProjectiveLineWithErr line = (res, resErr) where (res, resErr) = case norm of 1.0 -> (NPLine2 vec , normErr) diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index d11e0cabf..d0bcfa89d 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -59,7 +59,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(GEZero, GEPlu import Graphics.Slicer.Math.Lossy (angleBetween, canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenPLines, distancePPointToPLine, eToCPPoint2, eToPLine2, getFirstArc, join2PPoint2, normalizePLine2, pPointOnPerp) -- Our 2D Projective Geometric Algebra library. -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), canonicalize, pPointBetweenPPointsWithErr, distanceBetweenPPointsWithErr, distancePPointToPLineWithErr, eToPLine2WithErr, eToPPoint2, pLineIntersectionWithErr, translateL, translateRotatePPoint2, angleBetween2PL, flipL, join2PP, makePPoint2, normalize, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, distancePPointToPLineWithErr, pPointOnPerpWithErr, outOf, pPointOf, ulpOfOut, outputIntersectsLineSeg, pPointBetweenPPointsWithErr) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), canonicalize, pPointBetweenPPointsWithErr, distanceBetweenPPointsWithErr, distancePPointToPLineWithErr, eToPLine2WithErr, eToPPoint2, intersect2PL, translateL, translateRotatePPoint2, angleBetween2PL, flipL, join2PP, makePPoint2, normalize, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, distancePPointToPLineWithErr, pPointOnPerpWithErr, outOf, pPointOf, ulpOfOut, outputIntersectsLineSeg, pPointBetweenPPointsWithErr) -- Our Contour library. import Graphics.Slicer.Math.Contour (contourContainsContour, getContours, pointsOfContour, numPointsOfContour, justOneContourFrom, lineSegsOfContour, makeLineSegContour, makePointContour, insideIsLeft, innerContourPoint, firstPointPairOfContour, firstLineSegOfContour) @@ -1362,15 +1362,16 @@ prop_NormPLineIsPLine x y dx dy = normalizePLine2 (randomPLine x y dx dy) prop_PLinesIntersectAtOrigin :: NonZero ℝ -> ℝ -> NonZero ℝ -> ℝ -> Bool prop_PLinesIntersectAtOrigin rawX y rawX2 rawY2 | foundDistance < realToFrac errSum = True - | otherwise = error "wtf" + | otherwise = error $ "wtf" + <> show intersectionErr <> "\n" where originPPoint2 = makePPoint2 0 0 (foundDistance, UlpSum distanceErr) = distanceBetweenPPointsWithErr originPPoint2 intersectionCPPoint2 (intersectionCPPoint2, UlpSum canonicalizationErr) = canonicalize intersectionPPoint2 - (intersectionPPoint2, UlpSum intersectionErr) = pLineIntersectionWithErr randomPLine1 randomPLine2 + (intersectionPPoint2, intersectionErr) = intersect2PL randomPLine1 randomPLine2 (randomPLine1, UlpSum pline1Err) = randomPLineThroughOrigin x y (randomPLine2, UlpSum pline2Err) = randomPLineThroughOrigin x2 y2 - errSum = intersectionErr + pline1Err + pline2Err + distanceErr + canonicalizationErr + errSum = pline1Err + pline2Err + distanceErr + canonicalizationErr x,x2,y2 :: ℝ x = coerce rawX x2 @@ -1390,14 +1391,15 @@ prop_PLinesIntersectAtPoint rawX y rawX2 rawY2 targetX targetY <> show targetPPoint2 <> "\n" <> show foundDistance <> "\n" <> show distanceErr <> "\n" + <> show intersectionErr <> "\n" where (targetPPoint2) = makePPoint2 (coerce targetX) (coerce targetY) (foundDistance, UlpSum distanceErr) = distanceBetweenPPointsWithErr targetPPoint2 intersectionCPPoint2 (intersectionCPPoint2, UlpSum canonicalizationErr) = canonicalize intersectionPPoint2 - (intersectionPPoint2, UlpSum intersectionErr) = pLineIntersectionWithErr randomPLine1 randomPLine2 + (intersectionPPoint2, intersectionErr) = intersect2PL randomPLine1 randomPLine2 (randomPLine1, UlpSum pline1Err) = randomPLineWithErr x y targetX targetY (randomPLine2, UlpSum pline2Err) = randomPLineWithErr x2 y2 targetX targetY - errSum = intersectionErr + pline1Err + pline2Err + distanceErr + canonicalizationErr + errSum = pline1Err + pline2Err + distanceErr + canonicalizationErr x,x2,y2 :: ℝ x = coerce rawX x2 diff --git a/tests/golden/C0-Faces-Default.ganja.js b/tests/golden/C0-Faces-Default.ganja.js index 5d876db80..ac1675c73 100644 --- a/tests/golden/C0-Faces-Default.ganja.js +++ b/tests/golden/C0-Faces-Default.ganja.js @@ -12,16 +12,16 @@ Algebra(2,0,1,()=>{ var aea = point(1.0,1.0); var aeb = point(-1.0,1.0); var af = 0.0e1-1.414213562373095e2+0.0e0; - var ag = -0.4142135623730951e1-0.17157287525381e2+0.24264068711928521e0; + var ag = -0.4142135623730951e1-0.17157287525380988e2+0.2426406871192852e0; var ah = -0.3826834323650897e1-0.9238795325112867e2+0.541196100146197e0; var ai = 0.3826834323650897e1-0.9238795325112867e2-0.541196100146197e0; - var aj = 0.41421356237309515e1-0.17157287525380993e2-0.24264068711928524e0; + var aj = 0.41421356237309515e1-0.17157287525380982e2-0.24264068711928521e0; var ak = 0.0e1-1.414213562373095e2+0.0e0; var al = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; var am = 0.3826834323650897e1-0.9238795325112867e2-0.541196100146197e0; var an = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var ao = -0.4142135623730951e1-0.17157287525381e2+0.24264068711928521e0; - var ap = 0.41421356237309515e1-0.17157287525380993e2-0.24264068711928524e0; + var ao = -0.4142135623730951e1-0.17157287525380988e2+0.2426406871192852e0; + var ap = 0.41421356237309515e1-0.17157287525380982e2-0.24264068711928521e0; var aq = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; var ar = -0.3826834323650897e1-0.9238795325112867e2+0.541196100146197e0; var as = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; diff --git a/tests/golden/C0-Faces-Ordered.ganja.js b/tests/golden/C0-Faces-Ordered.ganja.js index 553dabe73..00da3950f 100644 --- a/tests/golden/C0-Faces-Ordered.ganja.js +++ b/tests/golden/C0-Faces-Ordered.ganja.js @@ -12,18 +12,18 @@ Algebra(2,0,1,()=>{ var aea = point(-1.0,1.0); var aeb = point(0.0,0.0); var af = 0.3826834323650897e1-0.9238795325112867e2-0.541196100146197e0; - var ag = 0.41421356237309515e1-0.17157287525380993e2-0.24264068711928524e0; + var ag = 0.41421356237309515e1-0.17157287525380982e2-0.24264068711928521e0; var ah = 0.0e1-1.414213562373095e2+0.0e0; var ai = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; var aj = 0.3826834323650897e1-0.9238795325112867e2-0.541196100146197e0; var ak = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var al = -0.4142135623730951e1-0.17157287525381e2+0.24264068711928521e0; - var am = 0.41421356237309515e1-0.17157287525380993e2-0.24264068711928524e0; + var al = -0.4142135623730951e1-0.17157287525380988e2+0.2426406871192852e0; + var am = 0.41421356237309515e1-0.17157287525380982e2-0.24264068711928521e0; var an = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; var ao = -0.3826834323650897e1-0.9238795325112867e2+0.541196100146197e0; var ap = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; var aq = 0.0e1-1.414213562373095e2+0.0e0; - var ar = -0.4142135623730951e1-0.17157287525381e2+0.24264068711928521e0; + var ar = -0.4142135623730951e1-0.17157287525380988e2+0.2426406871192852e0; var as = -0.3826834323650897e1-0.9238795325112867e2+0.541196100146197e0; document.body.appendChild(this.graph([ 0x882288, diff --git a/tests/golden/C0-Straight_Skeleton.ganja.js b/tests/golden/C0-Straight_Skeleton.ganja.js index 1c71c24f2..ec90aa37e 100644 --- a/tests/golden/C0-Straight_Skeleton.ganja.js +++ b/tests/golden/C0-Straight_Skeleton.ganja.js @@ -13,13 +13,13 @@ Algebra(2,0,1,()=>{ var aeb = point(0.0,0.0); var afa = 0.3826834323650897e1-0.9238795325112867e2-0.541196100146197e0; var afb = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var afc = 0.41421356237309515e1-0.17157287525380993e2-0.24264068711928524e0; + var afc = 0.41421356237309515e1-0.17157287525380982e2-0.24264068711928521e0; var aga = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; var agb = -0.3826834323650897e1-0.9238795325112867e2+0.541196100146197e0; - var agc = -0.4142135623730951e1-0.17157287525381e2+0.24264068711928521e0; + var agc = -0.4142135623730951e1-0.17157287525380988e2+0.2426406871192852e0; var aha = 0.0e1-1.414213562373095e2+0.0e0; - var ahb = 0.41421356237309515e1-0.17157287525380993e2-0.24264068711928524e0; - var ahc = -0.4142135623730951e1-0.17157287525381e2+0.24264068711928521e0; + var ahb = 0.41421356237309515e1-0.17157287525380982e2-0.24264068711928521e0; + var ahc = -0.4142135623730951e1-0.17157287525380988e2+0.2426406871192852e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C1-Straight_Skeleton.ganja.js b/tests/golden/C1-Straight_Skeleton.ganja.js index 19575fab8..8cec104ad 100644 --- a/tests/golden/C1-Straight_Skeleton.ganja.js +++ b/tests/golden/C1-Straight_Skeleton.ganja.js @@ -13,13 +13,13 @@ Algebra(2,0,1,()=>{ var aeb = point(-1.0,1.0); var afa = -0.7071067811865475e1-0.7071067811865475e2+0.0e0; var afb = 0.9238795325112867e1-0.3826834323650897e2+0.541196100146197e0; - var afc = 0.17157287525381e1-0.4142135623730951e2+0.24264068711928521e0; + var afc = 0.17157287525380988e1-0.4142135623730951e2+0.2426406871192852e0; var aga = 0.9238795325112867e1+0.3826834323650897e2-0.541196100146197e0; var agb = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var agc = 0.17157287525380993e1+0.41421356237309515e2-0.24264068711928524e0; - var aha = 0.17157287525381e1-0.4142135623730951e2+0.24264068711928521e0; + var agc = 0.17157287525380982e1+0.41421356237309515e2-0.24264068711928521e0; + var aha = 0.17157287525380988e1-0.4142135623730951e2+0.2426406871192852e0; var ahb = 1.414213562373095e1+0.0e2+0.0e0; - var ahc = 0.17157287525380993e1+0.41421356237309515e2-0.24264068711928524e0; + var ahc = 0.17157287525380982e1+0.41421356237309515e2-0.24264068711928521e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C2-Straight_Skeleton.ganja.js b/tests/golden/C2-Straight_Skeleton.ganja.js index 5390e93b3..f553b3e1a 100644 --- a/tests/golden/C2-Straight_Skeleton.ganja.js +++ b/tests/golden/C2-Straight_Skeleton.ganja.js @@ -13,13 +13,13 @@ Algebra(2,0,1,()=>{ var aeb = point(-1.0,-1.0); var afa = 0.7071067811865475e1-0.7071067811865475e2+0.0e0; var afb = 0.3826834323650897e1+0.9238795325112867e2+0.541196100146197e0; - var afc = 0.4142135623730951e1+0.17157287525381e2+0.24264068711928521e0; + var afc = 0.4142135623730951e1+0.17157287525380988e2+0.2426406871192852e0; var aga = -0.3826834323650897e1+0.9238795325112867e2-0.541196100146197e0; var agb = -0.7071067811865475e1-0.7071067811865475e2+0.0e0; - var agc = -0.41421356237309515e1+0.17157287525380993e2-0.24264068711928524e0; - var aha = 0.4142135623730951e1+0.17157287525381e2+0.24264068711928521e0; + var agc = -0.41421356237309515e1+0.17157287525380982e2-0.24264068711928521e0; + var aha = 0.4142135623730951e1+0.17157287525380988e2+0.2426406871192852e0; var ahb = 0.0e1+1.414213562373095e2+0.0e0; - var ahc = -0.41421356237309515e1+0.17157287525380993e2-0.24264068711928524e0; + var ahc = -0.41421356237309515e1+0.17157287525380982e2-0.24264068711928521e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C3-Straight_Skeleton.ganja.js b/tests/golden/C3-Straight_Skeleton.ganja.js index 9ee168f36..b0e98fc59 100644 --- a/tests/golden/C3-Straight_Skeleton.ganja.js +++ b/tests/golden/C3-Straight_Skeleton.ganja.js @@ -13,13 +13,13 @@ Algebra(2,0,1,()=>{ var aeb = point(0.0,0.0); var afa = -0.9238795325112867e1-0.3826834323650897e2-0.541196100146197e0; var afb = 0.7071067811865475e1-0.7071067811865475e2+0.0e0; - var afc = -0.17157287525380993e1-0.41421356237309515e2-0.24264068711928524e0; + var afc = -0.17157287525380982e1-0.41421356237309515e2-0.24264068711928521e0; var aga = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; var agb = -0.9238795325112867e1+0.3826834323650897e2+0.541196100146197e0; - var agc = -0.17157287525381e1+0.4142135623730951e2+0.24264068711928521e0; + var agc = -0.17157287525380988e1+0.4142135623730951e2+0.2426406871192852e0; var aha = -1.414213562373095e1+0.0e2+0.0e0; - var ahb = -0.17157287525380993e1-0.41421356237309515e2-0.24264068711928524e0; - var ahc = -0.17157287525381e1+0.4142135623730951e2+0.24264068711928521e0; + var ahb = -0.17157287525380982e1-0.41421356237309515e2-0.24264068711928521e0; + var ahc = -0.17157287525380988e1+0.4142135623730951e2+0.2426406871192852e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C4-Straight_Skeleton.ganja.js b/tests/golden/C4-Straight_Skeleton.ganja.js index 1c71c24f2..ec90aa37e 100644 --- a/tests/golden/C4-Straight_Skeleton.ganja.js +++ b/tests/golden/C4-Straight_Skeleton.ganja.js @@ -13,13 +13,13 @@ Algebra(2,0,1,()=>{ var aeb = point(0.0,0.0); var afa = 0.3826834323650897e1-0.9238795325112867e2-0.541196100146197e0; var afb = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var afc = 0.41421356237309515e1-0.17157287525380993e2-0.24264068711928524e0; + var afc = 0.41421356237309515e1-0.17157287525380982e2-0.24264068711928521e0; var aga = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; var agb = -0.3826834323650897e1-0.9238795325112867e2+0.541196100146197e0; - var agc = -0.4142135623730951e1-0.17157287525381e2+0.24264068711928521e0; + var agc = -0.4142135623730951e1-0.17157287525380988e2+0.2426406871192852e0; var aha = 0.0e1-1.414213562373095e2+0.0e0; - var ahb = 0.41421356237309515e1-0.17157287525380993e2-0.24264068711928524e0; - var ahc = -0.4142135623730951e1-0.17157287525381e2+0.24264068711928521e0; + var ahb = 0.41421356237309515e1-0.17157287525380982e2-0.24264068711928521e0; + var ahc = -0.4142135623730951e1-0.17157287525380988e2+0.2426406871192852e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], From 42f55f7218d1ab6c7e7c2363625927f48b0aae0a Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Fri, 21 Oct 2022 19:57:26 +0000 Subject: [PATCH 032/206] add eToPL and normalizeL. use those to change angleBetweenWithErr to handle input error. --- Graphics/Slicer/Math/Lossy.hs | 4 +- Graphics/Slicer/Math/PGA.hs | 65 +++++++++++--------- Graphics/Slicer/Math/PGAPrimitives.hs | 30 ++++++--- Graphics/Slicer/Math/Skeleton/Cells.hs | 6 +- Graphics/Slicer/Math/Skeleton/Concave.hs | 6 +- Graphics/Slicer/Math/Skeleton/Motorcycles.hs | 14 ++--- tests/Math/PGA.hs | 18 +++--- 7 files changed, 83 insertions(+), 60 deletions(-) diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index c8b62e30c..89e554b2e 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -39,7 +39,7 @@ module Graphics.Slicer.Math.Lossy ( translatePLine2 ) where -import Prelude (($), fst) +import Prelude (($), fst, mempty) -- The numeric type in HSlice. import Graphics.Slicer.Definitions (ℝ) @@ -51,7 +51,7 @@ import Graphics.Slicer.Math.Arcs (getFirstArcWithErr, getInsideArcWithErr) import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PPoint2, ProjectiveLine2, ProjectivePoint2, angleBetween2PL, canonicalize, distanceBetweenPPointsWithErr, distanceBetweenPLinesWithErr, distancePPointToPLineWithErr, eToPLine2WithErr, eToPPoint2, join2PP, normalize, pPointBetweenPPointsWithErr, pPointOnPerpWithErr, pToEP, translateL) angleBetween :: NPLine2 -> NPLine2 -> ℝ -angleBetween nPLine1 nPLine2 = fst $ angleBetween2PL nPLine1 nPLine2 +angleBetween nPLine1 nPLine2 = fst $ angleBetween2PL (nPLine1, mempty) (nPLine2, mempty) -- | canonicalize a euclidian point. canonicalizePPoint2 :: PPoint2 -> CPPoint2 diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index b9de69eea..4eeee8c37 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -44,6 +44,7 @@ module Graphics.Slicer.Math.PGA( distancePPointToPLineWithErr, eToPLine2WithErr, eToPPoint2, + eToPL, flipL, intersect2PL, intersectsWith, @@ -51,6 +52,7 @@ module Graphics.Slicer.Math.PGA( join2PP, makePPoint2, normalize, + normalizeL, outputIntersectsLineSeg, pLineIsLeft, pPointBetweenPPointsWithErr, @@ -91,7 +93,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (GNum(G0, GEPlus, GEZero), GVal(GVa import Graphics.Slicer.Math.Line (combineLineSegs) -import Graphics.Slicer.Math.PGAPrimitives(Arcable(hasArc, outOf, outUlpMag, ulpOfOut), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(angleBetween2PL, flipL, forceBasisOfL, intersect2PL, normalize, normOfL, translateL, vecOfL), ProjectivePoint2(canonicalize, forceBasisOfP, idealNormOfP, join2PP, pToEP, vecOfP)) +import Graphics.Slicer.Math.PGAPrimitives(Arcable(hasArc, outOf, outUlpMag, ulpOfOut), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(angleBetween2PL, flipL, forceBasisOfL, intersect2PL, normalize, normalizeL, normOfL, translateL, vecOfL), ProjectivePoint2(canonicalize, forceBasisOfP, idealNormOfP, join2PP, join2PPWithErr, pToEP, vecOfP)) -- Our 2D plane coresponds to a Clifford algebra of 2,0,1. @@ -113,23 +115,23 @@ plinesIntersectIn :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> PInters plinesIntersectIn pl1 pl2 | isNothing canonicalizedIntersection || (idealNorm <= realToFrac (ulpVal idnErr) - && (sameDirection pl1 pl2 || - oppositeDirection pl1 pl2)) = if sameDirection pl1 pl2 - then PCollinear - else PAntiCollinear - | sameDirection pl1 pl2 = PParallel - | oppositeDirection pl1 pl2 = PAntiParallel - | otherwise = IntersectsIn res (resUlp, mempty, npl1Ulp, npl2Ulp, iaErr, mempty) + && (sameDirection npl1 npl2 || + oppositeDirection npl1 npl2)) = if sameDirection npl1 npl2 + then PCollinear + else PAntiCollinear + | sameDirection npl1 npl2 = PParallel + | oppositeDirection npl1 npl2 = PAntiParallel + | otherwise = IntersectsIn res (resUlp, mempty, mempty, mempty, iaErr, mempty) where (idealNorm, idnErr) = idealNormOfP intersectPoint - (_, iaErr) = angleBetween2PL pl1 pl2 + (_, iaErr) = angleBetween2PL npl1 npl2 -- FIXME: how much do the potential normalization errors have an effect on the resultant angle? (intersectPoint, intersectUlp) = intersect2PL pl1 pl2 -- FIXME: remove the canonicalization from this function, moving it to the callers. (res, resUlp) = fromJust canonicalizedIntersection canonicalizedIntersection = canonicalizeIntersectionWithErr pl1 pl2 - (_, npl1Ulp) = normalize pl1 - (_, npl2Ulp) = normalize pl2 + npl1 = normalizeL pl1 + npl2 = normalizeL pl2 -- | Check if the second line's direction is on the 'left' side of the first line, assuming they intersect. If they don't intersect, return Nothing. pLineIsLeft :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Maybe Bool @@ -232,8 +234,8 @@ distanceBetweenPLinesWithErr line1 line2 = (ideal, resUlpSum) -- | A checker, to ensure two Projective Lines are going the same direction, and are parallel. -- FIXME: precision on inputs? -sameDirection :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Bool -sameDirection a b = res >= maxAngle +sameDirection :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Bool +sameDirection a b = res >= maxAngle where -- ceiling value. a value bigger than maxAngle is considered to be going the same direction. maxAngle :: ℝ @@ -242,7 +244,7 @@ sameDirection a b = res >= maxAngle -- | A checker, to ensure two Projective Lines are going the opposite direction, and are parallel. -- FIXME: precision on inputs? -oppositeDirection :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Bool +oppositeDirection :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Bool oppositeDirection a b = res <= minAngle where -- floor value. a value smaller than minAngle is considered to be going the opposite direction. @@ -331,13 +333,13 @@ outputIntersectsLineSeg source (l1, UlpSum l1Err) | otherwise = pLineIntersectsLineSeg (pl1, UlpSum pl1Err) (l1, UlpSum l1Err) ulpScale where foundError :: ℝ - foundError = realToFrac $ l1Err + pl1Err + pl2Err + npl1Err + npl2Err + rawIntersectionErr + intersectionDistanceErr + canonicalizedSourceErr + foundError = realToFrac $ l1Err + pl1Err + pl2Err + rawIntersectionErr + intersectionDistanceErr + canonicalizedSourceErr -- | the multiplier used to expand the hitcircle of an endpoint. ulpScale :: ℝ ulpScale = realToFrac $ ulpMultiplier * realToFrac travelUlpMul * abs (realToFrac angle + angleErr) - (angle, UlpSum angleErr) = angleBetween2PL pl1 pl2 - (_, UlpSum npl1Err) = normalize pl1 - (_, UlpSum npl2Err) = normalize pl2 + (angle, UlpSum angleErr) = angleBetween2PL (npl1, npl2Err) (npl2, npl2Err) + (npl1, npl1Err) = normalizeL pl1 + (npl2, npl2Err) = normalizeL pl2 (pl2, UlpSum pl2Err) = eToPLine2WithErr l1 -- the multiplier to account for distance between our Pointable, and where it intersects. travelUlpMul @@ -366,17 +368,17 @@ intersectsWithErr (Left l1@(rawL1,_)) (Right pl1@(rawPL1,_)) = where ulpScale :: ℝ ulpScale = realToFrac $ ulpMultiplier * (abs (realToFrac angle) + angleErr) - (angle, UlpSum angleErr) = angleBetween2PL npl1 npl2 - (npl1, _) = normalize rawPL1 - (npl2, _) = normalize pl2 + (angle, UlpSum angleErr) = angleBetween2PL (npl1, npl1Err) (npl2, npl2Err) + (npl1, npl1Err) = normalizeL rawPL1 + (npl2, npl2Err) = normalizeL pl2 (pl2, _) = eToPLine2WithErr rawL1 intersectsWithErr (Right pl1@(rawPL1,_)) (Left l1@(rawL1,_)) = pLineIntersectsLineSeg pl1 l1 ulpScale where ulpScale :: ℝ ulpScale = realToFrac $ ulpMultiplier * (abs (realToFrac angle) + angleErr) - (angle, UlpSum angleErr) = angleBetween2PL npl1 npl2 - (npl1, _) = normalize rawPL1 - (npl2, _) = normalize pl2 + (angle, UlpSum angleErr) = angleBetween2PL (npl1, npl1Err) (npl2, npl2Err) + (npl1, npl1Err) = normalizeL rawPL1 + (npl2, npl2Err) = normalizeL pl2 (pl2, _) = eToPLine2WithErr rawL1 -- | Check if/where a line segment and a PLine intersect. @@ -449,15 +451,15 @@ lineSegIntersectsLineSeg (l1, UlpSum l1Err) (l2, UlpSum ulpL2) -- | the sum of all ULPs. used to expand the hitcircle of an endpoint. ulpTotal = pl1Err + pl2Err + l1Err + ulpL2 ulpScale = 120 + ulpMultiplier * (realToFrac angle+angleErr) * (realToFrac angle+angleErr) - (angle, UlpSum angleErr) = angleBetween2PL npl1 npl2 - (npl1, _) = normalize pl1 - (npl2, _) = normalize pl2 + (angle, UlpSum angleErr) = angleBetween2PL (npl1, npl1Err) (npl2, npl2Err) + (npl1, npl1Err) = normalizeL pl1 + (npl2, npl2Err) = normalizeL pl2 dumpULPs = "pl1Err: " <> show pl1Err <> "\npl2Err: " <> show pl2Err <> "\nl1Err: " <> show l1Err <> "\nrawIntersectErr: " <> show rawIntersectErr <> "\n" hasIntersection = hasRawIntersection && onSegment l1 rawIntersection ulpStartSum1 ulpEndSum1 && onSegment l2 rawIntersection ulpStartSum2 ulpEndSum2 hasRawIntersection = valOf 0 foundVal /= 0 foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(PPoint2 (GVec vals)) -> vals) rawIntersect -- FIXME: remove the canonicalization from this function, moving it to the callers. - (rawIntersection, UlpSum rawIntersectionErr) = canonicalize rawIntersect + (rawIntersection, _) = canonicalize rawIntersect (rawIntersect, rawIntersectErr) = intersect2PL pl1 pl2 -- | Given the result of intersectionPoint, find out whether this intersection point is on the given segment, or not. @@ -542,6 +544,11 @@ eToPLine2WithErr l1 = (res, resErr) where (res, resErr) = join2PP (eToPPoint2 $ startPoint l1) (eToPPoint2 $ endPoint l1) +eToPL :: LineSeg -> (PLine2, PLine2Err) +eToPL l1 = (res, resErr) + where + (res, resErr) = join2PPWithErr (eToPPoint2 $ startPoint l1) (eToPPoint2 $ endPoint l1) + -- | Get the sum of the error involved in storing the values in a given PLine2. ulpOfPLine2 :: (ProjectiveLine2 a) => a -> UlpSum ulpOfPLine2 line = UlpSum $ sum $ abs . realToFrac . doubleUlp . (\(GVal r _) -> r) <$> catMaybes @@ -564,7 +571,7 @@ canonicalizeIntersectionWithErr pl1 pl2 | otherwise = Just (cpp1, ulpTotal) where (cpp1, canonicalizationErr) = canonicalize pp1 - (pp1, (_, _, intersectionErr)) = intersect2PL pl1 pl2 + (pp1, _) = intersect2PL pl1 pl2 ulpTotal = canonicalizationErr foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(PPoint2 (GVec vals)) -> vals) pp1 diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index 99e79558f..15c018626 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -47,6 +47,7 @@ module Graphics.Slicer.Math.PGAPrimitives forceBasisOfL, intersect2PL, normalize, + normalizeL, normOfL, sqNormOfL, translateL, @@ -57,12 +58,13 @@ module Graphics.Slicer.Math.PGAPrimitives forceBasisOfP, idealNormOfP, join2PP, + join2PPWithErr, pToEP, vecOfP ) ) where -import Prelude(Bool, Eq((==),(/=)), Monoid(mempty), Ord, Semigroup((<>)), Show(show), ($), (+), (*), (<$>), abs, error, filter, negate, otherwise, realToFrac, sqrt) +import Prelude(Bool, Eq((==),(/=)), Monoid(mempty), Ord, Semigroup((<>)), Show(show), ($), (+), (*), (<$>), (&&), abs, error, filter, negate, otherwise, realToFrac, sqrt) import Control.DeepSeq (NFData) @@ -143,12 +145,13 @@ newtype NPLine2 = NPLine2 GVec deriving (Eq, Generic, NFData, Show) class ProjectiveLine2 a where - angleBetween2PL :: (ProjectiveLine2 b) => a -> b -> (ℝ, UlpSum) + angleBetween2PL :: (ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> (ℝ, UlpSum) consLikeL :: a -> (GVec -> a) flipL :: a -> a forceBasisOfL :: a -> a intersect2PL :: (ProjectiveLine2 b) => a -> b -> (PPoint2, (PLine2Err, PLine2Err, PPoint2Err)) normalize :: a -> (NPLine2, UlpSum) + normalizeL :: a -> (NPLine2, PLine2Err) normOfL :: a -> (ℝ, PLine2Err) sqNormOfL :: a -> (ℝ, UlpSum) translateL :: a -> ℝ -> (PLine2, UlpSum) @@ -163,6 +166,7 @@ instance ProjectiveLine2 NPLine2 where forceBasisOfL l = forceProjectiveLineBasis l intersect2PL l1 l2 = intersectionOfProjectiveLinesWithErr l1 l2 normalize l = (l, mempty) + normalizeL l = (l, mempty) normOfL l = normOfProjectiveLineWithErr l sqNormOfL l = sqNormOfProjectiveLineWithErr l translateL l d = (\(r,(PLine2Err _ _ _ _ t _)) -> (r,t)) $ translateProjectiveLine2WithErr l d @@ -176,7 +180,10 @@ instance ProjectiveLine2 PLine2 where flipL l = flipProjectiveLine l forceBasisOfL l = forceProjectiveLineBasis l intersect2PL l1 l2 = intersectionOfProjectiveLinesWithErr l1 l2 - normalize l = (\(b,(PLine2Err _ _ c d _ _)) -> (b,c <> d)) $ normalizeProjectiveLineWithErr l + normalize l = crushErr $ normalizeProjectiveLineWithErr l + where + crushErr (res, PLine2Err _ _ c d _ _) = (res, c <> d) + normalizeL l = normalizeProjectiveLineWithErr l normOfL l = normOfProjectiveLineWithErr l sqNormOfL l = sqNormOfProjectiveLineWithErr l translateL l d = (\(r,(PLine2Err _ _ _ _ t _)) -> (r,t)) $ translateProjectiveLine2WithErr l d @@ -212,9 +219,11 @@ instance Monoid PLine2Err where -- | Return the sine of the angle between the two lines, along with the error. -- Results in a value that is ~+1 when a line points in the same direction of the other given line, and ~-1 when pointing backwards. -angleBetweenWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, ([ErrVal], [ErrVal]), UlpSum)) -angleBetweenWithErr line1 line2 = (scalarPart likeRes - , resErr) +angleBetweenWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> (ℝ, (PLine2Err, PLine2Err, ([ErrVal], [ErrVal]), UlpSum)) +angleBetweenWithErr (line1, line1Err) (line2, line2Err) + | line1Err == mempty && line2Err == mempty = (scalarPart likeRes, resErr) + -- FIXME: use the input errors to define our output error here. + | otherwise = (scalarPart likeRes, resErr) where resErr = (npl1Err, npl2Err, (likeMulErr,likeAddErr), ulpSum) -- FIXME: this returned ULPsum is wrong. actually try to interpret it. @@ -260,7 +269,7 @@ intersectionOfProjectiveLinesWithErr line1 line2 = (res, PPoint2Err resErrs mempty mempty mempty mempty iAngleErr iAngleUnlikeErr)) where -- Since the angle of intersection has an effect on how well this point was resolved, save it with the point. - (iAngleErr,(_,_,iAngleUnlikeErr,_)) = angleBetweenWithErr npl1 npl2 + (iAngleErr,(_,_,iAngleUnlikeErr,_)) = angleBetweenWithErr (npl1, npl1Err) (npl2, npl2Err) (res, (_,_, resErrs)) = meetOfProjectiveLinesWithErr npl1 npl2 (npl1, npl1Err) = normalizeProjectiveLineWithErr line1 (npl2, npl2Err) = normalizeProjectiveLineWithErr line2 @@ -393,6 +402,7 @@ class (Show a) => ProjectivePoint2 a where forceBasisOfP :: a -> a idealNormOfP :: a -> (ℝ, UlpSum) join2PP :: (ProjectivePoint2 b) => a -> b -> (PLine2, UlpSum) + join2PPWithErr :: (ProjectivePoint2 b) => a -> b -> (PLine2, PLine2Err) pToEP :: a -> (Point2, UlpSum) vecOfP :: a -> GVec @@ -406,6 +416,9 @@ instance ProjectivePoint2 PPoint2 where crushErr (res, (PPoint2Err _ cp1Errs _ _ _ _ _ ,PPoint2Err _ cp2Errs _ _ _ _ _ ,PLine2Err _ _ _ _ _ (resMulErrs, resAddErrs))) = (res, sumErrVals resMulErrs <> sumErrVals resAddErrs <> sumErrVals cp1Errs <> sumErrVals cp2Errs) + join2PPWithErr a b = crushErr $ join2ProjectivePointsWithErr a b + where + crushErr (res, (_,_,resErr)) = (res, resErr) pToEP p = crushErr $ fromMaybe (error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point.") $ projectivePointToPoint2 p where crushErr (res, PPoint2Err _ cp1Errs _ _ _ _ _) = (res, sumErrVals cp1Errs) @@ -421,6 +434,9 @@ instance ProjectivePoint2 CPPoint2 where crushErr (res, (PPoint2Err _ cp1Errs _ _ _ _ _ ,PPoint2Err _ cp2Errs _ _ _ _ _ ,PLine2Err _ _ _ _ _ (resMulErrs, resAddErrs))) = (res, sumErrVals resMulErrs <> sumErrVals resAddErrs <> sumErrVals cp1Errs <> sumErrVals cp2Errs) + join2PPWithErr a b = crushErr $ join2ProjectivePointsWithErr a b + where + crushErr (res, (_,_,resErr)) = (res, resErr) pToEP p = crushErr $ fromMaybe (error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point.") $ projectivePointToPoint2 p where crushErr (res, PPoint2Err _ cp1Errs _ _ _ _ _) = (res, sumErrVals cp1Errs) diff --git a/Graphics/Slicer/Math/Skeleton/Cells.hs b/Graphics/Slicer/Math/Skeleton/Cells.hs index 113444e4a..09c09c14c 100644 --- a/Graphics/Slicer/Math/Skeleton/Cells.hs +++ b/Graphics/Slicer/Math/Skeleton/Cells.hs @@ -56,9 +56,9 @@ import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum)) import Graphics.Slicer.Math.Intersections (intersectionOf) -import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, eToCPPoint2, eToNPLine2, eToPLine2, join2PPoint2, normalizePLine2, pToEPoint2) +import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, eToCPPoint2, eToPLine2, join2PPoint2, pToEPoint2) -import Graphics.Slicer.Math.PGA (Arcable(outOf), CPPoint2(CPPoint2), Pointable(canPoint, ePointOf, pPointOf), PIntersection(PAntiCollinear, IntersectsIn), PPoint2(PPoint2), angleBetween2PL, distanceBetweenPPointsWithErr, eToPPoint2, plinesIntersectIn) +import Graphics.Slicer.Math.PGA (Arcable(outOf), CPPoint2(CPPoint2), Pointable(canPoint, ePointOf, pPointOf), PIntersection(PAntiCollinear, IntersectsIn), PPoint2(PPoint2), angleBetween2PL, distanceBetweenPPointsWithErr, eToPL, eToPPoint2, normalizeL, plinesIntersectIn) data UnsupportedReason = INodeCrossesDivide ![(INode,CellDivide)] !NodeTree deriving (Show, Eq) @@ -111,7 +111,7 @@ findDivisions contour crashTree = case motorcyclesIn crashTree of where intersectionIsBehind m = angleFound < realToFrac angleErr where - (angleFound, UlpSum angleErr) = angleBetween2PL (normalizePLine2 $ outOf m) (eToNPLine2 $ lineSegToIntersection m) + (angleFound, UlpSum angleErr) = angleBetween2PL (normalizeL $ outOf m) (eToPL $ lineSegToIntersection m) lineSegToIntersection m = makeLineSeg (ePointOf m) (pToEPoint2 intersectionPPoint) intersectionPPoint = intersectionOf (outOf firstMC) (outOf secondMC) (Slist (_:_) _) -> error "too many motorcycles." diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index 7c854c37a..f142d3040 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -62,7 +62,7 @@ import Graphics.Slicer.Math.Intersections (intersectionOf, intersectionBetween, import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, distancePPointToPLine, eToPLine2, getInsideArc, join2CPPoint2, normalizePLine2) -import Graphics.Slicer.Math.PGA (Arcable(hasArc, outOf), Pointable(canPoint, pPointOf), PLine2(PLine2), ProjectivePoint2, CPPoint2(CPPoint2), PPoint2(PPoint2), canonicalize, flipL, distanceBetweenPPointsWithErr, pLineIsLeft, angleBetween2PL, distancePPointToPLineWithErr, NPLine2(NPLine2)) +import Graphics.Slicer.Math.PGA (Arcable(hasArc, outOf), Pointable(canPoint, pPointOf), PLine2(PLine2), ProjectivePoint2, CPPoint2(CPPoint2), PPoint2(PPoint2), canonicalize, distanceBetweenPPointsWithErr, flipL, normalizeL, pLineIsLeft, angleBetween2PL, distancePPointToPLineWithErr, NPLine2(NPLine2)) import Graphics.Slicer.Math.Skeleton.Definitions (ENode(ENode), ENodeSet(ENodeSet), INode(INode), INodeSet(INodeSet), NodeTree(NodeTree), concavePLines, getFirstLineSeg, getLastLineSeg, finalOutOf, firstInOf, getPairs, indexPLinesTo, insOf, lastINodeOf, linePairs, makeINode, sortedPLines, isLoop) @@ -219,9 +219,9 @@ towardIntersection pp1 pl1 pp2 | d <= realToFrac dErr = error $ "cannot resolve points finely enough.\nPPoint1: " <> show pp1 <> "\nPPoint2: " <> show pp2 <> "\nPLineIn: " <> show pl1 <> "\nnewPLine: " <> show newPLine <> "\n" | otherwise = angleFound > realToFrac angleErr where - (angleFound, UlpSum angleErr) = angleBetween2PL newPLine (normalizePLine2 pl1) + (angleFound, UlpSum angleErr) = angleBetween2PL newPLine (normalizeL pl1) (d, UlpSum dErr) = distanceBetweenPPointsWithErr (fst $ canonicalize pp1) pp2 - newPLine = normalizePLine2 $ join2CPPoint2 (fst $ canonicalize pp1) pp2 + newPLine = normalizeL $ join2CPPoint2 (fst $ canonicalize pp1) pp2 -- | Make a first generation node. makeENode :: Point2 -> Point2 -> Point2 -> ENode diff --git a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs index 9ac228267..f6e2f3cb7 100644 --- a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs +++ b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs @@ -48,9 +48,9 @@ import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, distance, map import Graphics.Slicer.Math.Intersections (getMotorcycleSegSetIntersections, getMotorcycleContourIntersections, intersectionOf, isAntiCollinear, noIntersection) -import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, pPointBetweenPPoints, distanceBetweenPPoints, eToNPLine2, eToCPPoint2, eToPLine2, normalizePLine2, pLineFromEndpoints, pToEPoint2, translatePLine2) +import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, pPointBetweenPPoints, distanceBetweenPPoints, eToCPPoint2, eToPLine2, normalizePLine2, pLineFromEndpoints, pToEPoint2, translatePLine2) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2(NPLine2), PLine2(PLine2), PPoint2, Arcable(outOf), Pointable(canPoint, ePointOf, pPointOf), flipL, pLineIsLeft, pPointsOnSameSideOfPLine, PIntersection(IntersectsIn,PAntiCollinear), plinesIntersectIn, angleBetween2PL, outputIntersectsLineSeg, ulpOfPLine2, ulpOfLineSeg) +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2(NPLine2), PLine2(PLine2), PPoint2, Arcable(outOf), Pointable(canPoint, ePointOf, pPointOf), eToPL, flipL, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, PIntersection(IntersectsIn,PAntiCollinear), plinesIntersectIn, angleBetween2PL, outputIntersectsLineSeg, ulpOfPLine2, ulpOfLineSeg) import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle), ENode(ENode), getFirstLineSeg, linePairs, CellDivide(CellDivide), DividingMotorcycles(DividingMotorcycles), MotorcycleIntersection(WithLineSeg, WithENode, WithMotorcycle)) @@ -157,7 +157,7 @@ crashMotorcycles contour holes intersectionPPoint = intersectionOf (outOf mot1) (outOf mot2) intersectionIsBehind m = angleFound < realToFrac angleErr where - (angleFound, UlpSum angleErr) = angleBetween2PL (normalizePLine2 $ outOf m) (eToNPLine2 $ lineSegToIntersection m) + (angleFound, UlpSum angleErr) = angleBetween2PL (normalizeL $ outOf m) (eToPL $ lineSegToIntersection m) lineSegToIntersection m = makeLineSeg (ePointOf m) (pToEPoint2 intersectionPPoint) -- | Find the non-reflex virtexes of a contour and draw motorcycles from them. Useful for contours that are a 'hole' in a bigger contour. @@ -254,10 +254,10 @@ motorcycleMightIntersectWith lineSegs motorcycle where intersectionPointIsBehind point = angleFound < realToFrac angleErr where - (angleFound, UlpSum angleErr) = angleBetween2PL (normalizePLine2 $ outOf motorcycle) (eToNPLine2 $ lineSegToIntersection point) + (angleFound, UlpSum angleErr) = angleBetween2PL (normalizeL $ outOf motorcycle) (eToPL $ lineSegToIntersection point) intersectionCPPointIsBehind pPoint = angleFound < realToFrac angleErr where - (angleFound, UlpSum angleErr) = angleBetween2PL (normalizePLine2 $ outOf motorcycle) (eToNPLine2 $ lineSegToIntersectionP pPoint) + (angleFound, UlpSum angleErr) = angleBetween2PL (normalizeL $ outOf motorcycle) (eToPL $ lineSegToIntersectionP pPoint) lineSegToIntersection myPoint = makeLineSeg (ePointOf motorcycle) myPoint lineSegToIntersectionP myPPoint = makeLineSeg (ePointOf motorcycle) (pToEPoint2 myPPoint) @@ -297,10 +297,10 @@ motorcycleIntersectsAt contour motorcycle = case intersections of where intersectionPointIsBehind point = angleFound < realToFrac angleErr where - (angleFound, UlpSum angleErr) = angleBetween2PL (normalizePLine2 $ outOf motorcycle) (eToNPLine2 $ lineSegToIntersection point) + (angleFound, UlpSum angleErr) = angleBetween2PL (normalizeL $ outOf motorcycle) (eToPL $ lineSegToIntersection point) intersectionPPointIsBehind pPoint = angleFound < realToFrac angleErr where - (angleFound, UlpSum angleErr) = angleBetween2PL (normalizePLine2 $ outOf motorcycle) (eToNPLine2 $ lineSegToIntersectionP pPoint) + (angleFound, UlpSum angleErr) = angleBetween2PL (normalizeL $ outOf motorcycle) (eToPL $ lineSegToIntersectionP pPoint) lineSegToIntersection myPoint = makeLineSeg (ePointOf motorcycle) myPoint lineSegToIntersectionP myPPoint = makeLineSeg (ePointOf motorcycle) (pToEPoint2 myPPoint) motorcyclePoint = canonicalizePPoint2 $ pPointOf motorcycle diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index d0bcfa89d..ac2449f44 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -59,7 +59,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(GEZero, GEPlu import Graphics.Slicer.Math.Lossy (angleBetween, canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenPLines, distancePPointToPLine, eToCPPoint2, eToPLine2, getFirstArc, join2PPoint2, normalizePLine2, pPointOnPerp) -- Our 2D Projective Geometric Algebra library. -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), canonicalize, pPointBetweenPPointsWithErr, distanceBetweenPPointsWithErr, distancePPointToPLineWithErr, eToPLine2WithErr, eToPPoint2, intersect2PL, translateL, translateRotatePPoint2, angleBetween2PL, flipL, join2PP, makePPoint2, normalize, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, distancePPointToPLineWithErr, pPointOnPerpWithErr, outOf, pPointOf, ulpOfOut, outputIntersectsLineSeg, pPointBetweenPPointsWithErr) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), canonicalize, pPointBetweenPPointsWithErr, distanceBetweenPPointsWithErr, distancePPointToPLineWithErr, eToPLine2WithErr, eToPPoint2, intersect2PL, translateL, translateRotatePPoint2, angleBetween2PL, flipL, join2PP, makePPoint2, normalize, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, distancePPointToPLineWithErr, pPointOnPerpWithErr, outOf, pPointOf, ulpOfOut, outputIntersectsLineSeg, pPointBetweenPPointsWithErr) -- Our Contour library. import Graphics.Slicer.Math.Contour (contourContainsContour, getContours, pointsOfContour, numPointsOfContour, justOneContourFrom, lineSegsOfContour, makeLineSegContour, makePointContour, insideIsLeft, innerContourPoint, firstPointPairOfContour, firstLineSegOfContour) @@ -399,18 +399,18 @@ prop_perpAt90Degrees x y rawX2 y2 rawD <> "angle2: " <> show angle2 <> "\n" <> "angle2Err: " <> show angle2Err <> "\n" where - (angle2, UlpSum angle2Err) = angleBetween2PL normedPLine3 normedPLine4 + (angle2, UlpSum angle2Err) = angleBetween2PL (normedPLine3, norm3Err) (normedPLine4, norm4Err) (PPoint2 rawBisectorStart, UlpSum bisectorStartErr) = pPointBetweenPPointsWithErr sourceStart sourceEnd 0.5 0.5 (bisectorEndRaw, UlpSum bisectorEndRawErr) = pPointOnPerpWithErr pline4 (PPoint2 rawBisectorStart) d (bisectorEnd, UlpSum bisectorEndErr) = canonicalize bisectorEndRaw (pline3, UlpSum pline3Err) = join2PP (CPPoint2 rawBisectorStart) bisectorEnd - (normedPLine3, UlpSum norm3Err) = normalize pline3 + (normedPLine3, norm3Err) = normalizeL pline3 sourceStart = makePPoint2 x y sourceEnd = makePPoint2 x2 y2 (pline4, UlpSum pline4Err) = join2PP sourceStart sourceEnd - (normedPLine4, UlpSum norm4Err) = normalize pline4 - errTotal3 = angle2Err + norm3Err + pline3Err + pline4Err + norm4Err + bisectorStartErr + bisectorEndRawErr + bisectorEndErr - errTotal4 = angle2Err + norm3Err + pline3Err + pline4Err + norm4Err + bisectorStartErr + bisectorEndRawErr + bisectorEndErr + (normedPLine4, norm4Err) = normalizeL pline4 + errTotal3 = angle2Err + pline3Err + pline4Err + bisectorStartErr + bisectorEndRawErr + bisectorEndErr + errTotal4 = angle2Err + pline3Err + pline4Err + bisectorStartErr + bisectorEndRawErr + bisectorEndErr x2 :: ℝ x2 = coerce rawX2 d :: ℝ @@ -714,7 +714,7 @@ myAngleBetween a b <> show res <> "\n" <> show resErr <> "\n" where - (res, UlpSum resErr) = angleBetween2PL a b + (res, UlpSum resErr) = angleBetween2PL (a, mempty) (b, mempty) -- | ensure that a right angle with one side parallel with an axis and the other side parallel to the other axis results in a line through the origin point. -- NOTE: hack, using angleBetween to filter out minor numerical imprecision. @@ -1323,8 +1323,8 @@ prop_obtuseBisectorOnBiggerSide_makeINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 (angleFound, UlpSum angleErr) = angleBetween2PL bisector1 bisector2 eNode = randomENode x y d1 rawR1 d2 rawR2 iNode = randomINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 - bisector1 = normalizePLine2 $ outOf iNode - bisector2 = normalizePLine2 $ flipL $ outOf eNode + bisector1 = normalizeL $ outOf iNode + bisector2 = normalizeL $ flipL $ outOf eNode prop_eNodeTowardIntersection1 :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> Positive ℝ -> Radian ℝ -> Expectation prop_eNodeTowardIntersection1 x y d1 rawR1 d2 rawR2 = l1TowardIntersection --> True From 4904957e1a2d209a1808cd8b3b19150db4e36685 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 22 Oct 2022 20:01:54 +0000 Subject: [PATCH 033/206] add xIntercept and yIntercept, along with tests for them. --- Graphics/Slicer/Math/Ganja.hs | 8 ++- Graphics/Slicer/Math/PGAPrimitives.hs | 73 +++++++++++++++++++++++-- tests/Math/PGA.hs | 78 ++++++++++++++++++++++++--- 3 files changed, 148 insertions(+), 11 deletions(-) diff --git a/Graphics/Slicer/Math/Ganja.hs b/Graphics/Slicer/Math/Ganja.hs index 3fc4e259d..739efeac8 100644 --- a/Graphics/Slicer/Math/Ganja.hs +++ b/Graphics/Slicer/Math/Ganja.hs @@ -81,7 +81,7 @@ -- so we can define a Num instance for Positive. {-# OPTIONS_GHC -Wno-orphans #-} -module Graphics.Slicer.Math.Ganja (GanjaAble, ListThree, Radian(Radian), edgesOf, generationsOf, toGanja, dumpGanja, dumpGanjas, randomTriangle, randomSquare, randomRectangle, randomConvexDualRightQuad, randomConvexSingleRightQuad, randomConvexBisectableQuad, randomConvexQuad, randomConcaveChevronQuad, randomENode, randomINode, randomPLine, randomPLineWithErr, randomLineSeg, cellFrom, remainderFrom, onlyOne, onlyOneOf, randomPLineThroughOrigin, randomLineSegFromOriginNotX1Y1, randomX1Y1LineSegToOrigin, randomX1Y1LineSegToPoint, randomLineSegFromPointNotX1Y1, randomPLineThroughPoint, randomLineSegWithErr) where +module Graphics.Slicer.Math.Ganja (GanjaAble, ListThree, Radian(Radian), edgesOf, generationsOf, toGanja, dumpGanja, dumpGanjas, randomPL, randomTriangle, randomSquare, randomRectangle, randomConvexDualRightQuad, randomConvexSingleRightQuad, randomConvexBisectableQuad, randomConvexQuad, randomConcaveChevronQuad, randomENode, randomINode, randomPLine, randomPLineWithErr, randomLineSeg, cellFrom, remainderFrom, onlyOne, onlyOneOf, randomPLineThroughOrigin, randomLineSegFromOriginNotX1Y1, randomX1Y1LineSegToOrigin, randomX1Y1LineSegToPoint, randomLineSegFromPointNotX1Y1, randomPLineThroughPoint, randomLineSegWithErr) where import Prelude (Bool, Enum, Eq, Fractional, Num, Ord, Show, String, Int, (<>), (<>), (<$>), ($), (>=), (==), abs, concat, error, fromInteger, fromRational, fst, mod, otherwise, replicate, show, signum, snd, zip, (.), (+), (-), (*), (<), (/), (>), (<=), (&&), (/=)) @@ -114,7 +114,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (GNum(GEPlus, GEZero), GVec(GVec), import Graphics.Slicer.Math.Lossy (eToPLine2, join2PPoint2, normalizePLine2, pPointBetweenPPoints, pToEPoint2) -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), PLine2(PLine2), PPoint2(PPoint2), eToPLine2WithErr, eToPPoint2, flipL, translateRotatePPoint2, ulpOfLineSeg, outOf, pPointOf, NPLine2(NPLine2)) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), PLine2(PLine2), PPoint2(PPoint2), PLine2Err, eToPLine2WithErr, eToPL, eToPPoint2, flipL, translateRotatePPoint2, ulpOfLineSeg, outOf, pPointOf, NPLine2(NPLine2)) import Graphics.Slicer.Math.Skeleton.Concave (makeENode, getOutsideArc) @@ -673,6 +673,10 @@ randomPLine x y dx dy = fst $ randomPLineWithErr x y dx dy randomPLineWithErr :: ℝ -> ℝ -> NonZero ℝ -> NonZero ℝ -> (PLine2, UlpSum) randomPLineWithErr x y dx dy = eToPLine2WithErr $ makeLineSeg (Point2 (x, y)) (Point2 (coerce dx, coerce dy)) +-- | A helper function. constructs a random PLine. +randomPL :: ℝ -> ℝ -> NonZero ℝ -> NonZero ℝ -> (PLine2, PLine2Err) +randomPL x y dx dy = eToPL $ makeLineSeg (Point2 (x, y)) (Point2 (coerce dx, coerce dy)) + -- | A helper function. constructs a random LineSeg. randomLineSeg :: ℝ -> ℝ -> ℝ -> ℝ -> LineSeg randomLineSeg x y rawDx rawDy = fst $ randomLineSegWithErr x y rawDx rawDy diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index 15c018626..409d6f354 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -61,18 +61,22 @@ module Graphics.Slicer.Math.PGAPrimitives join2PPWithErr, pToEP, vecOfP - ) + ), + xIntercept, + yIntercept ) where -import Prelude(Bool, Eq((==),(/=)), Monoid(mempty), Ord, Semigroup((<>)), Show(show), ($), (+), (*), (<$>), (&&), abs, error, filter, negate, otherwise, realToFrac, sqrt) +import Prelude(Bool, Eq((==),(/=)), Monoid(mempty), Ord, Semigroup((<>)), Show(show), ($), (+), (*), (/), (<$>), (&&), abs, error, filter, negate, otherwise, realToFrac, sqrt) import Control.DeepSeq (NFData) import Data.Bits.Floating.Ulp (doubleUlp) +import Data.Either (Either(Left, Right)) + import Data.List (foldl', sort) -import Data.Maybe (Maybe(Just,Nothing), fromMaybe, isNothing) +import Data.Maybe (Maybe(Just,Nothing), fromMaybe, isJust, isNothing) import Data.Set (Set, elems, fromList, singleton) @@ -335,6 +339,69 @@ translateProjectiveLine2WithErr line d = (PLine2 res, normErr <> PLine2Err resEr tUlp = UlpSum $ abs $ realToFrac $ doubleUlp tAdd (norm, normErr) = normOfL line +----------------------------------------- +--- Projective Line Error Calculation --- +----------------------------------------- + +-- | find the approximate point that a given line crosses the X axis. +xIntercept :: (ProjectiveLine2 a) => (a, PLine2Err) -> Maybe (Either a ℝ, UlpSum) +xIntercept (line, lineErr) + -- handle a line that is parallel to the X axis. + | isNothing rawX = Nothing + -- use X and T to calculate our answer + | isJust rawT = Just (Right xDivRes, xDivErr) + -- is colinear with the X axis. + | isNothing rawY = Just (Left line, mempty) + -- we have an X and a Y, but no T? this line passes through the origin. + | isNothing rawT = Just (Right 0, mempty) + | otherwise = error "totality failure: we should never get here." + where + -- negate is required, because the X value is inverted. + xDivRes = negate $ valOf 0 rawT / valOf 0 rawX + xDivErr = rawXErr <> rawTErr <> UlpSum (abs $ realToFrac $ doubleUlp xDivRes) + rawTErr = eValOf mempty (getVal [GEZero 1] lAddErr) + <> eValOf mempty (getVal [GEZero 1] lNormalizeErr) + <> eValOf mempty (getVal [GEZero 1] lJoinAddErr) + <> eValOf mempty (getVal [GEZero 1] lJoinMulErr) + rawXErr = eValOf mempty (getVal [GEPlus 1] lAddErr) + <> eValOf mempty (getVal [GEPlus 1] lNormalizeErr) + <> eValOf mempty (getVal [GEPlus 1] lJoinAddErr) + <> eValOf mempty (getVal [GEPlus 1] lJoinMulErr) + (PLine2Err lAddErr lNormalizeErr _ _ _ (lJoinMulErr, lJoinAddErr)) = lineErr + rawT = getVal [GEZero 1] pLineVals + rawX = getVal [GEPlus 1] pLineVals + rawY = getVal [GEPlus 2] pLineVals + (GVec pLineVals) = vecOfL line + +-- | find the point that a given line crosses the Y axis. +yIntercept :: (ProjectiveLine2 a) => (a, PLine2Err) -> Maybe (Either a ℝ, UlpSum) +yIntercept (line, lineErr) + -- handle a line that is parallel to the Y axis. + | isNothing rawY = Nothing + -- use Y and T to calculate our answer + | isJust rawT = Just $ (Right yDivRes, yDivErr) + -- is along the Y axis. + | isNothing rawX = Just (Left line, mempty) + -- we have an X and a Y? this line passes through the origin. + | isNothing rawT = Just (Right 0, mempty) + | otherwise = error "we should never get here" + where + yDivRes = negate $ valOf 0 rawT / valOf 0 rawY + yDivErr = rawYErr <> rawTErr <> UlpSum (abs $ realToFrac $ doubleUlp yDivRes) + rawTErr = eValOf mempty (getVal [GEZero 1] lAddErr) + <> eValOf mempty (getVal [GEZero 1] lNormalizeErr) + <> eValOf mempty (getVal [GEZero 1] lJoinAddErr) + <> eValOf mempty (getVal [GEZero 1] lJoinMulErr) + rawYErr = eValOf mempty (getVal [GEPlus 2] lAddErr) + <> eValOf mempty (getVal [GEPlus 2] lNormalizeErr) + <> eValOf mempty (getVal [GEPlus 2] lJoinAddErr) + <> eValOf mempty (getVal [GEPlus 2] lJoinMulErr) + (PLine2Err lAddErr lNormalizeErr _ _ _ (lJoinMulErr, lJoinAddErr)) = lineErr + rawT = getVal [GEZero 1] pLineVals + rawX = getVal [GEPlus 1] pLineVals + rawY = getVal [GEPlus 2] pLineVals + (GVec pLineVals) = vecOfL line + -------------------------------- --- Projective Point Support --- -------------------------------- diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index ac2449f44..c88b16da8 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -25,7 +25,7 @@ module Math.PGA (linearAlgSpec, geomAlgSpec, pgaSpec, proj2DGeomAlgSpec, facetSpec, facetFlakeySpec, contourSpec, lineSpec) where -- Be explicit about what we import. -import Prelude (($), Bool(True, False), (<$>), (==), (>=), error, (/=), (<=), mempty, otherwise, abs, (&&), (+), show, length, (<>), fst, not, length, realToFrac, sqrt, (<), (>), (-), (/), (||), (*)) +import Prelude (($), Bool(True, False), (<$>), (==), (>=), error, (/=), (<=), mempty, otherwise, abs, (&&), (+), show, length, (<>), fst, not, length, realToFrac, sqrt, (<), (>), (-), (/), (||), (*), snd) -- Hspec, for writing specs. import Test.Hspec (describe, Spec, it, Expectation) @@ -35,11 +35,11 @@ import Test.QuickCheck (property, NonZero(NonZero), Positive(Positive)) import Data.Coerce (coerce) -import Data.Either (Either(Left, Right)) +import Data.Either (Either(Left, Right), fromRight, isLeft) import Data.List (foldl') -import Data.Maybe (fromMaybe, Maybe(Just, Nothing)) +import Data.Maybe (fromJust, fromMaybe, isNothing, Maybe(Just, Nothing)) import Numeric.Rounded.Hardware (Rounded, RoundingMode(TowardInf)) @@ -54,12 +54,16 @@ import Graphics.Slicer (ℝ) import Graphics.Slicer.Math.Definitions(Point2(Point2), Contour(LineSegContour), LineSeg(LineSeg), roundPoint2, startPoint, distance, xOf, yOf, minMaxPoints, makeLineSeg, endPoint) -- Our Geometric Algebra library. -import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(GEZero, GEPlus, G0), GVal(GVal), GVec(GVec), UlpSum(UlpSum), addValPairWithErr, subValPairWithErr, addValWithErr, subVal, addVecPair, subVecPair, mulScalarVecWithErr, divVecScalarWithErr, scalarPart, vectorPart, (•), (∧), (⋅), (⎣), (⎤)) +import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(GEZero, GEPlus, G0), GVal(GVal), GVec(GVec), UlpSum(UlpSum), addValPairWithErr, subValPairWithErr, addValWithErr, ulpVal, subVal, addVecPair, subVecPair, mulScalarVecWithErr, divVecScalarWithErr, scalarPart, vectorPart, (•), (∧), (⋅), (⎣), (⎤)) import Graphics.Slicer.Math.Lossy (angleBetween, canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenPLines, distancePPointToPLine, eToCPPoint2, eToPLine2, getFirstArc, join2PPoint2, normalizePLine2, pPointOnPerp) -- Our 2D Projective Geometric Algebra library. -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), canonicalize, pPointBetweenPPointsWithErr, distanceBetweenPPointsWithErr, distancePPointToPLineWithErr, eToPLine2WithErr, eToPPoint2, intersect2PL, translateL, translateRotatePPoint2, angleBetween2PL, flipL, join2PP, makePPoint2, normalize, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, distancePPointToPLineWithErr, pPointOnPerpWithErr, outOf, pPointOf, ulpOfOut, outputIntersectsLineSeg, pPointBetweenPPointsWithErr) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PLine2Err(PLine2Err), canonicalize, pPointBetweenPPointsWithErr, distanceBetweenPPointsWithErr, distancePPointToPLineWithErr, eToPLine2WithErr, eToPL, eToPPoint2, intersect2PL, translateL, translateRotatePPoint2, angleBetween2PL, flipL, join2PP, makePPoint2, normalize, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, distancePPointToPLineWithErr, pPointOnPerpWithErr, outOf, pPointOf, ulpOfOut, outputIntersectsLineSeg, pPointBetweenPPointsWithErr) + + +-- The primitives of our PGA only library, and error estimation code. +import Graphics.Slicer.Math.PGAPrimitives (xIntercept, yIntercept) -- Our Contour library. import Graphics.Slicer.Math.Contour (contourContainsContour, getContours, pointsOfContour, numPointsOfContour, justOneContourFrom, lineSegsOfContour, makeLineSegContour, makePointContour, insideIsLeft, innerContourPoint, firstPointPairOfContour, firstLineSegOfContour) @@ -83,7 +87,7 @@ import Graphics.Slicer.Math.Skeleton.Skeleton (findStraightSkeleton) import Math.Util ((-->), (-/>)) -- Our debugging library, for making the below simpler to read, and drop into command lines. -import Graphics.Slicer.Math.Ganja (ListThree, Radian(Radian), cellFrom, edgesOf, generationsOf, randomTriangle, randomRectangle, randomSquare, randomConvexQuad, randomConvexSingleRightQuad, randomConvexDualRightQuad, randomConvexBisectableQuad, randomConcaveChevronQuad, randomENode, randomINode, randomLineSeg, randomPLine, randomPLineWithErr, remainderFrom, onlyOne, onlyOneOf, dumpGanjas, toGanja, randomPLineThroughOrigin, randomX1Y1LineSegToOrigin, randomLineSegFromOriginNotX1Y1, randomX1Y1LineSegToPoint, randomLineSegFromPointNotX1Y1, randomPLineThroughPoint, randomLineSegWithErr) +import Graphics.Slicer.Math.Ganja (ListThree, Radian(Radian), cellFrom, edgesOf, generationsOf, randomPL, randomTriangle, randomRectangle, randomSquare, randomConvexQuad, randomConvexSingleRightQuad, randomConvexDualRightQuad, randomConvexBisectableQuad, randomConcaveChevronQuad, randomENode, randomINode, randomLineSeg, randomPLine, randomPLineWithErr, remainderFrom, onlyOne, onlyOneOf, dumpGanjas, toGanja, randomPLineThroughOrigin, randomX1Y1LineSegToOrigin, randomLineSegFromOriginNotX1Y1, randomX1Y1LineSegToPoint, randomLineSegFromPointNotX1Y1, randomPLineThroughPoint, randomLineSegWithErr) -- Default all numbers in this file to being of the type ImplicitCAD uses for values. default (ℝ) @@ -1409,6 +1413,63 @@ prop_PLinesIntersectAtPoint rawX y rawX2 rawY2 targetX targetY | rawY2 == y = if y == 1 then 2 else 1 | otherwise = rawY2 +prop_PLineIntersectsAtXAxis :: ℝ -> ℝ -> NonZero ℝ -> ℝ -> NonZero ℝ -> Bool +prop_PLineIntersectsAtXAxis x y rawX2 y2 m + -- ignore the case where the random PLine is parallel to the X axis. + | isNothing axisIntersection = True + -- Ignore the case where the random PLine is colinear to the X axis. + | isLeft $ fst $ fromJust axisIntersection = True + | foundDistance < realToFrac errSum = True + | otherwise = error + $ "wtf\n" + <> show foundDistance <> "\n" + <> show errSum <> "\n" + <> show axisPLine <> "\n" + <> show foundDistance <> "\n" + <> show distanceErr <> "\n" + <> show intersectionErr <> "\n" + where + errSum = ulpVal $ axisIntersectionErr <> distanceErr + (foundDistance, distanceErr) = distanceBetweenPPointsWithErr axisIntersectionPoint intersectionPPoint2 + axisIntersectionErr = snd $ fromJust axisIntersection + axisIntersectionPoint = eToPPoint2 $ Point2 ((fromRight (error "not right?") $ fst $ fromJust axisIntersection), 0) + axisIntersection = xIntercept (randomPLine1, pline1Err) + (intersectionPPoint2, intersectionErr) = intersect2PL randomPLine1 axisPLine + (randomPLine1, pline1Err) = randomPL x y rawX2 (coerce y2) + (axisPLine, _) = eToPL $ makeLineSeg (Point2 (0,0)) (Point2 (coerce m,0)) + x2 :: ℝ + x2 = coerce rawX2 + +prop_PLineIntersectsAtYAxis :: NonZero ℝ -> ℝ -> ℝ -> NonZero ℝ -> NonZero ℝ -> Bool +prop_PLineIntersectsAtYAxis x y x2 rawY2 m + -- ignore the case where the random PLine is parallel to the X axis. + | isNothing axisIntersection = True + -- Ignore the case where the random PLine is colinear to the X axis. + | isLeft $ fst $ fromJust axisIntersection = True + | foundDistance < realToFrac errSum = True + | otherwise = error + $ "wtf\n" + <> show foundDistance <> "\n" + <> show errSum <> "\n" + <> show randomPLine1 <> "\n" + <> show axisPLine <> "\n" + <> show axisIntersectionPoint <> "\n" + <> show intersectionPPoint2 <> "\n" + <> show foundDistance <> "\n" + <> show distanceErr <> "\n" + <> show intersectionErr <> "\n" + where + errSum = ulpVal $ axisIntersectionErr <> distanceErr + (foundDistance, distanceErr) = distanceBetweenPPointsWithErr axisIntersectionPoint intersectionPPoint2 + axisIntersectionErr = snd $ fromJust axisIntersection + axisIntersectionPoint = eToPPoint2 $ Point2 (0,(fromRight (error "not right?") $ fst $ fromJust axisIntersection)) + axisIntersection = yIntercept (randomPLine1, pline1Err) + (intersectionPPoint2, intersectionErr) = intersect2PL randomPLine1 axisPLine + (randomPLine1, pline1Err) = randomPL (coerce x) y (coerce x2) (coerce y2) + (axisPLine, axisErr) = eToPL $ makeLineSeg (Point2 (0,0)) (Point2 (0,coerce m)) + y2 :: ℝ + y2 = coerce rawY2 + facetFlakeySpec :: Spec facetFlakeySpec = do describe "Stability (Points)" $ do @@ -1450,6 +1511,11 @@ facetSpec = do property prop_LineSegWithinErrRange it "a normalized line normalized again is approximately itsself" $ property prop_NormPLineIsPLine + describe "Stability (Error)" $ do + it "finds that the X intersection of a random PLine is within the returned UlpSum" $ + property prop_PLineIntersectsAtXAxis + it "finds that the Y intersection of a random PLine is within the returned UlpSum" $ + property prop_PLineIntersectsAtYAxis describe "Stability (Intersections)" $ do it "finds that the intersection of two PLines at the origin are within the returned UlpSum" $ property prop_PLinesIntersectAtOrigin From 34feb016908bc94444efa5c4f249447a312d4494 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 23 Oct 2022 11:36:40 +0000 Subject: [PATCH 034/206] move distanceBetweenPPointsWithErr into PGAPrimitives.hs, and rename to distance2PP. --- Graphics/Slicer/Math/Lossy.hs | 4 +-- Graphics/Slicer/Math/PGA.hs | 33 +++++++------------- Graphics/Slicer/Math/PGAPrimitives.hs | 20 +++++++++++- Graphics/Slicer/Math/Skeleton/Cells.hs | 4 +-- Graphics/Slicer/Math/Skeleton/Concave.hs | 14 ++++----- Graphics/Slicer/Math/Skeleton/Definitions.hs | 4 +-- tests/Math/PGA.hs | 30 +++++++++--------- 7 files changed, 59 insertions(+), 50 deletions(-) diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index 89e554b2e..e3b2f30a0 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -48,7 +48,7 @@ import Graphics.Slicer.Math.Definitions (LineSeg, Point2, makeLineSeg) import Graphics.Slicer.Math.Arcs (getFirstArcWithErr, getInsideArcWithErr) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PPoint2, ProjectiveLine2, ProjectivePoint2, angleBetween2PL, canonicalize, distanceBetweenPPointsWithErr, distanceBetweenPLinesWithErr, distancePPointToPLineWithErr, eToPLine2WithErr, eToPPoint2, join2PP, normalize, pPointBetweenPPointsWithErr, pPointOnPerpWithErr, pToEP, translateL) +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PPoint2, ProjectiveLine2, ProjectivePoint2, angleBetween2PL, canonicalize, distance2PP, distanceBetweenPLinesWithErr, distancePPointToPLineWithErr, eToPLine2WithErr, eToPPoint2, join2PP, normalize, pPointBetweenPPointsWithErr, pPointOnPerpWithErr, pToEP, translateL) angleBetween :: NPLine2 -> NPLine2 -> ℝ angleBetween nPLine1 nPLine2 = fst $ angleBetween2PL (nPLine1, mempty) (nPLine2, mempty) @@ -58,7 +58,7 @@ canonicalizePPoint2 :: PPoint2 -> CPPoint2 canonicalizePPoint2 point = fst $ canonicalize point distanceBetweenPPoints :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> ℝ -distanceBetweenPPoints point1 point2 = fst $ distanceBetweenPPointsWithErr point1 point2 +distanceBetweenPPoints point1 point2 = fst $ distance2PP point1 point2 distanceBetweenPLines :: (ProjectiveLine2 a) => a -> a -> ℝ distanceBetweenPLines nPLine1 nPLine2 = fst $ distanceBetweenPLinesWithErr nPLine1 nPLine2 diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 4eeee8c37..f2d2f9af4 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -39,7 +39,7 @@ module Graphics.Slicer.Math.PGA( angleBetween2PL, canonicalize, combineConsecutiveLineSegs, - distanceBetweenPPointsWithErr, + distance2PP, distanceBetweenPLinesWithErr, distancePPointToPLineWithErr, eToPLine2WithErr, @@ -93,7 +93,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (GNum(G0, GEPlus, GEZero), GVal(GVa import Graphics.Slicer.Math.Line (combineLineSegs) -import Graphics.Slicer.Math.PGAPrimitives(Arcable(hasArc, outOf, outUlpMag, ulpOfOut), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(angleBetween2PL, flipL, forceBasisOfL, intersect2PL, normalize, normalizeL, normOfL, translateL, vecOfL), ProjectivePoint2(canonicalize, forceBasisOfP, idealNormOfP, join2PP, join2PPWithErr, pToEP, vecOfP)) +import Graphics.Slicer.Math.PGAPrimitives(Arcable(hasArc, outOf, outUlpMag, ulpOfOut), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(angleBetween2PL, flipL, forceBasisOfL, intersect2PL, normalize, normalizeL, normOfL, translateL, vecOfL), ProjectivePoint2(canonicalize, distance2PP, forceBasisOfP, idealNormOfP, join2PP, join2PPWithErr, pToEP, vecOfP)) -- Our 2D plane coresponds to a Clifford algebra of 2,0,1. @@ -211,15 +211,6 @@ pPointsOnSameSideOfPLine point1 point2 line pv2 = vecOfP $ forceBasisOfP point2 lv1 = vecOfL $ forceBasisOfL line -distanceBetweenPPointsWithErr :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> (ℝ, UlpSum) -distanceBetweenPPointsWithErr point1 point2 = (res, ulpTotal) - where - (res, _) = normOfL newPLine - (newPLine, newPLineUlp) = join2PP cpoint1 cpoint2 - ulpTotal = newPLineUlp -- resErr -- <> PLine2Err _ _ _ _ _ newPLineUlp - (cpoint1, _) = canonicalize point1 - (cpoint2, _) = canonicalize point2 - -- | Find the unsigned distance between two parallel or antiparallel projective lines. distanceBetweenPLinesWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, UlpSum) distanceBetweenPLinesWithErr line1 line2 = (ideal, resUlpSum) @@ -355,7 +346,7 @@ outputIntersectsLineSeg source (l1, UlpSum l1Err) (rawIntersection, UlpSum rawIntersectionErr) = fromJust canonicalizedIntersection canonicalizedIntersection = canonicalizeIntersectionWithErr pl1 pl2 (canonicalizedSource, UlpSum canonicalizedSourceErr) = canonicalize $ pPointOf source - (intersectionDistance, UlpSum intersectionDistanceErr) = distanceBetweenPPointsWithErr canonicalizedSource rawIntersection + (intersectionDistance, UlpSum intersectionDistanceErr) = distance2PP canonicalizedSource rawIntersection -- | A type alias, for cases where either input is acceptable. type SegOrPLine2WithErr = Either (LineSeg, UlpSum) (PLine2,UlpSum) @@ -396,8 +387,8 @@ pLineIntersectsLineSeg (pl1, UlpSum pl1Err) (l1, UlpSum l1Err) ulpScale | hasRawIntersection = Left $ NoIntersection rawIntersection (UlpSum $ realToFrac ulpStartSum, UlpSum $ realToFrac ulpEndSum, mempty, mempty) | otherwise = Left $ NoIntersection ((\(PPoint2 v) -> CPPoint2 v) rawIntersect) (mempty, mempty, mempty, mempty) where - (startDistance, UlpSum startDistanceErr) = distanceBetweenPPointsWithErr rawIntersection start - (endDistance, UlpSum endDistanceErr) = distanceBetweenPPointsWithErr rawIntersection end + (startDistance, UlpSum startDistanceErr) = distance2PP rawIntersection start + (endDistance, UlpSum endDistanceErr) = distance2PP rawIntersection end start = eToPPoint2 $ startPoint l1 end = eToPPoint2 $ endPoint l1 ulpStartSum, ulpEndSum :: ℝ @@ -438,10 +429,10 @@ lineSegIntersectsLineSeg (l1, UlpSum l1Err) (l2, UlpSum ulpL2) ulpStartSum2 = realToFrac $ ulpTotal+start2DistanceErr ulpEndSum1 = realToFrac $ ulpTotal ulpEndSum2 = realToFrac $ ulpTotal - (start1Distance, UlpSum start1DistanceErr) = distanceBetweenPPointsWithErr rawIntersection start1 - (start2Distance, UlpSum start2DistanceErr) = distanceBetweenPPointsWithErr rawIntersection start2 - (end1Distance, UlpSum end1DistanceErr) = distanceBetweenPPointsWithErr rawIntersection end1 - (end2Distance, UlpSum end2DistanceErr) = distanceBetweenPPointsWithErr rawIntersection end2 + (start1Distance, UlpSum start1DistanceErr) = distance2PP rawIntersection start1 + (start2Distance, UlpSum start2DistanceErr) = distance2PP rawIntersection start2 + (end1Distance, UlpSum end1DistanceErr) = distance2PP rawIntersection end1 + (end2Distance, UlpSum end2DistanceErr) = distance2PP rawIntersection end2 start1 = eToPPoint2 $ startPoint l1 end1 = eToPPoint2 $ endPoint l1 start2 = eToPPoint2 $ startPoint l2 @@ -469,9 +460,9 @@ onSegment ls i startUlp endUlp = || (midDistance <= (lengthOfSegment/2) + midFudgeFactor) || (endDistance <= endFudgeFactor) where - (startDistance, UlpSum startDistanceErr) = distanceBetweenPPointsWithErr start i - (midDistance, UlpSum midDistanceErr) = distanceBetweenPPointsWithErr mid i - (endDistance, UlpSum endDistanceErr) = distanceBetweenPPointsWithErr end i + (startDistance, UlpSum startDistanceErr) = distance2PP start i + (midDistance, UlpSum midDistanceErr) = distance2PP mid i + (endDistance, UlpSum endDistanceErr) = distance2PP end i start = eToPPoint2 $ startPoint ls (mid, UlpSum midErr) = pPointBetweenPPointsWithErr start end 0.5 0.5 end = eToPPoint2 $ endPoint ls diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index 409d6f354..447102459 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -55,6 +55,7 @@ module Graphics.Slicer.Math.PGAPrimitives ), ProjectivePoint2( canonicalize, + distance2PP, forceBasisOfP, idealNormOfP, join2PP, @@ -356,7 +357,7 @@ xIntercept (line, lineErr) | isNothing rawT = Just (Right 0, mempty) | otherwise = error "totality failure: we should never get here." where - -- negate is required, because the X value is inverted. + -- negate is required, because the result is inverted. xDivRes = negate $ valOf 0 rawT / valOf 0 rawX xDivErr = rawXErr <> rawTErr <> UlpSum (abs $ realToFrac $ doubleUlp xDivRes) rawTErr = eValOf mempty (getVal [GEZero 1] lAddErr) @@ -386,6 +387,7 @@ yIntercept (line, lineErr) | isNothing rawT = Just (Right 0, mempty) | otherwise = error "we should never get here" where + -- negate is required, because the result is inverted. yDivRes = negate $ valOf 0 rawT / valOf 0 rawY yDivErr = rawYErr <> rawTErr <> UlpSum (abs $ realToFrac $ doubleUlp yDivRes) rawTErr = eValOf mempty (getVal [GEZero 1] lAddErr) @@ -466,6 +468,7 @@ class Arcable a where class (Show a) => ProjectivePoint2 a where canonicalize :: a -> (CPPoint2, UlpSum) consLikeP :: a -> (GVec -> a) + distance2PP :: (ProjectivePoint2 b) => a -> b -> (ℝ, UlpSum) forceBasisOfP :: a -> a idealNormOfP :: a -> (ℝ, UlpSum) join2PP :: (ProjectivePoint2 b) => a -> b -> (PLine2, UlpSum) @@ -476,6 +479,9 @@ class (Show a) => ProjectivePoint2 a where instance ProjectivePoint2 PPoint2 where canonicalize p = (\(a, PPoint2Err _ cp1Errs _ _ _ _ _) -> (a,sumErrVals cp1Errs)) $ canonicalizePPoint2WithErr p consLikeP (PPoint2 _) = PPoint2 + distance2PP p1 p2 = crushErr $ distanceBetweenPPointsWithErr p1 p2 + where + crushErr a = a forceBasisOfP a = forceProjectivePointBasis a idealNormOfP a = idealNormPPoint2WithErr a join2PP a b = crushErr $ join2ProjectivePointsWithErr a b @@ -494,6 +500,9 @@ instance ProjectivePoint2 PPoint2 where instance ProjectivePoint2 CPPoint2 where canonicalize p = (p, mempty) consLikeP (CPPoint2 _) = CPPoint2 + distance2PP p1 p2 = crushErr $ distanceBetweenPPointsWithErr p1 p2 + where + crushErr a = a forceBasisOfP p = forceProjectivePointBasis p idealNormOfP p = idealNormPPoint2WithErr p join2PP a b = crushErr $ join2ProjectivePointsWithErr a b @@ -535,6 +544,15 @@ canonicalizePPoint2WithErr point (GVec rawVals) = vecOfP point foundVal = getVal [GEPlus 1, GEPlus 2] rawVals +distanceBetweenPPointsWithErr :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> (ℝ, UlpSum) +distanceBetweenPPointsWithErr point1 point2 = (res, ulpTotal) + where + (res, _) = normOfL newPLine + (newPLine, newPLineUlp) = join2PP cpoint1 cpoint2 + ulpTotal = newPLineUlp -- resErr -- <> PLine2Err _ _ _ _ _ newPLineUlp + (cpoint1, _) = canonicalize point1 + (cpoint2, _) = canonicalize point2 + -- | runtime basis coersion. ensure all of the '0' components exist on a Projective Point. forceProjectivePointBasis :: (ProjectivePoint2 a) => a -> a forceProjectivePointBasis point diff --git a/Graphics/Slicer/Math/Skeleton/Cells.hs b/Graphics/Slicer/Math/Skeleton/Cells.hs index 09c09c14c..53667db86 100644 --- a/Graphics/Slicer/Math/Skeleton/Cells.hs +++ b/Graphics/Slicer/Math/Skeleton/Cells.hs @@ -58,7 +58,7 @@ import Graphics.Slicer.Math.Intersections (intersectionOf) import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, eToCPPoint2, eToPLine2, join2PPoint2, pToEPoint2) -import Graphics.Slicer.Math.PGA (Arcable(outOf), CPPoint2(CPPoint2), Pointable(canPoint, ePointOf, pPointOf), PIntersection(PAntiCollinear, IntersectsIn), PPoint2(PPoint2), angleBetween2PL, distanceBetweenPPointsWithErr, eToPL, eToPPoint2, normalizeL, plinesIntersectIn) +import Graphics.Slicer.Math.PGA (Arcable(outOf), CPPoint2(CPPoint2), Pointable(canPoint, ePointOf, pPointOf), PIntersection(PAntiCollinear, IntersectsIn), PPoint2(PPoint2), angleBetween2PL, distance2PP, eToPL, eToPPoint2, normalizeL, plinesIntersectIn) data UnsupportedReason = INodeCrossesDivide ![(INode,CellDivide)] !NodeTree deriving (Show, Eq) @@ -190,7 +190,7 @@ findNextCell (RemainingContour (Slist [(Slist lineSegs _, divides)] _) ) = case elemIndex (fst $ fst div1) contourSegs `compare` elemIndex (fst $ fst div2) contourSegs of LT -> LT GT -> GT - EQ -> fst (distanceBetweenPPointsWithErr (startPPoint $ fst $ fst div1) (toPPoint2 $ snd $ fst div1)) `compare` fst (distanceBetweenPPointsWithErr (startPPoint $ fst $ fst div2) (toPPoint2 $ snd $ fst div2)) + EQ -> fst (distance2PP (startPPoint $ fst $ fst div1) (toPPoint2 $ snd $ fst div1)) `compare` fst (distance2PP (startPPoint $ fst $ fst div2) (toPPoint2 $ snd $ fst div2)) where toPPoint2 :: Either Point2 CPPoint2 -> CPPoint2 toPPoint2 (Left point2) = eToCPPoint2 point2 diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index f142d3040..91413dc52 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -62,7 +62,7 @@ import Graphics.Slicer.Math.Intersections (intersectionOf, intersectionBetween, import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, distancePPointToPLine, eToPLine2, getInsideArc, join2CPPoint2, normalizePLine2) -import Graphics.Slicer.Math.PGA (Arcable(hasArc, outOf), Pointable(canPoint, pPointOf), PLine2(PLine2), ProjectivePoint2, CPPoint2(CPPoint2), PPoint2(PPoint2), canonicalize, distanceBetweenPPointsWithErr, flipL, normalizeL, pLineIsLeft, angleBetween2PL, distancePPointToPLineWithErr, NPLine2(NPLine2)) +import Graphics.Slicer.Math.PGA (Arcable(hasArc, outOf), Pointable(canPoint, pPointOf), PLine2(PLine2), ProjectivePoint2, CPPoint2(CPPoint2), PPoint2(PPoint2), canonicalize, distance2PP, flipL, normalizeL, pLineIsLeft, angleBetween2PL, distancePPointToPLineWithErr, NPLine2(NPLine2)) import Graphics.Slicer.Math.Skeleton.Definitions (ENode(ENode), ENodeSet(ENodeSet), INode(INode), INodeSet(INodeSet), NodeTree(NodeTree), concavePLines, getFirstLineSeg, getLastLineSeg, finalOutOf, firstInOf, getPairs, indexPLinesTo, insOf, lastINodeOf, linePairs, makeINode, sortedPLines, isLoop) @@ -179,8 +179,8 @@ averageNodes n1 n2 | n2Distance < getRounded n2Err = error $ "intersection is AT the point of n2!\n" <> dumpInput | otherwise = makeINode (sortedPair n1 n2) $ Just $ getOutsideArc (pPointOf n1) (normalizePLine2 $ outOf n1) (pPointOf n2) (normalizePLine2 $ outOf n2) where - (n1Distance, UlpSum n1Err) = distanceBetweenPPointsWithErr (intersectionOf (outOf n1) (outOf n2)) (canonicalizePPoint2 $ pPointOf n1) - (n2Distance, UlpSum n2Err) = distanceBetweenPPointsWithErr (intersectionOf (outOf n1) (outOf n2)) (canonicalizePPoint2 $ pPointOf n2) + (n1Distance, UlpSum n1Err) = distance2PP (intersectionOf (outOf n1) (outOf n2)) (canonicalizePPoint2 $ pPointOf n1) + (n2Distance, UlpSum n2Err) = distance2PP (intersectionOf (outOf n1) (outOf n2)) (canonicalizePPoint2 $ pPointOf n2) dumpInput = "Node1: " <> show n1 <> "\nNode2: " <> show n2 <> "\nNode1Out: " <> show (outOf n1) @@ -220,7 +220,7 @@ towardIntersection pp1 pl1 pp2 | otherwise = angleFound > realToFrac angleErr where (angleFound, UlpSum angleErr) = angleBetween2PL newPLine (normalizeL pl1) - (d, UlpSum dErr) = distanceBetweenPPointsWithErr (fst $ canonicalize pp1) pp2 + (d, UlpSum dErr) = distance2PP (fst $ canonicalize pp1) pp2 newPLine = normalizeL $ join2CPPoint2 (fst $ canonicalize pp1) pp2 -- | Make a first generation node. @@ -665,7 +665,7 @@ skeletonOfNodes connectedLoop inSegSets iNodes = where pairCloseEnough a b = res < realToFrac errRes where - (res, UlpSum errRes) = distanceBetweenPPointsWithErr a b + (res, UlpSum errRes) = distance2PP a b linesCloseEnough = case lineIntersections of [] -> [] @@ -866,5 +866,5 @@ skeletonOfNodes connectedLoop inSegSets iNodes = && (dist2 >= realToFrac dist2Err) | otherwise = error $ "cannot intersect a node with no output:\nNode1: " <> show node1 <> "\nNode2: " <> show node2 <> "\nnodes: " <> show iNodes <> "\n" where - (dist1, UlpSum dist1Err) = distanceBetweenPPointsWithErr (intersectionOf (outOf node1) (outOf node2)) (canonicalizePPoint2 $ pPointOf node1) - (dist2, UlpSum dist2Err) = distanceBetweenPPointsWithErr (intersectionOf (outOf node1) (outOf node2)) (canonicalizePPoint2 $ pPointOf node2) + (dist1, UlpSum dist1Err) = distance2PP (intersectionOf (outOf node1) (outOf node2)) (canonicalizePPoint2 $ pPointOf node1) + (dist2, UlpSum dist2Err) = distance2PP (intersectionOf (outOf node1) (outOf node2)) (canonicalizePPoint2 $ pPointOf node2) diff --git a/Graphics/Slicer/Math/Skeleton/Definitions.hs b/Graphics/Slicer/Math/Skeleton/Definitions.hs index 3ca8e41ea..a625a94a3 100644 --- a/Graphics/Slicer/Math/Skeleton/Definitions.hs +++ b/Graphics/Slicer/Math/Skeleton/Definitions.hs @@ -54,7 +54,7 @@ import Slist.Type (Slist(Slist)) import Graphics.Implicit.Definitions (ℝ) -import Graphics.Slicer.Math.PGA (plinesIntersectIn, PIntersection(IntersectsIn), flipL, PLine2(PLine2), pLineIsLeft, distanceBetweenPPointsWithErr, Pointable(canPoint, pPointOf, ePointOf), Arcable(hasArc, outOf, ulpOfOut, outUlpMag), CPPoint2(CPPoint2), PPoint2(PPoint2), canonicalize, eToPLine2WithErr, eToPPoint2, pToEP, vecOfL) +import Graphics.Slicer.Math.PGA (plinesIntersectIn, PIntersection(IntersectsIn), flipL, PLine2(PLine2), pLineIsLeft, distance2PP, Pointable(canPoint, pPointOf, ePointOf), Arcable(hasArc, outOf, ulpOfOut, outUlpMag), CPPoint2(CPPoint2), PPoint2(PPoint2), canonicalize, eToPLine2WithErr, eToPPoint2, pToEP, vecOfL) import Graphics.Slicer.Math.Definitions (Contour, LineSeg(LineSeg), Point2, mapWithFollower, fudgeFactor, startPoint, distance, endPoint, lineSegsOfContour, makeLineSeg) @@ -125,7 +125,7 @@ instance Pointable INode where where distanceWithinErr a b = res < realToFrac err where - (res, UlpSum err) = distanceBetweenPPointsWithErr (fst $ canonicalize a) (fst $ canonicalize b) + (res, UlpSum err) = distance2PP (fst $ canonicalize a) (fst $ canonicalize b) allPLines = if hasArc iNode then slist $ nub $ outOf iNode : firstPLine : secondPLine : rawPLines else slist $ nub $ firstPLine : secondPLine : rawPLines diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index c88b16da8..ef597d4d6 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -59,7 +59,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(GEZero, GEPlu import Graphics.Slicer.Math.Lossy (angleBetween, canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenPLines, distancePPointToPLine, eToCPPoint2, eToPLine2, getFirstArc, join2PPoint2, normalizePLine2, pPointOnPerp) -- Our 2D Projective Geometric Algebra library. -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PLine2Err(PLine2Err), canonicalize, pPointBetweenPPointsWithErr, distanceBetweenPPointsWithErr, distancePPointToPLineWithErr, eToPLine2WithErr, eToPL, eToPPoint2, intersect2PL, translateL, translateRotatePPoint2, angleBetween2PL, flipL, join2PP, makePPoint2, normalize, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, distancePPointToPLineWithErr, pPointOnPerpWithErr, outOf, pPointOf, ulpOfOut, outputIntersectsLineSeg, pPointBetweenPPointsWithErr) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), canonicalize, pPointBetweenPPointsWithErr, distance2PP, distancePPointToPLineWithErr, eToPLine2WithErr, eToPL, eToPPoint2, intersect2PL, translateL, translateRotatePPoint2, angleBetween2PL, flipL, join2PP, makePPoint2, normalize, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, distancePPointToPLineWithErr, pPointOnPerpWithErr, outOf, pPointOf, ulpOfOut, outputIntersectsLineSeg, pPointBetweenPPointsWithErr) -- The primitives of our PGA only library, and error estimation code. @@ -627,8 +627,8 @@ prop_LineSegIntersectionStableAtOrigin d1 x1 y1 rawX2 rawY2 res1 = intersectsWithErr (Right pLineThroughOriginNotX1Y1NotOther) (Left x1y1LineSegToOrigin) res2 = intersectsWithErr (Right pLineThroughOriginNotX1Y1NotOther) (Left lineSegFromOrigin) distanceStart = case res2 of - (Left (NoIntersection iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distanceBetweenPPointsWithErr iPoint (eToCPPoint2 $ Point2 (0,0))) <> "\nUlpSum:" <> show ulpSum <> "\n" - (Right (IntersectsIn iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distanceBetweenPPointsWithErr iPoint (eToCPPoint2 $ Point2 (0,0))) <> "\nUlpSum:" <> show ulpSum <> "\n" + (Left (NoIntersection iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP iPoint (eToCPPoint2 $ Point2 (0,0))) <> "\nUlpSum:" <> show ulpSum <> "\n" + (Right (IntersectsIn iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP iPoint (eToCPPoint2 $ Point2 (0,0))) <> "\nUlpSum:" <> show ulpSum <> "\n" _ -> "" pLineThroughOriginNotX1Y1NotOther = randomPLineThroughOrigin x2 y2 x1y1LineSegToOrigin = randomX1Y1LineSegToOrigin d1 @@ -673,12 +673,12 @@ prop_LineSegIntersectionStableAtX1Y1Point pointD rawD1 x1 y1 rawX2 rawY2 res1 = intersectsWithErr (Right pLineThroughPointNotX1Y1NotOther) (Left x1y1LineSegToPoint) res2 = intersectsWithErr (Right pLineThroughPointNotX1Y1NotOther) (Left lineSegFromPointNotX1Y1) distanceStart = case res2 of - (Left (NoIntersection iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distanceBetweenPPointsWithErr iPoint (eToCPPoint2 $ Point2 (d2,d2))) <> "\nUlpSum:" <> show ulpSum <> "\n" - (Right (IntersectsIn iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distanceBetweenPPointsWithErr iPoint (eToCPPoint2 $ Point2 (d2,d2))) <> "\nUlpSum:" <> show ulpSum <> "\n" + (Left (NoIntersection iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP iPoint (eToCPPoint2 $ Point2 (d2,d2))) <> "\nUlpSum:" <> show ulpSum <> "\n" + (Right (IntersectsIn iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP iPoint (eToCPPoint2 $ Point2 (d2,d2))) <> "\nUlpSum:" <> show ulpSum <> "\n" _ -> "" distanceEnd = case res1 of - (Left (NoIntersection iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distanceBetweenPPointsWithErr iPoint (eToCPPoint2 $ Point2 (d2,d2))) <> "\nUlpSum:" <> show ulpSum <> "\n" - (Right (IntersectsIn iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distanceBetweenPPointsWithErr iPoint (eToCPPoint2 $ Point2 (d2,d2))) <> "\nUlpSum:" <> show ulpSum <> "\n" + (Left (NoIntersection iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP iPoint (eToCPPoint2 $ Point2 (d2,d2))) <> "\nUlpSum:" <> show ulpSum <> "\n" + (Right (IntersectsIn iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP iPoint (eToCPPoint2 $ Point2 (d2,d2))) <> "\nUlpSum:" <> show ulpSum <> "\n" _ -> "" pLineThroughPointNotX1Y1NotOther = randomPLineThroughPoint x2 y2 d2 x1y1LineSegToPoint = randomX1Y1LineSegToPoint d1 d2 @@ -1190,7 +1190,7 @@ prop_PPointWithinErrRange x y | res > realToFrac (resErr) = error $ "res too big: " <> show res | otherwise = (p1 /= p2) || (res == 0 || error "the same, but distance?") where - (res, UlpSum resErr) = distanceBetweenPPointsWithErr p1 p2 + (res, UlpSum resErr) = distance2PP p1 p2 p1 = makePPoint2 x y p2 = makePPoint2 x y @@ -1370,7 +1370,7 @@ prop_PLinesIntersectAtOrigin rawX y rawX2 rawY2 <> show intersectionErr <> "\n" where originPPoint2 = makePPoint2 0 0 - (foundDistance, UlpSum distanceErr) = distanceBetweenPPointsWithErr originPPoint2 intersectionCPPoint2 + (foundDistance, UlpSum distanceErr) = distance2PP originPPoint2 intersectionCPPoint2 (intersectionCPPoint2, UlpSum canonicalizationErr) = canonicalize intersectionPPoint2 (intersectionPPoint2, intersectionErr) = intersect2PL randomPLine1 randomPLine2 (randomPLine1, UlpSum pline1Err) = randomPLineThroughOrigin x y @@ -1398,7 +1398,7 @@ prop_PLinesIntersectAtPoint rawX y rawX2 rawY2 targetX targetY <> show intersectionErr <> "\n" where (targetPPoint2) = makePPoint2 (coerce targetX) (coerce targetY) - (foundDistance, UlpSum distanceErr) = distanceBetweenPPointsWithErr targetPPoint2 intersectionCPPoint2 + (foundDistance, UlpSum distanceErr) = distance2PP targetPPoint2 intersectionCPPoint2 (intersectionCPPoint2, UlpSum canonicalizationErr) = canonicalize intersectionPPoint2 (intersectionPPoint2, intersectionErr) = intersect2PL randomPLine1 randomPLine2 (randomPLine1, UlpSum pline1Err) = randomPLineWithErr x y targetX targetY @@ -1430,15 +1430,14 @@ prop_PLineIntersectsAtXAxis x y rawX2 y2 m <> show intersectionErr <> "\n" where errSum = ulpVal $ axisIntersectionErr <> distanceErr - (foundDistance, distanceErr) = distanceBetweenPPointsWithErr axisIntersectionPoint intersectionPPoint2 + (foundDistance, distanceErr) = distance2PP axisIntersectionPoint intersectionPPoint2 axisIntersectionErr = snd $ fromJust axisIntersection axisIntersectionPoint = eToPPoint2 $ Point2 ((fromRight (error "not right?") $ fst $ fromJust axisIntersection), 0) axisIntersection = xIntercept (randomPLine1, pline1Err) (intersectionPPoint2, intersectionErr) = intersect2PL randomPLine1 axisPLine (randomPLine1, pline1Err) = randomPL x y rawX2 (coerce y2) + -- Error in this line should be in directions that should not matter. (axisPLine, _) = eToPL $ makeLineSeg (Point2 (0,0)) (Point2 (coerce m,0)) - x2 :: ℝ - x2 = coerce rawX2 prop_PLineIntersectsAtYAxis :: NonZero ℝ -> ℝ -> ℝ -> NonZero ℝ -> NonZero ℝ -> Bool prop_PLineIntersectsAtYAxis x y x2 rawY2 m @@ -1460,13 +1459,14 @@ prop_PLineIntersectsAtYAxis x y x2 rawY2 m <> show intersectionErr <> "\n" where errSum = ulpVal $ axisIntersectionErr <> distanceErr - (foundDistance, distanceErr) = distanceBetweenPPointsWithErr axisIntersectionPoint intersectionPPoint2 + (foundDistance, distanceErr) = distance2PP axisIntersectionPoint intersectionPPoint2 axisIntersectionErr = snd $ fromJust axisIntersection axisIntersectionPoint = eToPPoint2 $ Point2 (0,(fromRight (error "not right?") $ fst $ fromJust axisIntersection)) axisIntersection = yIntercept (randomPLine1, pline1Err) (intersectionPPoint2, intersectionErr) = intersect2PL randomPLine1 axisPLine (randomPLine1, pline1Err) = randomPL (coerce x) y (coerce x2) (coerce y2) - (axisPLine, axisErr) = eToPL $ makeLineSeg (Point2 (0,0)) (Point2 (0,coerce m)) + -- Error in this line should be in directions that should not matter. + (axisPLine, _) = eToPL $ makeLineSeg (Point2 (0,0)) (Point2 (0,coerce m)) y2 :: ℝ y2 = coerce rawY2 From e744f82619ec47f72a636fb9d7c7a1c53678bf27 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Mon, 24 Oct 2022 21:56:27 +0000 Subject: [PATCH 035/206] make motorcycles, inodes, and enodes use PLine2Err to track the error built on their projective outputs and inputs. --- Graphics/Slicer/Math/Arcs.hs | 41 +++--- Graphics/Slicer/Math/Ganja.hs | 50 ++++---- Graphics/Slicer/Math/Intersections.hs | 10 +- Graphics/Slicer/Math/PGA.hs | 62 ++------- Graphics/Slicer/Math/PGAPrimitives.hs | 8 +- Graphics/Slicer/Math/Skeleton/Cells.hs | 20 +-- Graphics/Slicer/Math/Skeleton/Concave.hs | 78 ++++++------ Graphics/Slicer/Math/Skeleton/Definitions.hs | 76 +++++------ Graphics/Slicer/Math/Skeleton/Face.hs | 26 ++-- Graphics/Slicer/Math/Skeleton/Motorcycles.hs | 33 ++--- Graphics/Slicer/Math/Skeleton/NodeTrees.hs | 16 +-- tests/Math/PGA.hs | 125 ++++++++++++------- 12 files changed, 271 insertions(+), 274 deletions(-) diff --git a/Graphics/Slicer/Math/Arcs.hs b/Graphics/Slicer/Math/Arcs.hs index 9f0c922df..3dac508a3 100644 --- a/Graphics/Slicer/Math/Arcs.hs +++ b/Graphics/Slicer/Math/Arcs.hs @@ -22,35 +22,34 @@ module Graphics.Slicer.Math.Arcs (getFirstArcWithErr, getInsideArcWithErr) where -import Prelude (($), (<>), (==), (+), otherwise) +import Prelude (($), (<>), (==), mempty, otherwise) -import Graphics.Slicer.Math.Definitions (Point2, LineSeg(LineSeg), addPoints, distance, scalePoint) +import Graphics.Slicer.Math.Definitions (Point2, addPoints, distance, makeLineSeg, scalePoint) -import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum), addVecPairWithErr, sumErrVals) +import Graphics.Slicer.Math.GeometricAlgebra (addVecPairWithErr) -import Graphics.Slicer.Math.PGA (ProjectiveLine2, PLine2(PLine2), eToPLine2WithErr, flipL, normalize, vecOfL) +import Graphics.Slicer.Math.PGA (ProjectiveLine2, PLine2(PLine2), PLine2Err(PLine2Err), eToPL, flipL, normalizeL, vecOfL) -- | Get a PLine in the direction of the inside of the contour, at the angle bisector of the intersection of the line segment, and another segment from the end of the given line segment, toward the given point. -- Note that we normalize our output, but return it as a PLine2. this is safe, because double normalization (if it happens) only raises the ULP. -getFirstArcWithErr :: Point2 -> Point2 -> Point2 -> (PLine2, UlpSum) +getFirstArcWithErr :: Point2 -> Point2 -> Point2 -> (PLine2, PLine2Err) getFirstArcWithErr p1 p2 p3 -- since we hawe two equal sides, we can draw a point ot the other side of the quad, and use it for constructing. - | distance p2 p1 == distance p2 p3 = (PLine2 $ vecOfL quadRes, UlpSum $ quadErr + quadResErr) + | distance p2 p1 == distance p2 p3 = (PLine2 $ vecOfL quadRes, quadErr <> quadResErr) {- | distance p2 p1 > distance p2 p3 = scaleSide p1 p3 True (distance p2 p1 / distance p2 p3) | otherwise = scaleSide p3 p1 True (distance p2 p3 / distance p2 p1) -} - | otherwise = (insideArc, UlpSum $ side1Err + side2Err + insideArcErr) + | otherwise = (insideArc, insideArcErr) where - (insideArc, UlpSum insideArcErr) = getInsideArcWithErr side1 side2 - (side1, UlpSum side1NormErr) = normalize side1Raw - (side1Raw, UlpSum side1RawErr) = eToPLine2WithErr (LineSeg p1 p2) - side1Err = side1NormErr+side1RawErr - (side2, UlpSum side2NormErr) = normalize side2Raw - (side2Raw, UlpSum side2RawErr) = eToPLine2WithErr (LineSeg p2 p3) - side2Err = side2NormErr+side2RawErr - (quadRes, UlpSum quadResErr) = normalize quad - (quad, UlpSum quadErr) = eToPLine2WithErr $ LineSeg p2 $ scalePoint 0.5 $ addPoints p1 p3 + (insideArc, insideArcErr) = getInsideArcWithErr side1 side2 + -- FIXME: how do these errors effect the result? + (side1, _) = normalizeL side1Raw + (side1Raw, _) = eToPL (makeLineSeg p1 p2) + (side2, _) = normalizeL side2Raw + (side2Raw, _) = eToPL (makeLineSeg p2 p3) + (quadRes, quadResErr) = normalizeL quad + (quad, quadErr) = eToPL $ makeLineSeg p2 $ scalePoint 0.5 $ addPoints p1 p3 {- scaleSide ps1 ps2 t v | t == True = (PLine2 scaledRes, UlpSum $ scaledUlp + scaledResUlp) @@ -64,14 +63,14 @@ getFirstArcWithErr p1 p2 p3 -- | Get a PLine along the angle bisector of the intersection of the two given line segments, pointing in the 'acute' direction. -- Note that we normalize our output, but don't bother normalizing our input lines, as the ones we output and the ones getFirstArcWithErr outputs are normalized. -- Note that we know that the inside is to the right of the first line given, and that the first line points toward the intersection. -getInsideArcWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PLine2, UlpSum) +getInsideArcWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PLine2, PLine2Err) getInsideArcWithErr line1 line2 -- | pline1 == pline2 = error "need to be able to return two PLines." - | otherwise = (PLine2 $ vecOfL normRes, ulpSum) + | otherwise = (PLine2 $ vecOfL normRes, errTotal) where - ulpSum = resUlp <> sumErrVals addVecErr - (normRes, resUlp) = normalize $ PLine2 $ addVecRes - (addVecRes, addVecErr) = addVecPairWithErr flippedPV1 pv2 + errTotal = normErr <> PLine2Err addVecErrs mempty mempty mempty mempty mempty + (normRes, normErr) = normalizeL $ PLine2 $ addVecRes + (addVecRes, addVecErrs) = addVecPairWithErr flippedPV1 pv2 flippedPV1 = vecOfL $ flipL line1 pv2 = vecOfL line2 diff --git a/Graphics/Slicer/Math/Ganja.hs b/Graphics/Slicer/Math/Ganja.hs index 739efeac8..3c3b44afe 100644 --- a/Graphics/Slicer/Math/Ganja.hs +++ b/Graphics/Slicer/Math/Ganja.hs @@ -81,7 +81,7 @@ -- so we can define a Num instance for Positive. {-# OPTIONS_GHC -Wno-orphans #-} -module Graphics.Slicer.Math.Ganja (GanjaAble, ListThree, Radian(Radian), edgesOf, generationsOf, toGanja, dumpGanja, dumpGanjas, randomPL, randomTriangle, randomSquare, randomRectangle, randomConvexDualRightQuad, randomConvexSingleRightQuad, randomConvexBisectableQuad, randomConvexQuad, randomConcaveChevronQuad, randomENode, randomINode, randomPLine, randomPLineWithErr, randomLineSeg, cellFrom, remainderFrom, onlyOne, onlyOneOf, randomPLineThroughOrigin, randomLineSegFromOriginNotX1Y1, randomX1Y1LineSegToOrigin, randomX1Y1LineSegToPoint, randomLineSegFromPointNotX1Y1, randomPLineThroughPoint, randomLineSegWithErr) where +module Graphics.Slicer.Math.Ganja (GanjaAble, ListThree, Radian(Radian), edgesOf, generationsOf, toGanja, dumpGanja, dumpGanjas, randomPL, randomTriangle, randomSquare, randomRectangle, randomConvexDualRightQuad, randomConvexSingleRightQuad, randomConvexBisectableQuad, randomConvexQuad, randomConcaveChevronQuad, randomENode, randomINode, randomPLine, randomPLineWithErr, randomLineSeg, cellFrom, remainderFrom, onlyOne, onlyOneOf, randomPLineThroughOrigin, randomLineSegFromOriginNotX1Y1, randomX1Y1LineSegToOrigin, randomX1Y1LineSegToPoint, randomLineSegFromPointNotX1Y1, randomPLineThroughPoint) where import Prelude (Bool, Enum, Eq, Fractional, Num, Ord, Show, String, Int, (<>), (<>), (<$>), ($), (>=), (==), abs, concat, error, fromInteger, fromRational, fst, mod, otherwise, replicate, show, signum, snd, zip, (.), (+), (-), (*), (<), (/), (>), (<=), (&&), (/=)) @@ -114,7 +114,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (GNum(GEPlus, GEZero), GVec(GVec), import Graphics.Slicer.Math.Lossy (eToPLine2, join2PPoint2, normalizePLine2, pPointBetweenPPoints, pToEPoint2) -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), PLine2(PLine2), PPoint2(PPoint2), PLine2Err, eToPLine2WithErr, eToPL, eToPPoint2, flipL, translateRotatePPoint2, ulpOfLineSeg, outOf, pPointOf, NPLine2(NPLine2)) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), PLine2(PLine2), PPoint2(PPoint2), PLine2Err, eToPLine2WithErr, eToPL, eToPPoint2, flipL, normalizeL, translateRotatePPoint2, outOf, pPointOf, NPLine2(NPLine2)) import Graphics.Slicer.Math.Skeleton.Concave (makeENode, getOutsideArc) @@ -205,7 +205,7 @@ instance GanjaAble ENode where (plvar, plref) = toGanja (outOf eNode) (varname <> "c") instance GanjaAble Motorcycle where - toGanja (Motorcycle (l1, l2) outPLine _ _) varname = ( + toGanja (Motorcycle (l1, l2) outPLine _) varname = ( l1var <> l2var <> plvar @@ -259,9 +259,9 @@ instance GanjaAble INode where where (invars, inrefs) = (concat $ fst <$> res, concat $ snd <$> res) where - res = (\(a,b) -> toGanja a (varname <> b)) <$> zip allPLines allStrings + res = (\(a,b) -> toGanja (fst a) (varname <> b)) <$> zip allPLines allStrings allStrings = [ c : s | s <- "": allStrings, c <- ['a'..'z'] <> ['0'..'9'] ] - allPLines = firstPLine:secondPLine:rawMorePLines <> maybeToList outPLine + allPLines = firstPLine:secondPLine:rawMorePLines <> maybeToList outPLine instance GanjaAble StraightSkeleton where toGanja (StraightSkeleton (Slist [[nodetree]] _) _) = toGanja nodetree @@ -651,19 +651,20 @@ randomENode x y d1 rawR1 d2 rawR2 = makeENode p1 intersectionPoint p2 intersectionPPoint = eToPPoint2 intersectionPoint randomINode :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> Positive ℝ -> Radian ℝ -> Bool -> Bool -> INode -randomINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 = makeINode [maybeFlippedpl1,maybeFlippedpl2] (Just bisector1) +randomINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 = makeINode [maybeFlippedpl1,maybeFlippedpl2] (Just $ (\(NPLine2 a,b) -> (PLine2 a,b <> outsideResErr)) bisector1) where r1 = rawR1 / 2 r2 = r1 + (rawR2 / 2) - pl1 = (\(NPLine2 a) -> PLine2 a) $ normalizePLine2 $ eToPLine2 $ getFirstLineSeg eNode - pl2 = (\(NPLine2 a) -> PLine2 a) $ normalizePLine2 $ flipL $ eToPLine2 $ getLastLineSeg eNode + pl1 = (\(NPLine2 a,b) -> (PLine2 a,b)) $ normalizeL $ eToPLine2 $ getFirstLineSeg eNode + pl2 = (\(NPLine2 a,b) -> (PLine2 a,b)) $ normalizeL $ flipL $ eToPLine2 $ getLastLineSeg eNode intersectionPPoint = pPointOf eNode eNode = randomENode x y d1 rawR1 d2 rawR2 pp1 = translateRotatePPoint2 intersectionPPoint (coerce d1) (coerce r1) pp2 = translateRotatePPoint2 intersectionPPoint (coerce d2) (coerce r2) - maybeFlippedpl1 = if flipIn1 then flipL pl1 else pl1 - maybeFlippedpl2 = if flipIn2 then flipL pl2 else pl2 - bisector1 = (\(NPLine2 a) -> PLine2 a) $ normalizePLine2 $ getOutsideArc pp1 (normalizePLine2 maybeFlippedpl1) pp2 (normalizePLine2 maybeFlippedpl2) + maybeFlippedpl1 = (if flipIn1 then flipL (fst pl1) else (fst pl1), snd pl1) + maybeFlippedpl2 = (if flipIn2 then flipL (fst pl2) else (fst pl2), snd pl2) + bisector1 = normalizeL outsideRes + (outsideRes, outsideResErr) = getOutsideArc pp1 (normalizePLine2 $ fst maybeFlippedpl1) pp2 (normalizePLine2 $ fst maybeFlippedpl2) -- | A helper function. constructs a random PLine. randomPLine :: ℝ -> ℝ -> NonZero ℝ -> NonZero ℝ -> PLine2 @@ -679,13 +680,8 @@ randomPL x y dx dy = eToPL $ makeLineSeg (Point2 (x, y)) (Point2 (coerce dx, coe -- | A helper function. constructs a random LineSeg. randomLineSeg :: ℝ -> ℝ -> ℝ -> ℝ -> LineSeg -randomLineSeg x y rawDx rawDy = fst $ randomLineSegWithErr x y rawDx rawDy +randomLineSeg x y dx dy = makeLineSeg (Point2 (x, y)) (Point2 (dx,dy)) -randomLineSegWithErr :: ℝ -> ℝ -> ℝ -> ℝ -> (LineSeg, UlpSum) -randomLineSegWithErr x1 y1 x2 y2 = (res, ulpSum) - where - res = makeLineSeg (Point2 (x1, y1)) (Point2 (x2, y2)) - ulpSum = ulpOfLineSeg res -- | A PLine that does not follow the X = Y line, and does not follow the other given line. randomPLineThroughOrigin :: ℝ -> ℝ -> (PLine2, UlpSum) @@ -696,42 +692,38 @@ randomPLineThroughPoint :: ℝ -> ℝ -> ℝ -> (PLine2, UlpSum) randomPLineThroughPoint x y d = eToPLine2WithErr $ makeLineSeg (Point2 (x,y)) (Point2 (d,d)) -- | A line segment ending at the origin. additionally, guaranteed not to be on the X = Y line. -randomLineSegFromPointNotX1Y1 :: ℝ -> ℝ -> ℝ -> (LineSeg, UlpSum) -randomLineSegFromPointNotX1Y1 rawX rawY d = (res, ulpSum) +randomLineSegFromPointNotX1Y1 :: ℝ -> ℝ -> ℝ -> LineSeg +randomLineSegFromPointNotX1Y1 rawX rawY d = res where res = makeLineSeg (Point2 (d, d)) (Point2 (x, y)) (x, y) | rawX == 0 && rawY == 0 = (0,0.1) | rawX == rawY = (rawX,0.1) | otherwise = (rawX, rawY) - ulpSum = ulpOfLineSeg res -- | A line segment ending at the origin. additionally, guaranteed not to be on the X = Y line. -randomLineSegFromOriginNotX1Y1 :: ℝ -> ℝ -> (LineSeg, UlpSum) -randomLineSegFromOriginNotX1Y1 rawX rawY = (res, ulpSum) +randomLineSegFromOriginNotX1Y1 :: ℝ -> ℝ -> LineSeg +randomLineSegFromOriginNotX1Y1 rawX rawY = res where res = makeLineSeg (Point2 (0, 0)) (Point2 (x, y)) (x, y) | rawX == 0 && rawY == 0 = (0,0.1) | rawX == rawY = (rawX,0.1) | otherwise = (rawX, rawY) - ulpSum = ulpOfLineSeg res -randomX1Y1LineSegToOrigin :: NonZero ℝ -> (LineSeg, UlpSum) -randomX1Y1LineSegToOrigin rawD = (res, ulpSum) +randomX1Y1LineSegToOrigin :: NonZero ℝ -> LineSeg +randomX1Y1LineSegToOrigin rawD = res where res = makeLineSeg (Point2 (d,d)) (Point2 (0,0)) d :: ℝ d = coerce rawD - ulpSum = ulpOfLineSeg res -randomX1Y1LineSegToPoint :: NonZero ℝ -> ℝ -> (LineSeg, UlpSum) -randomX1Y1LineSegToPoint rawD1 d2 = (res, ulpSum) +randomX1Y1LineSegToPoint :: NonZero ℝ -> ℝ -> LineSeg +randomX1Y1LineSegToPoint rawD1 d2 = res where res = makeLineSeg (Point2 (d1,d1)) (Point2 (d2,d2)) d1 :: ℝ d1 = coerce rawD1 - ulpSum = ulpOfLineSeg res -- | combine two lists. for feeding into randomStarPoly. makePairs :: [a] -> [b] -> [(a,b)] diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index 186a63c0f..8f9e0f949 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -36,14 +36,14 @@ import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, mapWithNeighb import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum)) -import Graphics.Slicer.Math.PGA (CPPoint2, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), Intersection(HitEndPoint, HitStartPoint, NoIntersection), PLine2, intersectsWith, distanceBetweenPLinesWithErr, outputIntersectsLineSeg, plinesIntersectIn, pToEP, ulpOfLineSeg) +import Graphics.Slicer.Math.PGA (CPPoint2, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), Intersection(HitEndPoint, HitStartPoint, NoIntersection), PLine2, intersectsWith, distanceBetweenPLinesWithErr, outputIntersectsLineSeg, plinesIntersectIn, pToEP) import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle)) -- | Get all possible intersections between the motorcycle and the given list of segments. -- Filters out the input and output segment of the motorcycle. getMotorcycleSegSetIntersections :: Motorcycle -> [LineSeg] -> [(LineSeg, Either Point2 CPPoint2)] -getMotorcycleSegSetIntersections m@(Motorcycle (inSeg, outSeg) _ _ _) segs = stripInSegOutSeg $ catMaybes $ mapWithNeighbors filterIntersections $ shortCircuit $ zip bufferedLineSegs $ mightIntersect <$> bufferedLineSegs +getMotorcycleSegSetIntersections m@(Motorcycle (inSeg, outSeg) _ _) segs = stripInSegOutSeg $ catMaybes $ mapWithNeighbors filterIntersections $ shortCircuit $ zip bufferedLineSegs $ mightIntersect <$> bufferedLineSegs where -- since this is a list of segments, we terminate the list with Nothings, so that the saneIntersections pattern matching logic can deal with "there is no neighbor, but i hit a start/end point" bufferedLineSegs :: [Maybe LineSeg] @@ -51,7 +51,7 @@ getMotorcycleSegSetIntersections m@(Motorcycle (inSeg, outSeg) _ _ _) segs = str mightIntersect :: Maybe LineSeg -> Maybe (Either Intersection PIntersection) mightIntersect maybeSeg = case maybeSeg of Nothing -> Nothing - (Just seg) -> Just $ outputIntersectsLineSeg m (seg, ulpOfLineSeg seg) + (Just seg) -> Just $ outputIntersectsLineSeg m seg shortCircuit :: [(Maybe LineSeg, Maybe (Either Intersection PIntersection))] -> [Maybe (LineSeg, Either Intersection PIntersection)] shortCircuit items = shortCircuitItem <$> items where @@ -67,10 +67,10 @@ getMotorcycleSegSetIntersections m@(Motorcycle (inSeg, outSeg) _ _ _) segs = str -- | Get all possible intersections between the motorcycle and the contour. -- Filters out the input and output segment of the motorcycle. getMotorcycleContourIntersections :: Motorcycle -> Contour -> [(LineSeg, Either Point2 CPPoint2)] -getMotorcycleContourIntersections m@(Motorcycle (inSeg, outSeg) _ _ _) c = stripInSegOutSeg $ catMaybes $ mapWithNeighbors filterIntersections $ openCircuit $ zip contourLines $ willIntersect <$> contourLines +getMotorcycleContourIntersections m@(Motorcycle (inSeg, outSeg) _ _) c = stripInSegOutSeg $ catMaybes $ mapWithNeighbors filterIntersections $ openCircuit $ zip contourLines $ willIntersect <$> contourLines where willIntersect :: LineSeg -> Either Intersection PIntersection - willIntersect mySeg = outputIntersectsLineSeg m (mySeg, ulpOfLineSeg mySeg) + willIntersect mySeg = outputIntersectsLineSeg m mySeg openCircuit v = Just <$> v contourLines = lineSegsOfContour c stripInSegOutSeg :: [(LineSeg, Either Point2 CPPoint2)] -> [(LineSeg, Either Point2 CPPoint2)] diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index f2d2f9af4..f5ed0bab0 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -24,7 +24,7 @@ -- | The purpose of this file is to hold projective geometric algebraic arithmatic. It defines a 2D PGA with mixed linear components. module Graphics.Slicer.Math.PGA( - Arcable(hasArc, outOf, ulpOfOut, outUlpMag), + Arcable(errOfOut, hasArc, outOf), CPPoint2(CPPoint2), Intersection(HitStartPoint, HitEndPoint, NoIntersection), NPLine2(NPLine2), @@ -62,12 +62,10 @@ module Graphics.Slicer.Math.PGA( plinesIntersectIn, translateL, translateRotatePPoint2, - ulpOfLineSeg, - ulpOfPLine2, vecOfL ) where -import Prelude (Bool, Eq((==),(/=)), Monoid(mempty), Semigroup((<>)), Show(show), ($), (*), (-), (>=), (&&), (<$>), otherwise, signum, (>), (<=), (+), negate, (/), (||), (<), abs, error, sin, cos, realToFrac, fst, sum, (.)) +import Prelude (Bool, Eq((==),(/=)), Monoid(mempty), Semigroup((<>)), Show(show), ($), (*), (-), (>=), (&&), (<$>), otherwise, signum, snd, (>), (<=), (+), negate, (/), (||), (<), abs, error, sin, cos, realToFrac, fst, sum, (.)) import Data.Bits.Floating.Ulp (doubleUlp) @@ -77,7 +75,7 @@ import Data.List (foldl') import Data.List.Ordered (foldt) -import Data.Maybe (Maybe(Just, Nothing), catMaybes, fromJust, isNothing, maybeToList) +import Data.Maybe (Maybe(Just, Nothing), catMaybes, fromJust, fromMaybe, isNothing, maybeToList) import Data.Set (singleton, fromList) @@ -93,7 +91,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (GNum(G0, GEPlus, GEZero), GVal(GVa import Graphics.Slicer.Math.Line (combineLineSegs) -import Graphics.Slicer.Math.PGAPrimitives(Arcable(hasArc, outOf, outUlpMag, ulpOfOut), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(angleBetween2PL, flipL, forceBasisOfL, intersect2PL, normalize, normalizeL, normOfL, translateL, vecOfL), ProjectivePoint2(canonicalize, distance2PP, forceBasisOfP, idealNormOfP, join2PP, join2PPWithErr, pToEP, vecOfP)) +import Graphics.Slicer.Math.PGAPrimitives(Arcable(errOfOut, hasArc, outOf), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(angleBetween2PL, flipL, forceBasisOfL, intersect2PL, normalize, normalizeL, normOfL, translateL, vecOfL), ProjectivePoint2(canonicalize, distance2PP, forceBasisOfP, idealNormOfP, join2PP, join2PPWithErr, pToEP, vecOfP), xIntercept, yIntercept) -- Our 2D plane coresponds to a Clifford algebra of 2,0,1. @@ -126,8 +124,7 @@ plinesIntersectIn pl1 pl2 (idealNorm, idnErr) = idealNormOfP intersectPoint (_, iaErr) = angleBetween2PL npl1 npl2 -- FIXME: how much do the potential normalization errors have an effect on the resultant angle? - (intersectPoint, intersectUlp) = intersect2PL pl1 pl2 - -- FIXME: remove the canonicalization from this function, moving it to the callers. + (intersectPoint, _) = intersect2PL pl1 pl2 (res, resUlp) = fromJust canonicalizedIntersection canonicalizedIntersection = canonicalizeIntersectionWithErr pl1 pl2 npl1 = normalizeL pl1 @@ -303,50 +300,21 @@ intersectsWith (Left l1) (Right pl1) = pLineIntersectsLineSeg (pl1, ul intersectsWith (Right pl1) (Left l1) = pLineIntersectsLineSeg (pl1, ulpOfPLine2 pl1) (l1, ulpOfLineSeg l1) 0 -- | Check if/where the arc of a motorcycle, inode, or enode intersect a line segment. -outputIntersectsLineSeg :: (Show a, Arcable a, Pointable a) => a -> (LineSeg, UlpSum) -> Either Intersection PIntersection -outputIntersectsLineSeg source (l1, UlpSum l1Err) +outputIntersectsLineSeg :: (Show a, Arcable a) => a -> LineSeg -> Either Intersection PIntersection +outputIntersectsLineSeg source l1 -- handle the case where a segment that is an input to the node is checked against. | isNothing canonicalizedIntersection = Right $ plinesIntersectIn pl1 pl2 - | intersectionDistance < foundError = pLineIntersectsLineSeg (pl1, UlpSum pl1Err) (l1, UlpSum l1Err) 1 - | ulpScale > 100000 = error - $ "wtf\n" - <> "ulpScale: " <> show ulpScale <> "\n" - <> "travelUlpMul: " <> show travelUlpMul <> "\n" - <> "ulpMultiplier: " <> show ulpMultiplier <> "\n" - <> "angle: " <> show angle <> "\n" - <> "angleErr: " <> show angleErr <> "\n" - <> "pl1Mag: " <> show pl1Mag <> "\n" - <> "intersectionDistance: " <> show intersectionDistance <> "\n" - <> show source <> "\n" - <> show pl2 <> "\n" - <> show l1 <> "\n" - <> show foundError <> "\n" - | otherwise = pLineIntersectsLineSeg (pl1, UlpSum pl1Err) (l1, UlpSum l1Err) ulpScale + | otherwise = pLineIntersectsLineSeg (pl1, pl1Ulp) (l1, pl2Ulp) 1 where - foundError :: ℝ - foundError = realToFrac $ l1Err + pl1Err + pl2Err + rawIntersectionErr + intersectionDistanceErr + canonicalizedSourceErr - -- | the multiplier used to expand the hitcircle of an endpoint. - ulpScale :: ℝ - ulpScale = realToFrac $ ulpMultiplier * realToFrac travelUlpMul * abs (realToFrac angle + angleErr) - (angle, UlpSum angleErr) = angleBetween2PL (npl1, npl2Err) (npl2, npl2Err) - (npl1, npl1Err) = normalizeL pl1 - (npl2, npl2Err) = normalizeL pl2 - (pl2, UlpSum pl2Err) = eToPLine2WithErr l1 - -- the multiplier to account for distance between our Pointable, and where it intersects. - travelUlpMul - | canPoint source = pl1Mag / intersectionDistance - | otherwise = error - $ "cannot resolve source to a point?\n" - <> show source <> "\n" - (pl1, UlpSum pl1Err, pl1Mag) - | hasArc source = (outOf source, ulpOfOut source, outUlpMag source) + pl2Ulp = snd (fromMaybe (Right 0,mempty) $ xIntercept (pl2,pl2Err)) <> snd (fromMaybe (Right 0,mempty) $ yIntercept (pl2,pl2Err)) + (pl2, pl2Err) = eToPL l1 + pl1Ulp = snd (fromMaybe (Right 0,mempty) $ xIntercept (pl1,pl1Err)) <> snd (fromMaybe (Right 0,mempty) $ yIntercept (pl1,pl1Err)) + (pl1, pl1Err) + | hasArc source = (outOf source, errOfOut source) | otherwise = error $ "no arc from source?\n" <> show source <> "\n" - (rawIntersection, UlpSum rawIntersectionErr) = fromJust canonicalizedIntersection canonicalizedIntersection = canonicalizeIntersectionWithErr pl1 pl2 - (canonicalizedSource, UlpSum canonicalizedSourceErr) = canonicalize $ pPointOf source - (intersectionDistance, UlpSum intersectionDistanceErr) = distance2PP canonicalizedSource rawIntersection -- | A type alias, for cases where either input is acceptable. type SegOrPLine2WithErr = Either (LineSeg, UlpSum) (PLine2,UlpSum) @@ -441,10 +409,6 @@ lineSegIntersectsLineSeg (l1, UlpSum l1Err) (l2, UlpSum ulpL2) (pl2, UlpSum pl2Err) = eToPLine2WithErr l2 -- | the sum of all ULPs. used to expand the hitcircle of an endpoint. ulpTotal = pl1Err + pl2Err + l1Err + ulpL2 - ulpScale = 120 + ulpMultiplier * (realToFrac angle+angleErr) * (realToFrac angle+angleErr) - (angle, UlpSum angleErr) = angleBetween2PL (npl1, npl1Err) (npl2, npl2Err) - (npl1, npl1Err) = normalizeL pl1 - (npl2, npl2Err) = normalizeL pl2 dumpULPs = "pl1Err: " <> show pl1Err <> "\npl2Err: " <> show pl2Err <> "\nl1Err: " <> show l1Err <> "\nrawIntersectErr: " <> show rawIntersectErr <> "\n" hasIntersection = hasRawIntersection && onSegment l1 rawIntersection ulpStartSum1 ulpEndSum1 && onSegment l2 rawIntersection ulpStartSum2 ulpEndSum2 hasRawIntersection = valOf 0 foundVal /= 0 diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index 447102459..88bdf3e2a 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -25,10 +25,9 @@ module Graphics.Slicer.Math.PGAPrimitives ( Arcable( + errOfOut, hasArc, - outOf, - outUlpMag, - ulpOfOut + outOf ), CPPoint2(CPPoint2), NPLine2(NPLine2), @@ -460,10 +459,9 @@ class Pointable a where -- | does this node have an output (resulting) pLine? class Arcable a where + errOfOut :: a -> PLine2Err hasArc :: a -> Bool outOf :: a -> PLine2 - ulpOfOut :: a -> UlpSum - outUlpMag :: a -> ℝ class (Show a) => ProjectivePoint2 a where canonicalize :: a -> (CPPoint2, UlpSum) diff --git a/Graphics/Slicer/Math/Skeleton/Cells.hs b/Graphics/Slicer/Math/Skeleton/Cells.hs index 53667db86..2f95bdf8b 100644 --- a/Graphics/Slicer/Math/Skeleton/Cells.hs +++ b/Graphics/Slicer/Math/Skeleton/Cells.hs @@ -56,10 +56,12 @@ import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum)) import Graphics.Slicer.Math.Intersections (intersectionOf) -import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, eToCPPoint2, eToPLine2, join2PPoint2, pToEPoint2) +import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, eToCPPoint2, eToPLine2, pToEPoint2) import Graphics.Slicer.Math.PGA (Arcable(outOf), CPPoint2(CPPoint2), Pointable(canPoint, ePointOf, pPointOf), PIntersection(PAntiCollinear, IntersectsIn), PPoint2(PPoint2), angleBetween2PL, distance2PP, eToPL, eToPPoint2, normalizeL, plinesIntersectIn) +import Graphics.Slicer.Math.PGAPrimitives (join2PPWithErr) + data UnsupportedReason = INodeCrossesDivide ![(INode,CellDivide)] !NodeTree deriving (Show, Eq) @@ -166,7 +168,7 @@ findNextCell (RemainingContour (Slist [(Slist lineSegs _, divides)] _) ) = cell = createCellFromStraightWalls (slist [lineSegs]) [closestDivide] remainder = findRemainder cell lineSegs divides remainingSegmentsOf (RemainingContour l) = l - closestDivide = if fst (fst $ head divideClosestSorted) == fst ( fst $ head divideFurthestSorted) + closestDivide = if fst (fst $ head divideClosestSorted) == fst (fst $ head divideFurthestSorted) then snd $ head divideClosestSorted else error $ "Divide collision:\n" <> show divideClosestSorted <> "\n" <> show divideFurthestSorted <> "\n" divideClosestSorted = slist $ sortBy (compareDivides lineSegs) $ closestSegOfDivide lineSegs <$> divides @@ -273,7 +275,7 @@ createCellFromStraightWalls (Slist [] _) _ = error "empty slist." createCellFromStraightWalls (Slist (_:_:_) _) _ = error "too many segsets." createCellFromStraightWalls _ [] = error "no celldivide." createCellFromStraightWalls _ (_:_:_) = error "too many celldivides." -createCellFromStraightWalls segSets@(Slist [segments] _) [cellDivide@(CellDivide (DividingMotorcycles motorcycle@(Motorcycle (_,outSeg) _ _ _) _) _)] +createCellFromStraightWalls segSets@(Slist [segments] _) [cellDivide@(CellDivide (DividingMotorcycles motorcycle@(Motorcycle (_,outSeg) _ _) _) _)] | len segSets == 0 = error "recieved no line segments. unpossible." | isLoop segSets && len segSets == len afterRes = error "passing back full segment list, which should not be possible." | isLoop segSets = Cell (slist [(afterRes, Just cellDivide)]) @@ -330,7 +332,7 @@ startBeforeEnd segments cellDivide = elemIndex (fst $ startOfDivide segments cel -- Get the segment the divide intersects that is closest to the beginning of the list of a contour's line segments. startOfDivide :: [LineSeg] -> CellDivide -> (LineSeg, Either Point2 CPPoint2) -startOfDivide _ (CellDivide (DividingMotorcycles (Motorcycle (inSeg,LineSeg start _) _ _ _) _) _) = (inSeg, Left start) +startOfDivide _ (CellDivide (DividingMotorcycles (Motorcycle (inSeg,LineSeg start _) _ _) _) _) = (inSeg, Left start) -- Get the segment the divide intersects that is closest to the end of the list of a contour's line segments. endOfDivide :: CellDivide -> (LineSeg, Either Point2 CPPoint2) @@ -351,7 +353,7 @@ maybeEndOfDivide (CellDivide (DividingMotorcycles m ms) lastIntersection) | otherwise = Nothing where startSegOfMotorcycle :: Motorcycle -> LineSeg - startSegOfMotorcycle (Motorcycle (startSeg, _) _ _ _) = startSeg + startSegOfMotorcycle (Motorcycle (startSeg, _) _ _) = startSeg -- | Add a pair of NodeTrees together along a Divide, to create a new nodeTree. -- The intersection point for the nodeTrees along the CellDivide is calculated, and then the out of final INode of the two sides is adjusted to pass through that point. @@ -367,7 +369,7 @@ addNodeTreesAlongDivide nodeTree1 nodeTree2 division = mergeNodeTrees (adjustedN case nub $ insOf $ lastINodeOf iNodeGens of [] -> error "unpossible." [_] -> NodeTree eNodes $ INodeSet $ init gens - (_:_) -> NodeTree eNodes $ INodeSet $ init gens <> one [makeINode (nub $ insOf $ lastINodeOf iNodeGens) (Just $ join2PPoint2 (finalPointOfNodeTree nodeTree) myCrossover)] + (_:_) -> NodeTree eNodes $ INodeSet $ init gens <> one [makeINode (nub $ insOf $ lastINodeOf iNodeGens) (Just $ join2PPWithErr (finalPointOfNodeTree nodeTree) myCrossover)] -- | find the last resolvable point in a NodeTree finalPointOfNodeTree (NodeTree _ iNodeGens) | canPoint (lastINodeOf iNodeGens) = pPointOf $ lastINodeOf iNodeGens @@ -405,7 +407,7 @@ nodeTreesDoNotOverlap nodeTree1 nodeTree2 cellDivide@(CellDivide motorcycles1 _) -- | Check that the outputs of the NodeTrees collide at the same point at the division between the two cells the NodeTrees correspond to. lastOutsIntersect :: NodeTree -> NodeTree -> CellDivide -> Bool lastOutsIntersect nt1 nt2 (CellDivide motorcycles _) = case motorcycles of - (DividingMotorcycles m (Slist _ 0)) -> plinesIntersectIn (finalPLine nt1) (outOf m) == plinesIntersectIn (finalPLine nt2) (outOf m) + (DividingMotorcycles m (Slist _ 0)) -> plinesIntersectIn (fst $ finalPLine nt1) (outOf m) == plinesIntersectIn (fst $ finalPLine nt2) (outOf m) (DividingMotorcycles _ (Slist _ _)) -> error "cannot yet check outpoint intersections of more than one motorcycle." -- | Given a nodeTree and it's closing division, return all of the ENodes where the point of the node is on the opposite side of the division. @@ -421,5 +423,5 @@ crossoverINodes nodeTree@(NodeTree _ (INodeSet (Slist iNodes _))) cellDivision = | lastSegOf cell == firstCSegOf m = startPoint $ lastSegOf cell | otherwise = error $ "unhandled case: " <> show cell <> "\n" <> show m <> "\n" <> show (lastSegOf cell) <> "\n" <> show (firstSegOf cell) <> "\n" where - firstCSegOf (Motorcycle (seg1,_) _ _ _) = seg1 - lastCSegOf (Motorcycle (_, seg2) _ _ _) = seg2 + firstCSegOf (Motorcycle (seg1,_) _ _) = seg1 + lastCSegOf (Motorcycle (_, seg2) _ _) = seg2 diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index 91413dc52..2e9e63ee9 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -28,7 +28,7 @@ module Graphics.Slicer.Math.Skeleton.Concave (skeletonOfConcaveRegion, findINodes, getOutsideArc, makeENode, makeENodes, averageNodes, eNodesOfOutsideContour, towardIntersection) where -import Prelude (Eq, Show, Bool(True, False), Either(Left, Right), String, Ord, Ordering(GT,LT), notElem, otherwise, ($), (>), (<), (<$>), (==), (/=), (>=), error, (&&), fst, and, (<>), show, not, max, concat, compare, uncurry, null, (||), min, snd, filter, zip, any, (*), (+), Int, (.), (<=), (-), (/), realToFrac) +import Prelude (Eq, Show, Bool(True, False), Either(Left, Right), String, Ord, Ordering(GT,LT), notElem, otherwise, ($), (>), (<), (<$>), (==), (/=), (>=), error, (&&), fst, and, (<>), show, not, max, concat, compare, uncurry, null, (||), min, snd, filter, zip, any, (*), (+), Int, (.), (<=), (-), realToFrac) import Prelude as PL (head, last, tail, init) @@ -50,21 +50,21 @@ import Slist as SL (head, last, tail) import Graphics.Implicit.Definitions (ℝ) -import Graphics.Slicer.Math.Arcs (getFirstArcWithErr) +import Graphics.Slicer.Math.Arcs (getFirstArcWithErr, getInsideArcWithErr) import Graphics.Slicer.Math.Contour (lineSegsOfContour) -import Graphics.Slicer.Math.Definitions (Contour, LineSeg(LineSeg), Point2, endPoint, mapWithFollower, fudgeFactor, startPoint, distance) +import Graphics.Slicer.Math.Definitions (Contour, LineSeg(LineSeg), Point2, endPoint, mapWithFollower, fudgeFactor, startPoint) import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum)) import Graphics.Slicer.Math.Intersections (intersectionOf, intersectionBetween, isCollinear, isParallel, isAntiCollinear, noIntersection) -import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, distancePPointToPLine, eToPLine2, getInsideArc, join2CPPoint2, normalizePLine2) +import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, distancePPointToPLine, eToPLine2, join2CPPoint2, normalizePLine2) -import Graphics.Slicer.Math.PGA (Arcable(hasArc, outOf), Pointable(canPoint, pPointOf), PLine2(PLine2), ProjectivePoint2, CPPoint2(CPPoint2), PPoint2(PPoint2), canonicalize, distance2PP, flipL, normalizeL, pLineIsLeft, angleBetween2PL, distancePPointToPLineWithErr, NPLine2(NPLine2)) +import Graphics.Slicer.Math.PGA (Arcable(errOfOut, hasArc, outOf), Pointable(canPoint, pPointOf), PLine2(PLine2), PLine2Err, ProjectivePoint2, CPPoint2(CPPoint2), PPoint2(PPoint2), canonicalize, distance2PP, flipL, normalizeL, pLineIsLeft, angleBetween2PL, distancePPointToPLineWithErr, NPLine2(NPLine2)) -import Graphics.Slicer.Math.Skeleton.Definitions (ENode(ENode), ENodeSet(ENodeSet), INode(INode), INodeSet(INodeSet), NodeTree(NodeTree), concavePLines, getFirstLineSeg, getLastLineSeg, finalOutOf, firstInOf, getPairs, indexPLinesTo, insOf, lastINodeOf, linePairs, makeINode, sortedPLines, isLoop) +import Graphics.Slicer.Math.Skeleton.Definitions (ENode(ENode), ENodeSet(ENodeSet), INode(INode), INodeSet(INodeSet), NodeTree(NodeTree), concavePLines, getFirstLineSeg, getLastLineSeg, finalOutOf, firstInOf, getPairs, indexPLinesTo, insOf, lastINodeOf, linePairs, makeINode, sortedPLinesWithErr, isLoop) import Graphics.Slicer.Math.Skeleton.NodeTrees (makeNodeTree, findENodeByOutput) @@ -109,11 +109,11 @@ findINodes inSegSets | len inSegSets == 2 = -- Two walls, no closed ends. solve the ends of a hallway region, so we can then hand off the solutioning to our regular process. case initialENodes of - [] -> INodeSet $ slist [[makeINode [getInsideArc (flipL $ eToPLine2 firstSeg) (eToPLine2 lastSeg), getInsideArc (eToPLine2 firstSeg) (flipL $ eToPLine2 lastSeg)] Nothing]] + [] -> INodeSet $ slist [[makeINode [getInsideArcWithErr (flipL $ eToPLine2 firstSeg) (eToPLine2 lastSeg), getInsideArcWithErr (eToPLine2 firstSeg) (flipL $ eToPLine2 lastSeg)] Nothing]] where firstSeg = SL.head $ slist $ SL.head inSegSets lastSeg = SL.head $ slist $ SL.last inSegSets - [a] -> INodeSet $ slist [[makeINode [getInsideArc (eToPLine2 lastSeg) (eToPLine2 shortSide), getInsideArc (eToPLine2 firstSeg) (eToPLine2 shortSide)] (Just $ flipL $ outOf a)]] + [a] -> INodeSet $ slist [[makeINode [getInsideArcWithErr (eToPLine2 lastSeg) (eToPLine2 shortSide), getInsideArcWithErr (eToPLine2 firstSeg) (eToPLine2 shortSide)] (Just (flipL $ outOf a, errOfOut a))]] where firstSeg = fromMaybe (error "no first segment?") $ safeHead $ slist longSide lastSeg = SL.last $ slist longSide @@ -189,22 +189,23 @@ averageNodes n1 n2 <> "\nNode2PPoint: " <> show (pPointOf n2) <> "\n" -- | Take a pair of arcables, and return their outOfs, in a sorted order. -sortedPair :: (Arcable a, Arcable b) => a -> b -> [PLine2] -sortedPair n1 n2 = sortedPLines [outOf n1, outOf n2] +sortedPair :: (Arcable a, Arcable b) => a -> b -> [(PLine2, PLine2Err)] +sortedPair n1 n2 = sortedPLinesWithErr [(outOf n1,errOfOut n1), (outOf n2,errOfOut n2)] -- | Get a PLine along the angle bisector of the intersection of the two given line segments, pointing in the 'obtuse' direction. -- Note: we normalize our output lines. -- FIXME: the outer PLine returned by two PLines in the same direction should be two PLines, whch are the same line in both directions. --- FIXME: should return amount of error. -getOutsideArc :: (ProjectivePoint2 a) => a -> NPLine2 -> a -> NPLine2 -> PLine2 +getOutsideArc :: (ProjectivePoint2 a) => a -> NPLine2 -> a -> NPLine2 -> (PLine2, PLine2Err) getOutsideArc ppoint1 npline1 ppoint2 npline2 | npline1 == npline2 = error "need to be able to return two PLines." | noIntersection pline1 pline2 = error $ "no intersection between pline " <> show pline1 <> " and " <> show pline2 <> ".\n" - | l1TowardPoint && l2TowardPoint = flipL $ getInsideArc pline1 (flipL pline2) - | l1TowardPoint = flipL $ getInsideArc pline1 pline2 - | l2TowardPoint = getInsideArc pline1 pline2 - | otherwise = getInsideArc pline1 (flipL pline2) + | l1TowardPoint && l2TowardPoint = (flipL resFlipped, resFlippedErr) + | l1TowardPoint = (flipL resNormal, resNormalErr) + | l2TowardPoint = (resNormal, resNormalErr) + | otherwise = (resFlipped, resFlippedErr) where + (resNormal, resNormalErr) = getInsideArcWithErr pline1 pline2 + (resFlipped, resFlippedErr) = getInsideArcWithErr pline1 (flipL pline2) pline1 = (\(NPLine2 v) -> PLine2 v) npline1 pline2 = (\(NPLine2 v) -> PLine2 v) npline2 intersectionPoint = intersectionOf pline1 pline2 @@ -225,10 +226,9 @@ towardIntersection pp1 pl1 pp2 -- | Make a first generation node. makeENode :: Point2 -> Point2 -> Point2 -> ENode -makeENode p1 p2 p3 = ENode (p1,p2,p3) arc arcErr arcMag +makeENode p1 p2 p3 = ENode (p1,p2,p3) arc arcErr where (arc, arcErr) = getFirstArcWithErr p1 p2 p3 - arcMag = (distance p1 p2 + distance p2 p3) / 2 -- | Make a first generation set of nodes, AKA, a set of arcs that come from the points where line segments meet, toward the inside of the contour. makeENodes :: [LineSeg] -> [ENode] @@ -279,17 +279,17 @@ findENodesInOrder eNodeSet@(ENodeSet (Slist [(_,_)] _)) generations = findENodes Nothing -> [] (Just (ancestorGens,workingGen)) -> concat $ findENodesOfInRecursive <$> nub (insOf (onlyINodeIn workingGen) <> maybePLineOut (onlyINodeIn workingGen)) where - maybePLineOut :: INode -> [PLine2] + maybePLineOut :: INode -> [(PLine2,PLine2Err)] maybePLineOut myINode = if hasArc myINode - then [outOf myINode] + then [(outOf myINode, errOfOut myINode)] else [] -- for a generation with only one inode, retrieve that inode. onlyINodeIn :: [INode] -> INode onlyINodeIn [oneItem] = oneItem onlyINodeIn a = error $ "more than one inode: " <> show a <> "\n" - findENodesOfInRecursive :: PLine2 -> [ENode] + findENodesOfInRecursive :: (PLine2,PLine2Err) -> [ENode] findENodesOfInRecursive myPLine - | isENode myPLine = [myENode] + | isENode (fst myPLine) = [myENode] | otherwise = -- must be an INode. recurse. case unsnoc ancestorGens of Nothing -> [] @@ -297,7 +297,7 @@ findENodesInOrder eNodeSet@(ENodeSet (Slist [(_,_)] _)) generations = findENodes where -- strip the new last generation until it only contains the INode matching myPLine. lastGenWithOnlyMyINode :: [[INode]] - lastGenWithOnlyMyINode = case filter (\a -> outOf a == myPLine) newLastGen of + lastGenWithOnlyMyINode = case filter (\a -> outOf a == fst myPLine) newLastGen of [] -> [] a -> [[first a]] where @@ -305,7 +305,7 @@ findENodesInOrder eNodeSet@(ENodeSet (Slist [(_,_)] _)) generations = findENodes first [] = error "found no INode?" first (v:_) = v where - myENode = fromMaybe (error "could not find ENode?") $ findENodeByOutput eNodeSet myPLine + myENode = fromMaybe (error "could not find ENode?") $ findENodeByOutput eNodeSet (fst myPLine) -- Determine if a PLine matches the output of an ENode. isENode :: PLine2 -> Bool isENode myPLine2 = isJust $ findENodeByOutput eNodeSet myPLine2 @@ -474,7 +474,7 @@ sortINodesByENodes loop inSegSets inGens@(INodeSet rawGenerations) canMergeWith inode1@(INode _ _ _ maybeOut) inode2 = isJust maybeOut && hasIn inode2 (outOf inode1) where hasIn :: INode -> PLine2 -> Bool - hasIn iNode pLine2 = case filter (==pLine2) $ insOf iNode of + hasIn iNode pLine2 = case filter (\a -> fst a == pLine2) $ insOf iNode of [] -> False [_] -> True (_:_) -> error "filter passed too many options." @@ -495,18 +495,18 @@ sortINodesByENodes loop inSegSets inGens@(INodeSet rawGenerations) newINode1 = makeINode (withoutConnectingPLine $ insOf iNode2) (Just newConnectingPLine) -- like iNode1, but with our flipped connecting line in, and iNode2's original out. newINode2 = makeINode ([newConnectingPLine] <> insOf iNode1) maybeOut2 - newConnectingPLine = flipL oldConnectingPLine + newConnectingPLine = (flipL $ fst oldConnectingPLine, snd oldConnectingPLine) oldConnectingPLine = case iNodeInsOf iNode2 of [] -> error "could not find old connecting PLine." [v] -> v (_:_) -> error "filter passed too many connecting PLines." - iNodeInsOf myINode = filter (isNothing . findENodeByOutput (eNodeSetOf $ slist initialENodes)) $ insOf myINode - withoutConnectingPLine = filter (/= oldConnectingPLine) + iNodeInsOf myINode = filter (\a -> isNothing . findENodeByOutput (eNodeSetOf $ slist initialENodes) $ fst a) $ insOf myINode + withoutConnectingPLine = filter (\a -> a /= oldConnectingPLine) -- Determine if the given INode has a PLine that points to an ENode. - hasENode iNode = any (isJust . findENodeByOutput (eNodeSetOf $ slist initialENodes)) $ insOf iNode + hasENode iNode = any (isJust . findENodeByOutput (eNodeSetOf $ slist initialENodes)) $ fst <$> insOf iNode -- Determine if the given INode has a PLine that points to another INode. - hasINode iNode = any (isNothing . findENodeByOutput (eNodeSetOf $ slist initialENodes)) $ insOf iNode + hasINode iNode = any (isNothing . findENodeByOutput (eNodeSetOf $ slist initialENodes)) $ fst <$> insOf iNode -- Construct an ENodeSet eNodeSetOf :: Slist ENode -> ENodeSet @@ -569,14 +569,14 @@ sortINodesByENodes loop inSegSets inGens@(INodeSet rawGenerations) -- | add together a child and it's parent. addINodeToParent :: INode -> INode -> INode addINodeToParent (INode _ _ _ Nothing) _ = error "cannot merge a child inode with no output!" - addINodeToParent iNode1@(INode _ _ _ (Just out1)) iNode2@(INode _ _ _ out2) = orderInsByENodes $ makeINode (insOf iNode1 <> withoutPLine out1 (insOf iNode2)) out2 + addINodeToParent iNode1@(INode _ _ _ (Just out1)) iNode2@(INode _ _ _ out2) = orderInsByENodes $ makeINode (insOf iNode1 <> withoutPLine (fst out1) (insOf iNode2)) out2 where - withoutPLine :: PLine2 -> [PLine2] -> [PLine2] - withoutPLine myPLine = filter (/= myPLine) + withoutPLine :: PLine2 -> [(PLine2,PLine2Err)] -> [(PLine2,PLine2Err)] + withoutPLine myPLine = filter (\a -> fst a /= myPLine) -- Order the input nodes of an INode. orderInsByENodes :: INode -> INode - orderInsByENodes inode@(INode _ _ _ out) = makeINode (indexPLinesTo firstPLine $ sortedPLines $ indexPLinesTo firstPLine $ insOf inode) out + orderInsByENodes inode@(INode _ _ _ out) = makeINode (indexPLinesTo firstPLine $ sortedPLinesWithErr $ indexPLinesTo firstPLine $ insOf inode) out -- | Apply a recursive algorithm to obtain a raw INode set. -- FIXME: does not handle more than two point intersections of arcs properly. @@ -599,7 +599,7 @@ skeletonOfNodes connectedLoop inSegSets iNodes = else -- Construct an INode with two identical inputs, and return it. -- FIXME: shouldn't we be able to return an empty set, instead? - Right $ INodeSet $ one [INode (outOf eNode) (outOf eNode) (slist []) Nothing] + Right $ INodeSet $ one [INode (outOf eNode, errOfOut eNode) (outOf eNode, errOfOut eNode) (slist []) Nothing] [iNode] -> handleTwoNodes eNode iNode (_:_) -> handleThreeOrMoreNodes [eNode1,eNode2] -> case iNodes of @@ -617,21 +617,23 @@ skeletonOfNodes connectedLoop inSegSets iNodes = | isCollinear (outOf node1) (outOf node2) = Left $ PartialNodes (INodeSet $ one iNodes) $ "cannot handle collinear nodes:\n" <> show node1 <> "\n" <> show node2 <> "\n" | nodesAreAntiCollinear node1 node2 && contourLooped = Right $ INodeSet $ one [makeLastPair node1 node2] | contourLooped = -- this is a complete loop, so this last INode will be re-written in sortINodesByENodes anyways. - Right $ INodeSet $ one [makeINode (sortedPLines [outOf node1,outOf node2]) Nothing] + Right $ INodeSet $ one [makeINode (sortedPLinesWithErr [outAndErrOf node1,outAndErrOf node2]) Nothing] | intersectsInPoint node1 node2 = Right $ INodeSet $ one [averageNodes node1 node2] | otherwise = errorLen2 where errorLen2 = Left $ PartialNodes (INodeSet $ one iNodes) $ "NOMATCH - length 2?\n" <> show node1 <> "\n" <> show node2 <> "\n" <> show contourLooped <> "\n" <> show eNodes <> "\n" <> show iNodes <> "\n" + outAndErrOf a = (outOf a, errOfOut a) -- Handle the the case of 3 or more nodes. handleThreeOrMoreNodes - | endsAtSamePoint && contourLooped = Right $ INodeSet $ one [makeINode (sortedPLines $ (outOf <$> eNodes) <> (outOf <$> iNodes)) Nothing] + | endsAtSamePoint && contourLooped = Right $ INodeSet $ one [makeINode (sortedPLinesWithErr $ (outAndErrOf <$> eNodes) <> (outAndErrOf <$> iNodes)) Nothing] -- FIXME: this can happen for non-loops. which means this Nothing is wrong. it should be the result of the intersection tree from the first and last node in the segment. - | endsAtSamePoint && not contourLooped = error $ show $ INodeSet $ one [makeINode (sortedPLines $ (outOf <$> eNodes) <> (outOf <$> iNodes)) Nothing] + | endsAtSamePoint && not contourLooped = error $ show $ INodeSet $ one [makeINode (sortedPLinesWithErr $ (outAndErrOf <$> eNodes) <> (outAndErrOf <$> iNodes)) Nothing] | hasShortestNeighboringPair = Right $ INodeSet $ averageOfShortestPairs `cons` inodesOf (errorIfLeft (skeletonOfNodes remainingLoop remainingLineSegs (remainingINodes <> averageOfShortestPairs))) | otherwise = errorLen3 where inodesOf (INodeSet set) = set + outAndErrOf a = (outOf a, errOfOut a) errorLen3 = error $ "shortestPairDistance: " <> show shortestPairDistance <> "\n" <> "ePairDistance: " <> show shortestEPairDistance <> "\n" diff --git a/Graphics/Slicer/Math/Skeleton/Definitions.hs b/Graphics/Slicer/Math/Skeleton/Definitions.hs index a625a94a3..045a8cb88 100644 --- a/Graphics/Slicer/Math/Skeleton/Definitions.hs +++ b/Graphics/Slicer/Math/Skeleton/Definitions.hs @@ -29,7 +29,7 @@ -- | Common types and functions used in the code responsible for generating straight skeletons. -module Graphics.Slicer.Math.Skeleton.Definitions (RemainingContour(RemainingContour), StraightSkeleton(StraightSkeleton), Spine(Spine), ENode(ENode), INode(INode), ENodeSet(ENodeSet), INodeSet(INodeSet), NodeTree(NodeTree), ancestorsOf, Motorcycle(Motorcycle), Cell(Cell), CellDivide(CellDivide), DividingMotorcycles(DividingMotorcycles), MotorcycleIntersection(WithENode, WithMotorcycle, WithLineSeg), concavePLines, getFirstLineSeg, getLastLineSeg, hasNoINodes, getPairs, linePairs, finalPLine, finalINodeOf, finalOutOf, makeINode, sortedPLines, indexPLinesTo, insOf, lastINodeOf, firstInOf, isLoop, lastInOf) where +module Graphics.Slicer.Math.Skeleton.Definitions (RemainingContour(RemainingContour), StraightSkeleton(StraightSkeleton), Spine(Spine), ENode(ENode), INode(INode), ENodeSet(ENodeSet), INodeSet(INodeSet), NodeTree(NodeTree), ancestorsOf, Motorcycle(Motorcycle), Cell(Cell), CellDivide(CellDivide), DividingMotorcycles(DividingMotorcycles), MotorcycleIntersection(WithENode, WithMotorcycle, WithLineSeg), concavePLines, getFirstLineSeg, getLastLineSeg, hasNoINodes, getPairs, linePairs, finalPLine, finalINodeOf, finalOutOf, makeINode, sortedPLines, sortedPLinesWithErr, indexPLinesTo, insOf, lastINodeOf, firstInOf, isLoop, lastInOf) where import Prelude (Eq, Show, Bool(True, False), Ordering(LT,GT), otherwise, ($), (<$>), (==), (/=), error, (>), (&&), any, fst, and, (||), (<>), show, (<), (*), realToFrac) @@ -51,38 +51,34 @@ import Slist as SL (last, head, init) import Slist.Type (Slist(Slist)) -import Graphics.Implicit.Definitions (ℝ) - - -import Graphics.Slicer.Math.PGA (plinesIntersectIn, PIntersection(IntersectsIn), flipL, PLine2(PLine2), pLineIsLeft, distance2PP, Pointable(canPoint, pPointOf, ePointOf), Arcable(hasArc, outOf, ulpOfOut, outUlpMag), CPPoint2(CPPoint2), PPoint2(PPoint2), canonicalize, eToPLine2WithErr, eToPPoint2, pToEP, vecOfL) - import Graphics.Slicer.Math.Definitions (Contour, LineSeg(LineSeg), Point2, mapWithFollower, fudgeFactor, startPoint, distance, endPoint, lineSegsOfContour, makeLineSeg) import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum), addVecPair) +import Graphics.Slicer.Math.PGA (plinesIntersectIn, PIntersection(IntersectsIn), flipL, PLine2(PLine2), PLine2Err, pLineIsLeft, distance2PP, Pointable(canPoint, pPointOf, ePointOf), Arcable(errOfOut, hasArc, outOf), CPPoint2(CPPoint2), PPoint2(PPoint2), canonicalize, eToPLine2WithErr, eToPPoint2, pToEP, vecOfL) + -- | A point where two lines segments that are part of a contour intersect, emmiting an arc toward the interior of a contour. -- FIXME: a source should have a different UlpSum for it's point and it's output. -- FIXME: provide our own Eq instance, cause floats suck? :) -data ENode = ENode { _inPoints :: !(Point2, Point2, Point2), _arcOut :: !PLine2, _arcULP :: UlpSum, _arcUlpMag :: ℝ} +data ENode = ENode { _inPoints :: !(Point2, Point2, Point2), _arcOut :: !PLine2, _arcOutErr :: !PLine2Err} deriving Eq deriving stock Show instance Arcable ENode where -- an ENode always has an arc. hasArc _ = True - outOf (ENode _ outArc _ _) = outArc - ulpOfOut (ENode _ _ outUlp _) = outUlp - outUlpMag (ENode _ _ _ ulpMag) = ulpMag + outOf (ENode _ outArc _) = outArc + errOfOut (ENode _ _ outErr) = outErr instance Pointable ENode where -- an ENode always contains a point. canPoint _ = True pPointOf a = (\(CPPoint2 v) -> PPoint2 v) $ eToPPoint2 $ ePointOf a - ePointOf (ENode (_,centerPoint,_) _ _ _) = centerPoint + ePointOf (ENode (_,centerPoint,_) _ _) = centerPoint -- | A point in our straight skeleton where two arcs intersect, resulting in the creation of another arc. -- FIXME: a source should have a different UlpSum for it's point and it's output. -data INode = INode { _firstInArc :: !PLine2, _secondInArc :: !PLine2, _moreInArcs :: !(Slist PLine2), _outArc :: !(Maybe PLine2) } +data INode = INode { _firstInArc :: !(PLine2, PLine2Err), _secondInArc :: !(PLine2, PLine2Err), _moreInArcs :: !(Slist (PLine2, PLine2Err)), _outArc :: !(Maybe (PLine2, PLine2Err))} deriving Eq deriving stock Show @@ -90,19 +86,20 @@ instance Arcable INode where -- an INode might just end here. hasArc (INode _ _ _ outArc) = isJust outArc outOf (INode _ _ _ outArc) = case outArc of - (Just rawOutArc) -> rawOutArc + (Just (rawOutArc,_)) -> rawOutArc + Nothing -> error "tried to get an outArc that has no output arc." + errOfOut (INode _ _ _ outArc) = case outArc of + (Just (_,rawOutArcErr)) -> rawOutArcErr Nothing -> error "tried to get an outArc that has no output arc." - ulpOfOut _ = error "tried to get the ULP of the out of an INode." - outUlpMag _ = error "tried to get the magnitude of the ULP of the out of an INode." instance Pointable INode where -- an INode does not contain a point, we have to attempt to resolve one instead. canPoint iNode@(INode firstPLine secondPLine morePLines _) = len allPLines > 1 && hasIntersectingPairs allPLines where allPLines = if hasArc iNode - then cons (outOf iNode) $ cons firstPLine $ cons secondPLine morePLines + then cons (outOf iNode, errOfOut iNode) $ cons firstPLine $ cons secondPLine morePLines else cons firstPLine $ cons secondPLine morePLines - hasIntersectingPairs (Slist pLines _) = any (\(pl1, pl2) -> saneIntersect $ plinesIntersectIn pl1 pl2) $ getPairs pLines + hasIntersectingPairs (Slist pLines _) = any (\(pl1, pl2) -> saneIntersect $ plinesIntersectIn (fst pl1) (fst pl2)) $ getPairs pLines where saneIntersect (IntersectsIn _ _) = True saneIntersect _ = False @@ -127,16 +124,16 @@ instance Pointable INode where where (res, UlpSum err) = distance2PP (fst $ canonicalize a) (fst $ canonicalize b) allPLines = if hasArc iNode - then slist $ nub $ outOf iNode : firstPLine : secondPLine : rawPLines + then slist $ nub $ (outOf iNode, errOfOut iNode) : firstPLine : secondPLine : rawPLines else slist $ nub $ firstPLine : secondPLine : rawPLines - intersectionsOfPairs (Slist pLines _) = catMaybes $ (\(pl1, pl2) -> saneIntersect $ plinesIntersectIn pl1 pl2) <$> getPairs pLines + intersectionsOfPairs (Slist pLines _) = catMaybes $ (\(pl1, pl2) -> saneIntersect $ plinesIntersectIn (fst pl1) (fst pl2)) <$> getPairs pLines where saneIntersect (IntersectsIn a _) = Just $ (\(CPPoint2 v) -> PPoint2 v) a saneIntersect _ = Nothing ePointOf a = fst $ pToEP $ pPointOf a -- Produce a list of the inputs to a given INode. -insOf :: INode -> [PLine2] +insOf :: INode -> [(PLine2, PLine2Err)] insOf (INode firstIn secondIn (Slist moreIns _) _) = firstIn:secondIn:moreIns lastINodeOf :: INodeSet -> INode @@ -147,22 +144,21 @@ lastINodeOf (INodeSet gens) = case unsnoc (SL.last gens) of -- | A Motorcycle. a PLine eminating from an intersection between two line segments toward the interior or the exterior of a contour. -- Motorcycles are emitted from convex (reflex) virtexes of the encircling contour, and concave virtexes of any holes. -- FIXME: Note that a new motorcycle may be created in the case of degenerate polygons... with it's inSegs being two other motorcycles. -data Motorcycle = Motorcycle { _inCSegs :: !(LineSeg, LineSeg), _outPline :: !PLine2, outPlineULP :: UlpSum, outPlineMagnitude :: ℝ } +data Motorcycle = Motorcycle { _inCSegs :: !(LineSeg, LineSeg), _outPline :: !PLine2, _outPlineErr :: PLine2Err} deriving Eq deriving stock Show instance Arcable Motorcycle where -- A Motorcycle always has an arc, which is it's path. hasArc _ = True - outOf (Motorcycle _ outArc _ _) = outArc - ulpOfOut (Motorcycle _ _ outUlp _) = outUlp - outUlpMag (Motorcycle _ _ _ outMag) = outMag + outOf (Motorcycle _ outArc _) = outArc + errOfOut (Motorcycle _ _ outErr) = outErr instance Pointable Motorcycle where -- A motorcycle always contains a point. canPoint _ = True pPointOf a = (\(CPPoint2 v) -> PPoint2 v) $ eToPPoint2 $ ePointOf a - ePointOf (Motorcycle (_, LineSeg point _) _ _ _) = point + ePointOf (Motorcycle (_, LineSeg point _) _ _) = point -- | The motorcycles that are involved in dividing two cells. data DividingMotorcycles = DividingMotorcycles { firstMotorcycle :: !Motorcycle, moreMotorcycles :: !(Slist Motorcycle) } @@ -243,11 +239,11 @@ isLoop inSegSets = endPoint lastSeg == startPoint firstSeg || distance (endPoint -- | get the first line segment of an ENode. getFirstLineSeg :: ENode -> LineSeg -getFirstLineSeg (ENode (p1,p2,_) _ _ _) = makeLineSeg p1 p2 +getFirstLineSeg (ENode (p1,p2,_) _ _) = makeLineSeg p1 p2 -- | get the second line segment of an ENode. getLastLineSeg :: ENode -> LineSeg -getLastLineSeg (ENode (_,p2,p3) _ _ _) = makeLineSeg p2 p3 +getLastLineSeg (ENode (_,p2,p3) _ _) = makeLineSeg p2 p3 -- | Get pairs of lines from the contour, including one pair that is the last line paired with the first. linePairs :: Contour -> [(LineSeg, LineSeg)] @@ -262,7 +258,7 @@ linePairs contour = rotateRight $ mapWithNeighbors (\a b c -> (handleLineSegErro -} -- | A smart constructor for INodes. -makeINode :: [PLine2] -> Maybe PLine2 -> INode +makeINode :: [(PLine2, PLine2Err)] -> Maybe (PLine2, PLine2Err) -> INode makeINode pLines maybeOut = case pLines of [] -> error "tried to construct a broken INode" [onePLine] -> error $ "tried to construct a broken INode from one PLine2: " <> show onePLine <> "\n" @@ -270,16 +266,16 @@ makeINode pLines maybeOut = case pLines of (first:second:more) -> INode first second (slist more) maybeOut -- | Get the output of the given nodetree. fails if the nodetree has no output. -finalPLine :: NodeTree -> PLine2 +finalPLine :: NodeTree -> (PLine2, PLine2Err) finalPLine (NodeTree (ENodeSet (Slist [(firstENode,moreENodes)] _)) iNodeSet) | hasNoINodes iNodeSet = if len moreENodes == 0 - then outOf firstENode + then (outOf firstENode, errOfOut firstENode) else error "cannot have final PLine of NodeTree with more than one ENode, and no generations!\n" - | hasArc (finalINodeOf iNodeSet) = outOf $ finalINodeOf iNodeSet + | hasArc (finalINodeOf iNodeSet) = (outOf $ finalINodeOf iNodeSet, errOfOut $ finalINodeOf iNodeSet) | otherwise = error "has inodes, has no out, has enodes?" finalPLine (NodeTree _ iNodeSet) | hasNoINodes iNodeSet = error "cannot have final PLine of a NodeTree that is completely empty!" - | hasArc (finalINodeOf iNodeSet) = outOf $ finalINodeOf iNodeSet + | hasArc (finalINodeOf iNodeSet) = (outOf $ finalINodeOf iNodeSet, errOfOut $ finalINodeOf iNodeSet) | otherwise = error "has inodes, has no out, has no enodes?" -- | get the last output PLine of a NodeTree, if there is one. otherwise, Nothing. @@ -332,20 +328,24 @@ hasNoINodes iNodeSet = case iNodeSet of sortedPLines :: [PLine2] -> [PLine2] sortedPLines = sortBy (\n1 n2 -> if (n1 `pLineIsLeft` n2) == Just True then LT else GT) +-- | Sort a set of PLines. yes, this is 'backwards', to match the counterclockwise order of contours. +sortedPLinesWithErr :: [(PLine2, PLine2Err)] -> [(PLine2, PLine2Err)] +sortedPLinesWithErr = sortBy (\n1 n2 -> if (fst n1 `pLineIsLeft` fst n2) == Just True then LT else GT) + -- | take a sorted list of PLines, and make sure the list starts with the pline closest to (but not left of) the given PLine. -indexPLinesTo :: PLine2 -> [PLine2] -> [PLine2] +indexPLinesTo :: PLine2 -> [(PLine2, PLine2Err)] -> [(PLine2, PLine2Err)] indexPLinesTo firstPLine pLines = pLinesBeforeIndex firstPLine pLines <> pLinesAfterIndex firstPLine pLines where - pLinesBeforeIndex myFirstPLine = filter (\a -> myFirstPLine `pLineIsLeft` a /= Just False) - pLinesAfterIndex myFirstPLine = filter (\a -> myFirstPLine `pLineIsLeft` a == Just False) + pLinesBeforeIndex myFirstPLine = filter (\a -> myFirstPLine `pLineIsLeft` (fst a) /= Just False) + pLinesAfterIndex myFirstPLine = filter (\a -> myFirstPLine `pLineIsLeft` (fst a) == Just False) -- | find the last PLine of an INode. lastInOf :: INode -> PLine2 lastInOf (INode _ secondPLine morePLines _) - | len morePLines == 0 = secondPLine - | otherwise = SL.last morePLines + | len morePLines == 0 = fst $ secondPLine + | otherwise = fst $ SL.last morePLines -- | find the first PLine of an INode. firstInOf :: INode -> PLine2 -firstInOf (INode a _ _ _) = a +firstInOf (INode a _ _ _) = fst a diff --git a/Graphics/Slicer/Math/Skeleton/Face.hs b/Graphics/Slicer/Math/Skeleton/Face.hs index f2dc7b8db..1b7682509 100644 --- a/Graphics/Slicer/Math/Skeleton/Face.hs +++ b/Graphics/Slicer/Math/Skeleton/Face.hs @@ -22,7 +22,7 @@ -- | This file contains code for creating a series of Faces, covering a straight skeleton. module Graphics.Slicer.Math.Skeleton.Face (Face(Face), orderedFacesOf, facesOf) where -import Prelude ((==), otherwise, (<$>), ($), length, error, (<>), show, Eq, Show, (<>), Bool(True), null, not, and, snd, (&&), (>), (/=)) +import Prelude ((==), fst, otherwise, (<$>), ($), length, error, (<>), show, Eq, Show, (<>), Bool(True), null, not, and, snd, (&&), (>), (/=)) import Data.List (uncons) @@ -42,11 +42,11 @@ import Graphics.Slicer.Math.Definitions (LineSeg, distance, fudgeFactor) import Graphics.Slicer.Math.Intersections (isCollinear) -import Graphics.Slicer.Math.Skeleton.Definitions (StraightSkeleton(StraightSkeleton), ENode, INode(INode), ENodeSet(ENodeSet), INodeSet(INodeSet), NodeTree(NodeTree), getFirstLineSeg, getLastLineSeg, finalINodeOf, finalOutOf, ancestorsOf, firstInOf, lastInOf, sortedPLines) +import Graphics.Slicer.Math.Skeleton.Definitions (StraightSkeleton(StraightSkeleton), ENode, INode(INode), ENodeSet(ENodeSet), INodeSet(INodeSet), NodeTree(NodeTree), getFirstLineSeg, getLastLineSeg, finalINodeOf, finalOutOf, ancestorsOf, firstInOf, lastInOf, sortedPLinesWithErr) import Graphics.Slicer.Math.Skeleton.NodeTrees (lastSegOf, findENodeByOutput, findINodeByOutput, firstSegOf, lastENodeOf, firstENodeOf, pathFirst, pathLast) -import Graphics.Slicer.Math.PGA (PLine2, Arcable(hasArc, outOf), ePointOf) +import Graphics.Slicer.Math.PGA (PLine2, PLine2Err, Arcable(hasArc, outOf), ePointOf) -------------------------------------------------------------------- -------------------------- Face Placement -------------------------- @@ -130,8 +130,8 @@ facesOfNodeTree nodeTree@(NodeTree myENodes iNodeSet@(INodeSet generations)) allInsAreENodes :: INode -> Bool allInsAreENodes myTarget = and $ isJust <$> (findENodeByOutput eNodes <$> inArcsOf myTarget) where - -- Make a list of an INode's input arcs. - inArcsOf (INode firstArc secondArc (Slist rawMoreArcs _) _) = firstArc : secondArc : rawMoreArcs + -- Make a list of the PLines of an INode's input arcs. + inArcsOf (INode firstArc secondArc (Slist rawMoreArcs _) _) = fst <$> firstArc : secondArc : rawMoreArcs -- | wrap getFaces so the first line segment of the input set is the first face given. rotateFaces :: INodeSet -> ENodeSet -> INode -> [Face] @@ -147,25 +147,25 @@ rotateFaces iNodeSet eNodes iNode = rTail <> [rHead] getFaces :: INodeSet -> ENodeSet -> INode -> [Face] getFaces iNodeSet@(INodeSet myGenerations) eNodes iNode@(INode _ _ _ maybeOut) = findFacesRecurse iNode allPLines where - allPLines = sortedPLines $ insOf iNode <> out + allPLines = sortedPLinesWithErr $ insOf iNode <> out where insOf (INode pLine1 pLine2 (Slist morePLines _) _) = pLine1 : pLine2 : morePLines out = case maybeOut of Nothing -> [] (Just o) -> [o] - firstPLine = head $ slist allPLines + firstPLine = fst $ head $ slist allPLines -- responsible for placing faces under the first pline given (if applicable), and between that pline, and the following pline. then.. recurse! - findFacesRecurse :: INode -> [PLine2] -> [Face] + findFacesRecurse :: INode -> [(PLine2, PLine2Err)] -> [Face] findFacesRecurse myINode pLines = case pLines of [] -> error "we should never get here." -- Just one PLine? assume we're the last one. do not place a face, but do place faces under the PLine. - [onePLine] -> placeFacesBeneath onePLine firstPLine - <> placeFaceBetween onePLine firstPLine + [(onePLine,_)] -> placeFacesBeneath onePLine firstPLine + <> placeFaceBetween onePLine firstPLine -- More than one PLine? place faces under onePLine, place a face between onePLine and anotherPLine, and recurse! - (onePLine : anotherPLine : myMorePLines) -> placeFacesBeneath onePLine anotherPLine - <> placeFaceBetween onePLine anotherPLine - <> findFacesRecurse myINode (anotherPLine:myMorePLines) + ((onePLine,_) : anotherPLine : myMorePLines) -> placeFacesBeneath onePLine (fst anotherPLine) + <> placeFaceBetween onePLine (fst anotherPLine) + <> findFacesRecurse myINode (anotherPLine:myMorePLines) where -- zero or one face, not a real list. placeFaceBetween :: PLine2 -> PLine2 -> [Face] diff --git a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs index f6e2f3cb7..4ed3c773c 100644 --- a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs +++ b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs @@ -26,7 +26,7 @@ module Graphics.Slicer.Math.Skeleton.Motorcycles (CollisionType(HeadOn), CrashTree(CrashTree), motorcycleToENode, Collision(Collision), motorcycleIntersectsAt, intersectionSameSide, crashMotorcycles, collisionResult, convexMotorcycles, lastCrashType, motorcyclesAreAntiCollinear, motorcyclesInDivision, motorcycleMightIntersectWith, motorcycleDivisor) where -import Prelude (Bool(True, False), Either(Left,Right), Eq((==)), Show(show), Ordering (EQ, GT, LT), (&&), (<>), ($), (<$>), (<), (>), (+), compare, error, notElem, null, otherwise, realToFrac, zip) +import Prelude (Bool(True, False), Either(Left,Right), Eq((==)), Show(show), Ordering (EQ, GT, LT), (&&), (<>), ($), (<$>), (<), (>), compare, error, mempty, notElem, null, otherwise, realToFrac, zip) import Prelude as PL (init, last) @@ -44,17 +44,17 @@ import Graphics.Slicer.Definitions (ℝ) import Graphics.Slicer.Math.Contour (pointsOfContour) -import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, distance, mapWithNeighbors, startPoint, endPoint, makeLineSeg) +import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, mapWithNeighbors, startPoint, endPoint, makeLineSeg) import Graphics.Slicer.Math.Intersections (getMotorcycleSegSetIntersections, getMotorcycleContourIntersections, intersectionOf, isAntiCollinear, noIntersection) import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, pPointBetweenPPoints, distanceBetweenPPoints, eToCPPoint2, eToPLine2, normalizePLine2, pLineFromEndpoints, pToEPoint2, translatePLine2) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2(NPLine2), PLine2(PLine2), PPoint2, Arcable(outOf), Pointable(canPoint, ePointOf, pPointOf), eToPL, flipL, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, PIntersection(IntersectsIn,PAntiCollinear), plinesIntersectIn, angleBetween2PL, outputIntersectsLineSeg, ulpOfPLine2, ulpOfLineSeg) +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), PPoint2, Arcable(outOf), Pointable(canPoint, ePointOf, pPointOf), eToPL, flipL, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, PIntersection(IntersectsIn,PAntiCollinear), plinesIntersectIn, angleBetween2PL, outputIntersectsLineSeg) import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle), ENode(ENode), getFirstLineSeg, linePairs, CellDivide(CellDivide), DividingMotorcycles(DividingMotorcycles), MotorcycleIntersection(WithLineSeg, WithENode, WithMotorcycle)) -import Graphics.Slicer.Math.GeometricAlgebra (addVecPair, UlpSum(UlpSum)) +import Graphics.Slicer.Math.GeometricAlgebra (addVecPairWithErr, UlpSum(UlpSum)) -- | The collision of two motorcycles. one lives, and one doesn't, unless it's a head on collision, in which case both die, and there is no survivor. data Collision = Collision { _inMotorcycles :: !(Motorcycle, Motorcycle, Slist Motorcycle), _survivor :: !(Maybe Motorcycle), collisionResult :: !CollisionType } @@ -75,7 +75,7 @@ data CrashTree = CrashTree { _motorcycles :: !(Slist Motorcycle), _survivors :: -- | convert a Motorcycle to an ENode motorcycleToENode :: Motorcycle -> ENode -motorcycleToENode (Motorcycle (seg1,seg2) mcpath mcUlp mcMag) = ENode (startPoint seg1, startPoint seg2, endPoint seg2) mcpath mcUlp mcMag +motorcycleToENode (Motorcycle (seg1,seg2) mcpath mcErr) = ENode (startPoint seg1, startPoint seg2, endPoint seg2) mcpath mcErr -- | Find the point where the propogation from a motorcycle equals the propogation of what it impacts, taking into account the weight of a motorcycle, and the weight of what it impacts. motorcycleDivisor :: Motorcycle -> MotorcycleIntersection -> PPoint2 @@ -83,7 +83,7 @@ motorcycleDivisor motorcycle target = pPointBetweenPPoints (canonicalizePPoint2 where pointOfTarget :: CPPoint2 pointOfTarget = case target of - (WithLineSeg lineSeg) -> case outputIntersectsLineSeg motorcycle (lineSeg, ulpOfLineSeg lineSeg) of + (WithLineSeg lineSeg) -> case outputIntersectsLineSeg motorcycle lineSeg of (Right (IntersectsIn p _)) -> p v -> error $ "impossible!\n" <> show v <> "\n" <> show lineSeg <> "\n" <> show motorcycle <> "\n" <> show target <> "\n" (WithENode eNode) -> canonicalizePPoint2 $ pPointOf eNode @@ -94,7 +94,7 @@ motorcycleDivisor motorcycle target = pPointBetweenPPoints (canonicalizePPoint2 (WithENode eNode) -> distanceBetweenPPoints (canonicalizePPoint2 $ pPointOf eNode) (justIntersectsIn $ plinesIntersectIn (translatePLine2 (eToPLine2 $ getFirstLineSeg eNode) 1) (outOf eNode)) (WithMotorcycle motorcycle2) -> mSpeedOf motorcycle2 mSpeedOf :: Motorcycle -> ℝ - mSpeedOf myMotorcycle@(Motorcycle (seg1,_) _ _ _) = distanceBetweenPPoints (canonicalizePPoint2 $ pPointOf myMotorcycle) (justIntersectsIn $ plinesIntersectIn (translatePLine2 (eToPLine2 seg1) 1) (outOf myMotorcycle)) + mSpeedOf myMotorcycle@(Motorcycle (seg1,_) _ _) = distanceBetweenPPoints (canonicalizePPoint2 $ pPointOf myMotorcycle) (justIntersectsIn $ plinesIntersectIn (translatePLine2 (eToPLine2 seg1) 1) (outOf myMotorcycle)) justIntersectsIn :: PIntersection -> CPPoint2 justIntersectsIn res = case res of (IntersectsIn p _) -> p @@ -140,7 +140,7 @@ crashMotorcycles contour holes -- Crash just two motorcycles. Returns Nothing when the motorcycles can't collide. crashOf :: Motorcycle -> Motorcycle -> Maybe Collision - crashOf mot1 mot2@(Motorcycle (inSeg2, _) _ _ _) + crashOf mot1 mot2@(Motorcycle (inSeg2, _) _ _) -- If we have a clear path between mot1 and the origin of mot2 | isAntiCollinear (outOf mot1) (outOf mot2) && motorcycleIntersectsAt contour mot1 == (inSeg2, Left $ endPoint inSeg2) = Just $ Collision (mot1,mot2, slist []) Nothing HeadOn | noIntersection (outOf mot1) (outOf mot2) = Nothing @@ -166,36 +166,37 @@ convexMotorcycles :: Contour -> [Motorcycle] convexMotorcycles contour = catMaybes $ onlyMotorcycles <$> zip (rotateLeft $ linePairs contour) (mapWithNeighbors convexPLines $ pointsOfContour contour) where rotateLeft a = PL.last a : PL.init a - onlyMotorcycles :: ((LineSeg, LineSeg), Maybe (PLine2, UlpSum, ℝ)) -> Maybe Motorcycle + onlyMotorcycles :: ((LineSeg, LineSeg), Maybe (PLine2, PLine2Err)) -> Maybe Motorcycle onlyMotorcycles ((seg1, seg2), maybePLine) = case maybePLine of - (Just (pLine, pLineUlp, pLineMag)) -> Just $ Motorcycle (seg1, seg2) pLine pLineUlp pLineMag + (Just (pLine, pLineErr)) -> Just $ Motorcycle (seg1, seg2) pLine pLineErr Nothing -> Nothing -- | Examine two line segments that are part of a Contour, and determine if they are convex from the perspective of the interior of the Contour. if they are, construct a PLine2 bisecting them, pointing toward the interior. -- Note that we know that the inside is to the left of the first line given, and that the first line points toward the intersection. - convexPLines :: Point2 -> Point2 -> Point2 -> Maybe (PLine2, UlpSum, ℝ) + convexPLines :: Point2 -> Point2 -> Point2 -> Maybe (PLine2, PLine2Err) convexPLines p1 p2 p3 | Just True == pLineIsLeft pl1 pl2 = Nothing - | otherwise = Just (resPLine, ulpOfPLine2 resPLine, distance p1 p2 + distance p2 p3) + | otherwise = Just resPLine where resPLine = motorcycleFromPoints p1 p2 p3 pl1 = pLineFromEndpoints p1 p2 pl2 = pLineFromEndpoints p2 p3 -- | generate the un-normalized PLine2 of a motorcycle created by the three points given. -motorcycleFromPoints :: Point2 -> Point2 -> Point2 -> PLine2 +motorcycleFromPoints :: Point2 -> Point2 -> Point2 -> (PLine2, PLine2Err) motorcycleFromPoints p1 p2 p3 = getOutsideArc (pLineFromEndpoints p1 p2) (pLineFromEndpoints p2 p3) where -- | Get a PLine along the angle bisector of the intersection of the two given line segments, pointing in the 'obtuse' direction. -- Note that we do not normalize our output, or require normalized inputs, but we normalize our values before adding them. - getOutsideArc :: PLine2 -> PLine2 -> PLine2 + getOutsideArc :: PLine2 -> PLine2 -> (PLine2, PLine2Err) getOutsideArc pline1 pline2 | noIntersection pline1 pline2 = error $ "not collinear, but not intersecting?\n" <> "PLine1: " <> show pline1 <> "\n" <> "PLine2: " <> show pline2 <> "\n" <> "result: " <> show (plinesIntersectIn pline1 pline2) <> "\n" - | otherwise = flipL $ PLine2 $ addVecPair flippedNPV1 npv2 + | otherwise = (flipL $ PLine2 newPLine, PLine2Err newPLineErrVals mempty mempty mempty mempty mempty) where + (newPLine, newPLineErrVals) = addVecPairWithErr flippedNPV1 npv2 (PLine2 flippedNPV1) = flipL $ (\(NPLine2 a) -> PLine2 a) $ normalizePLine2 pline1 (NPLine2 npv2) = normalizePLine2 pline2 @@ -309,7 +310,7 @@ motorcycleIntersectsAt contour motorcycle = case intersections of -- | Determine if a node is on one side of a motorcycle, or the other. -- Assumes the starting point of the second line segment is a point on the path. intersectionSameSide :: (Pointable a, Show a) => PPoint2 -> a -> Motorcycle -> Maybe Bool -intersectionSameSide pointOnSide node (Motorcycle _ path _ _) +intersectionSameSide pointOnSide node (Motorcycle _ path _) | canPoint node && pPointOf node == pointOnSide = Just True | canPoint node = pPointsOnSameSideOfPLine (pPointOf node) pointOnSide path | otherwise = error $ "cannot resolve provided item to a point: " <> show node <> "\n" diff --git a/Graphics/Slicer/Math/Skeleton/NodeTrees.hs b/Graphics/Slicer/Math/Skeleton/NodeTrees.hs index 8cac1a028..8471bff30 100644 --- a/Graphics/Slicer/Math/Skeleton/NodeTrees.hs +++ b/Graphics/Slicer/Math/Skeleton/NodeTrees.hs @@ -21,7 +21,7 @@ module Graphics.Slicer.Math.Skeleton.NodeTrees (firstENodeOf, firstSegOf, lastEN import Prelude (Bool(True,False), Eq, Show, (==), otherwise, snd, ($), error, (<>), notElem, show, (&&), (/=), null, (<$>), fst) -import Data.Maybe( Maybe(Just, Nothing), fromMaybe, isJust) +import Data.Maybe( Maybe(Just, Nothing), fromJust, fromMaybe, isJust) import Slist.Type (Slist(Slist)) @@ -31,7 +31,7 @@ import Slist as SL (filter, last, head, init, isEmpty) import Graphics.Slicer.Math.Definitions (LineSeg) -import Graphics.Slicer.Math.Skeleton.Definitions (ENode, INode(INode), ENodeSet(ENodeSet), INodeSet(INodeSet), NodeTree(NodeTree), finalINodeOf, finalPLine, getFirstLineSeg, getLastLineSeg, hasNoINodes, ancestorsOf, indexPLinesTo, makeINode, sortedPLines) +import Graphics.Slicer.Math.Skeleton.Definitions (ENode, INode(INode), ENodeSet(ENodeSet), INodeSet(INodeSet), NodeTree(NodeTree), finalINodeOf, finalPLine, getFirstLineSeg, getLastLineSeg, hasNoINodes, ancestorsOf, indexPLinesTo, makeINode, sortedPLinesWithErr) import Graphics.Slicer.Math.PGA (PLine2, Arcable(hasArc, outOf)) @@ -74,9 +74,9 @@ pathTo (NodeTree eNodeSet@(ENodeSet eNodeSides) iNodeSet@(INodeSet generations)) | hasArc target = (outOf target : childPlines, target: endNodes, finalENode) | otherwise = ( childPlines, target: endNodes, finalENode) where - pLineToFollow = case direction of - Head -> firstPLine - Last -> SL.last (cons secondPLine morePLines) + pLineToFollow = fst $ case direction of + Head -> firstPLine + Last -> SL.last (cons secondPLine morePLines) iNodeOnThisLevel = findINodeByOutput myINodeSet pLineToFollow False iNodeOnLowerLevel = findINodeByOutput (ancestorsOf myINodeSet) pLineToFollow True result = findENodeByOutput myENodeSet pLineToFollow @@ -131,7 +131,7 @@ findINodeByOutput iNodeSet@(INodeSet generations) plineOut recurse (Slist [iNode] _) -> Just (iNodeSet, iNode) (Slist (_:_) _) -> error "more than one node in a the same generation with the same PLine out!" where - nodesMatching = SL.filter (\(INode _ _ _ a) -> a == Just plineOut) $ slist (SL.last generations) + nodesMatching = SL.filter (\(INode _ _ _ a) -> isJust a && fst (fromJust a) == plineOut) $ slist (SL.last generations) -- | a smart constructor for a NodeTree makeNodeTree :: [ENode] -> INodeSet -> NodeTree @@ -180,8 +180,8 @@ mergeNodeTrees nodeTrees = | otherwise = error "multi-sided ENodeSets not yet supported." nodeTreeAndInsInOrder myNodeTree1@(NodeTree myENodeSet1 _) myNodeTree2@(NodeTree myENodeSet2 _) | isOneSide myENodeSet1 && isOneSide myENodeSet2 = case compareSides (firstSide myENodeSet1) (firstSide myENodeSet2) of - FirstLast -> [[makeINode (indexPLinesTo (outOf $ firstENodeOf myNodeTree2) $ sortedPLines $ insOf (finalINodeOf iNodeSet2) <> [finalPLine myNodeTree1]) Nothing]] - LastFirst -> [[makeINode (indexPLinesTo (outOf $ firstENodeOf myNodeTree1) $ sortedPLines $ finalPLine myNodeTree1 : insOf (finalINodeOf iNodeSet2)) Nothing]] + FirstLast -> [[makeINode (indexPLinesTo (outOf $ firstENodeOf myNodeTree2) $ sortedPLinesWithErr $ insOf (finalINodeOf iNodeSet2) <> [finalPLine myNodeTree1]) Nothing]] + LastFirst -> [[makeINode (indexPLinesTo (outOf $ firstENodeOf myNodeTree1) $ sortedPLinesWithErr $ finalPLine myNodeTree1 : insOf (finalINodeOf iNodeSet2)) Nothing]] NoMatch -> error "failed to connect" | otherwise = error "multi-sided ENodeSets not yet supported." mergeINodeSetsInOrder (NodeTree myENodeSet1 myINodeSet1) (NodeTree myENodeSet2 myINodeSet2) diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index ef597d4d6..8a84dba05 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -59,7 +59,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(GEZero, GEPlu import Graphics.Slicer.Math.Lossy (angleBetween, canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenPLines, distancePPointToPLine, eToCPPoint2, eToPLine2, getFirstArc, join2PPoint2, normalizePLine2, pPointOnPerp) -- Our 2D Projective Geometric Algebra library. -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), canonicalize, pPointBetweenPPointsWithErr, distance2PP, distancePPointToPLineWithErr, eToPLine2WithErr, eToPL, eToPPoint2, intersect2PL, translateL, translateRotatePPoint2, angleBetween2PL, flipL, join2PP, makePPoint2, normalize, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, distancePPointToPLineWithErr, pPointOnPerpWithErr, outOf, pPointOf, ulpOfOut, outputIntersectsLineSeg, pPointBetweenPPointsWithErr) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PLine2Err(PLine2Err), canonicalize, pPointBetweenPPointsWithErr, distance2PP, distancePPointToPLineWithErr, eToPLine2WithErr, eToPL, eToPPoint2, intersect2PL, translateL, translateRotatePPoint2, angleBetween2PL, flipL, join2PP, makePPoint2, normalize, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, distancePPointToPLineWithErr, pPointOnPerpWithErr, outOf, pPointOf, outputIntersectsLineSeg, pPointBetweenPPointsWithErr) -- The primitives of our PGA only library, and error estimation code. @@ -87,7 +87,7 @@ import Graphics.Slicer.Math.Skeleton.Skeleton (findStraightSkeleton) import Math.Util ((-->), (-/>)) -- Our debugging library, for making the below simpler to read, and drop into command lines. -import Graphics.Slicer.Math.Ganja (ListThree, Radian(Radian), cellFrom, edgesOf, generationsOf, randomPL, randomTriangle, randomRectangle, randomSquare, randomConvexQuad, randomConvexSingleRightQuad, randomConvexDualRightQuad, randomConvexBisectableQuad, randomConcaveChevronQuad, randomENode, randomINode, randomLineSeg, randomPLine, randomPLineWithErr, remainderFrom, onlyOne, onlyOneOf, dumpGanjas, toGanja, randomPLineThroughOrigin, randomX1Y1LineSegToOrigin, randomLineSegFromOriginNotX1Y1, randomX1Y1LineSegToPoint, randomLineSegFromPointNotX1Y1, randomPLineThroughPoint, randomLineSegWithErr) +import Graphics.Slicer.Math.Ganja (ListThree, Radian(Radian), cellFrom, edgesOf, generationsOf, randomPL, randomTriangle, randomRectangle, randomSquare, randomConvexQuad, randomConvexSingleRightQuad, randomConvexDualRightQuad, randomConvexBisectableQuad, randomConcaveChevronQuad, randomENode, randomINode, randomLineSeg, randomPLine, randomPLineWithErr, remainderFrom, onlyOne, onlyOneOf, dumpGanjas, toGanja, randomPLineThroughOrigin, randomX1Y1LineSegToOrigin, randomLineSegFromOriginNotX1Y1, randomX1Y1LineSegToPoint, randomLineSegFromPointNotX1Y1, randomPLineThroughPoint) -- Default all numbers in this file to being of the type ImplicitCAD uses for values. default (ℝ) @@ -507,10 +507,10 @@ prop_QuadBisectorCrosses rawX1 rawY1 rawX2 rawY2 <> show eNode <> "\n" <> "(" <> show x3 <> "," <> show y3 <> ")\n" where - intersect1 = intersectsWithErr (Right (PLine2 bisector1, UlpSum bisector1Err)) (Left (lineSeg1, lineSeg1Err)) - intersect2 = intersectsWithErr (Right (PLine2 bisector1, UlpSum bisector1Err)) (Left (lineSeg2, lineSeg2Err)) - intersect3 = outputIntersectsLineSeg eNode (lineSeg1, lineSeg1Err) - intersect4 = outputIntersectsLineSeg eNode (lineSeg2, lineSeg2Err) + intersect1 = intersectsWithErr (Right (PLine2 bisector1, UlpSum bisector1Err)) (Left (lineSeg1, mempty)) + intersect2 = intersectsWithErr (Right (PLine2 bisector1, UlpSum bisector1Err)) (Left (lineSeg2, mempty)) + intersect3 = outputIntersectsLineSeg eNode lineSeg1 + intersect4 = outputIntersectsLineSeg eNode lineSeg2 -- note that our bisector always intersects the origin. (bisector, UlpSum bisectorUlp) = eToPLine2WithErr $ makeLineSeg (Point2 (0,0)) (Point2 (x3,y3)) (NPLine2 bisector1, UlpSum bisector1Ulp) = normalize bisector @@ -533,8 +533,8 @@ prop_QuadBisectorCrosses rawX1 rawY1 rawX2 rawY2 x3 = x1 + x2 y3 = y1 + y2 -- the two line segments we should cross. - (lineSeg1,lineSeg1Err) = randomLineSegWithErr x1 y1 x3 y3 - (lineSeg2,lineSeg2Err) = randomLineSegWithErr x3 y3 x2 y2 + lineSeg1 = randomLineSeg x1 y1 x3 y3 + lineSeg2 = randomLineSeg x3 y3 x2 y2 isEndPoint (Left (HitEndPoint _)) = True isEndPoint (Right PCollinear) = True isEndPoint (Right PAntiParallel) = True @@ -558,14 +558,13 @@ prop_QuadBisectorCrossesMultiple rawX1 rawY1 rawX2 rawY2 rawTimes <> show eNode <> "\n" <> show (angleBetween (normalizePLine2 $ outOf eNode) (normalizePLine2 $ PLine2 bisector1)) <> "\n" <> show bisector1Err <> "\n" - <> show (ulpOfOut eNode) <> "\n" <> "(" <> show x3 <> "," <> show y3 <> ")\n" <> "(" <> show x4 <> "," <> show y4 <> ")\n" where - intersect1 = intersectsWithErr (Right (PLine2 bisector1, UlpSum bisector1Err)) (Left (lineSeg1, lineSeg1Err)) - intersect2 = intersectsWithErr (Right (PLine2 bisector1, UlpSum bisector1Err)) (Left (lineSeg2, lineSeg2Err)) - intersect3 = outputIntersectsLineSeg eNode (lineSeg1, lineSeg1Err) - intersect4 = outputIntersectsLineSeg eNode (lineSeg2, lineSeg2Err) + intersect1 = intersectsWithErr (Right (PLine2 bisector1, UlpSum bisector1Err)) (Left (lineSeg1, mempty)) + intersect2 = intersectsWithErr (Right (PLine2 bisector1, UlpSum bisector1Err)) (Left (lineSeg2, mempty)) + intersect3 = outputIntersectsLineSeg eNode lineSeg1 + intersect4 = outputIntersectsLineSeg eNode lineSeg2 -- note that our bisector always intersects the origin. (NPLine2 bisector1, UlpSum bisector1Ulp) = normalize bisector (bisector, UlpSum bisectorUlp) = eToPLine2WithErr $ makeLineSeg (Point2 (0,0)) (Point2 (x3,y3)) @@ -591,8 +590,8 @@ prop_QuadBisectorCrossesMultiple rawX1 rawY1 rawX2 rawY2 rawTimes y4 = y1 * times + y2 * times times = coerce rawTimes -- the two line segments we should cross. - (lineSeg1,lineSeg1Err) = randomLineSegWithErr x1 y1 x4 y4 - (lineSeg2,lineSeg2Err) = randomLineSegWithErr x4 y4 x2 y2 + lineSeg1 = randomLineSeg x1 y1 x4 y4 + lineSeg2 = randomLineSeg x4 y4 x2 y2 isEndPoint (Left (HitEndPoint _)) = True isEndPoint (Right PCollinear) = True isEndPoint (Right PAntiParallel) = True @@ -624,8 +623,8 @@ prop_LineSegIntersectionStableAtOrigin d1 x1 y1 rawX2 rawY2 ) <> "\n" <> "(x2,y2): " <> show (x2,y2) <> "\n" where - res1 = intersectsWithErr (Right pLineThroughOriginNotX1Y1NotOther) (Left x1y1LineSegToOrigin) - res2 = intersectsWithErr (Right pLineThroughOriginNotX1Y1NotOther) (Left lineSegFromOrigin) + res1 = intersectsWithErr (Right pLineThroughOriginNotX1Y1NotOther) (Left (x1y1LineSegToOrigin,mempty)) + res2 = intersectsWithErr (Right pLineThroughOriginNotX1Y1NotOther) (Left (lineSegFromOrigin,mempty)) distanceStart = case res2 of (Left (NoIntersection iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP iPoint (eToCPPoint2 $ Point2 (0,0))) <> "\nUlpSum:" <> show ulpSum <> "\n" (Right (IntersectsIn iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP iPoint (eToCPPoint2 $ Point2 (0,0))) <> "\nUlpSum:" <> show ulpSum <> "\n" @@ -670,8 +669,8 @@ prop_LineSegIntersectionStableAtX1Y1Point pointD rawD1 x1 y1 rawX2 rawY2 <> distanceEnd ) <> "\n" where - res1 = intersectsWithErr (Right pLineThroughPointNotX1Y1NotOther) (Left x1y1LineSegToPoint) - res2 = intersectsWithErr (Right pLineThroughPointNotX1Y1NotOther) (Left lineSegFromPointNotX1Y1) + res1 = intersectsWithErr (Right pLineThroughPointNotX1Y1NotOther) (Left (x1y1LineSegToPoint,mempty)) + res2 = intersectsWithErr (Right pLineThroughPointNotX1Y1NotOther) (Left (lineSegFromPointNotX1Y1,mempty)) distanceStart = case res2 of (Left (NoIntersection iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP iPoint (eToCPPoint2 $ Point2 (d2,d2))) <> "\nUlpSum:" <> show ulpSum <> "\n" (Right (IntersectsIn iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP iPoint (eToCPPoint2 $ Point2 (d2,d2))) <> "\nUlpSum:" <> show ulpSum <> "\n" @@ -789,22 +788,22 @@ prop_AxisAligned45DegreeAngles xPos yPos offset rawMagnitude1 rawMagnitude2 -- NOTE: we use only one magnitude, because getOutsideArc requires normalized inputs. prop_AxisAlignedRightAnglesOutside :: Bool -> Bool -> ℝ -> Positive ℝ -> Bool prop_AxisAlignedRightAnglesOutside xPos yPos offset rawMagnitude - | xPos && yPos = normalizePLine2 ( + | xPos && yPos = normalizePLine2 (fst $ getOutsideArc (eToPPoint2 $ Point2 (offset,offset+mag)) (normalizePLine2 $ eToPLine2 $ LineSeg (Point2 (offset,offset+mag)) (Point2 (offset,offset))) (eToPPoint2 $ Point2 (offset+mag,offset)) (normalizePLine2 $ eToPLine2 $ LineSeg (Point2 (offset+mag,offset)) (Point2 (offset,offset)))) `myAngleBetween` NPLine2 (GVec [GVal (-0.7071067811865475) (singleton (GEPlus 1)), GVal 0.7071067811865475 (singleton (GEPlus 2))]) - | xPos = normalizePLine2 ( + | xPos = normalizePLine2 (fst $ getOutsideArc (eToPPoint2 $ Point2 (offset,-(offset+mag))) (normalizePLine2 $ eToPLine2 $ LineSeg (Point2 (offset,-(offset+mag))) (Point2 (offset,-offset))) (eToPPoint2 $ Point2 (offset+mag,-offset)) (normalizePLine2 $ eToPLine2 $ LineSeg (Point2 (offset+mag,-offset)) (Point2 (offset,-offset)))) `myAngleBetween` NPLine2 (GVec [GVal 0.7071067811865475 (singleton (GEPlus 1)), GVal 0.7071067811865475 (singleton (GEPlus 2))]) - | not xPos && yPos = normalizePLine2 ( + | not xPos && yPos = normalizePLine2 ( fst $ getOutsideArc (eToPPoint2 $ Point2 (-offset,offset+mag)) (normalizePLine2 $ eToPLine2 $ LineSeg (Point2 (-offset,offset+mag)) (Point2 (-offset,offset))) (eToPPoint2 $ Point2 (-(offset+mag),offset)) (normalizePLine2 $ eToPLine2 $ LineSeg (Point2 (-(offset+mag),offset)) (Point2 (-offset,offset)))) `myAngleBetween` NPLine2 (GVec [GVal (-0.7071067811865475) (singleton (GEPlus 1)), GVal (-0.7071067811865475) (singleton (GEPlus 2))]) - | otherwise = normalizePLine2 ( + | otherwise = normalizePLine2 ( fst $ getOutsideArc (eToPPoint2 $ Point2 (-offset,-(offset+mag))) (normalizePLine2 $ eToPLine2 $ LineSeg (Point2 (-offset,-(offset+mag))) (Point2 (-offset,-offset))) (eToPPoint2 $ Point2 (-(offset+mag),-offset)) (normalizePLine2 $ eToPLine2 $ LineSeg (Point2 (-(offset+mag),-offset)) (Point2 (-offset,-offset)))) `myAngleBetween` @@ -820,22 +819,22 @@ prop_AxisAlignedRightAnglesOutside xPos yPos offset rawMagnitude -- FIXME: expressing this with the second line in each of these pairs the other direction (head->tail vs tail->head) results in falsification? prop_AxisAligned135DegreeAnglesOutside :: Bool -> Bool -> Positive ℝ -> Positive ℝ -> Bool prop_AxisAligned135DegreeAnglesOutside xPos yPos rawOffset rawMagnitude - | xPos && yPos = normalizePLine2 ( + | xPos && yPos = normalizePLine2 ( fst $ getOutsideArc (eToPPoint2 $ Point2 (offset+mag,offset)) (normalizePLine2 $ eToPLine2 $ LineSeg (Point2 (offset+mag,offset)) (Point2 (offset,offset))) (eToPPoint2 $ Point2 (offset+mag,offset+mag)) (normalizePLine2 $ eToPLine2 $ LineSeg (Point2 (offset+mag,offset+mag)) (Point2 (offset,offset)))) `myAngleBetween` NPLine2 (GVec [GVal (-0.3826834323650899) (singleton (GEPlus 1)), GVal 0.9238795325112867 (singleton (GEPlus 2))]) - | xPos = normalizePLine2 ( + | xPos = normalizePLine2 ( fst $ getOutsideArc (eToPPoint2 $ Point2 (offset+mag,-offset)) (normalizePLine2 $ eToPLine2 $ LineSeg (Point2 (offset+mag,-offset)) (Point2 (offset,-offset))) (eToPPoint2 $ Point2 (offset+mag,-(offset+mag))) (normalizePLine2 $ eToPLine2 $ LineSeg (Point2 (offset+mag,-(offset+mag))) (Point2 (offset,-offset)))) `myAngleBetween` NPLine2 (GVec [GVal 0.3826834323650899 (singleton (GEPlus 1)), GVal 0.9238795325112867 (singleton (GEPlus 2))]) - | not xPos && yPos = normalizePLine2 ( + | not xPos && yPos = normalizePLine2 ( fst $ getOutsideArc (eToPPoint2 $ Point2 (-(offset+mag),offset)) (normalizePLine2 $ eToPLine2 $ LineSeg (Point2 (-(offset+mag),offset)) (Point2 (-offset,offset))) (eToPPoint2 $ Point2 (-(offset+mag),offset+mag)) (normalizePLine2 $ eToPLine2 $ LineSeg (Point2 (-(offset+mag),offset+mag)) (Point2 (-offset,offset)))) `myAngleBetween` NPLine2 (GVec [GVal (-0.3826834323650899) (singleton (GEPlus 1)), GVal (-0.9238795325112867) (singleton (GEPlus 2))]) - | otherwise = normalizePLine2 ( + | otherwise = normalizePLine2 ( fst $ getOutsideArc (eToPPoint2 $ Point2 (-(offset+mag),-offset)) (normalizePLine2 $ eToPLine2 $ LineSeg (Point2 (-(offset+mag),-offset)) (Point2 (-offset,-offset))) (eToPPoint2 $ Point2 (-(offset+mag),-(offset+mag))) (normalizePLine2 $ eToPLine2 $ LineSeg (Point2 (-(offset+mag),-(offset+mag))) (Point2 (-offset,-offset)))) `myAngleBetween` @@ -1196,13 +1195,13 @@ prop_PPointWithinErrRange x y prop_LineSegWithinErrRange :: ℝ -> ℝ -> ℝ -> ℝ -> Bool prop_LineSegWithinErrRange x1 y1 rawX2 rawY2 - | res1 > realToFrac ulpSum = error "too big startPoint" - | res2 > realToFrac ulpSum = error "too big endPoint" + | res1 > 0 = error "too big startPoint" + | res2 > 0 = error "too big endPoint" | otherwise = True where res1 = distance (startPoint lineSeg) (Point2 (x1,y1)) res2 = distance (endPoint lineSeg) (Point2 (x2,y2)) - (lineSeg, UlpSum ulpSum) = randomLineSegWithErr x1 y1 x2 y2 + lineSeg = randomLineSeg x1 y1 x2 y2 (x2,y2) | x1 == rawX2 && y1 == rawY2 = if x1 == 0 && y1 == 0 then (1,1) @@ -1636,29 +1635,69 @@ facetSpec = do property prop_eNodeAwayFromIntersection2 it "successfully translates and rotates PPoint2s" $ property prop_translateRotateMoves +{- it "finds the arc resulting from a node at the intersection of the outArc of two nodes (corner3 and corner4 of c2)" $ - averageNodes c2c3E1 c2c4E1 --> INode (PLine2 (GVec [GVal 0.7071067811865475 (singleton (GEPlus 1)), GVal (-0.7071067811865475) (singleton (GEPlus 2))])) - (PLine2 (GVec [GVal 0.541196100146197 (singleton (GEZero 1)), GVal 0.3826834323650897 (singleton (GEPlus 1)), GVal 0.9238795325112867 (singleton (GEPlus 2))])) + averageNodes c2c3E1 c2c4E1 --> INode (PLine2 (GVec [GVal 0.7071067811865475 (singleton (GEPlus 1)), GVal (-0.7071067811865475) (singleton (GEPlus 2))]), + PLine2Err mempty [ErrVal (UlpSum 1.1102230246251565e-16) (singleton (GEPlus 1)), ErrVal (UlpSum 1.1102230246251565e-16) (singleton (GEPlus 2))] (UlpSum 2.220446049250313e-16) (UlpSum 8.881784197001252e-16) mempty ([ErrVal (UlpSum 2.220446049250313e-16) (singleton (GEPlus 2)), ErrVal (UlpSum 2.220446049250313e-16) (singleton (GEPlus 1))],[])) + (PLine2 (GVec [GVal 0.541196100146197 (singleton (GEZero 1)), GVal 0.3826834323650897 (singleton (GEPlus 1)), GVal 0.9238795325112867 (singleton (GEPlus 2))]), + PLine2Err [ErrVal (UlpSum 2.220446049250313e-16) (singleton (GEPlus 2))] + [ErrVal (UlpSum 1.1102230246251565e-16) (singleton (GEZero 1)), ErrVal (UlpSum 5.551115123125783e-17) (singleton (GEPlus 1)), ErrVal (UlpSum 1.1102230246251565e-16) (singleton (GEPlus 2))] + (UlpSum 2.220446049250313e-16) (UlpSum 9.43689570931383e-16) mempty mempty) (slist []) - (Just (PLine2 (GVec [GVal 0.48706362218573185 (singleton (GEZero 1)), GVal 0.9807852804032305 (singleton (GEPlus 1)), GVal 0.19509032201612822 (singleton (GEPlus 2))]))) + (Just (PLine2 (GVec [GVal 0.48706362218573185 (singleton (GEZero 1)), GVal 0.9807852804032305 (singleton (GEPlus 1)), GVal 0.19509032201612822 (singleton (GEPlus 2))]), + PLine2Err [ErrVal (UlpSum 2.220446049250313e-16) (singleton (GEPlus 1)), ErrVal (UlpSum 2.7755575615628914e-17) (singleton (GEPlus 2))] + [ErrVal (UlpSum 5.551115123125783e-17) (singleton (GEZero 1)), ErrVal (UlpSum 1.1102230246251565e-16) (singleton (GEPlus 1)), ErrVal (UlpSum 2.7755575615628914e-17) (singleton (GEPlus 2))] + (UlpSum 2.220446049250313e-16) (UlpSum 4.510281037539698e-16) mempty mempty) + ) it "finds the outside arc of two PLines intersecting at 90 degrees (c2)" $ - averageNodes c2c2E1 c2c3E1 --> INode (PLine2 (GVec [GVal (-0.7071067811865475) (singleton (GEPlus 1)), GVal (-0.7071067811865475) (singleton (GEPlus 2))])) - (PLine2 (GVec [GVal 0.7071067811865475 (singleton (GEPlus 1)), GVal (-0.7071067811865475) (singleton (GEPlus 2))])) + averageNodes c2c2E1 c2c3E1 --> INode (PLine2 (GVec [GVal (-0.7071067811865475) (singleton (GEPlus 1)), GVal (-0.7071067811865475) (singleton (GEPlus 2))]), + PLine2Err [] + [ErrVal (UlpSum 1.1102230246251565e-16) (singleton (GEPlus 1)), ErrVal (UlpSum 1.1102230246251565e-16) (singleton (GEPlus 2))] + (UlpSum 2.220446049250313e-16) (UlpSum 8.881784197001254e-16) mempty ([ErrVal (UlpSum 2.220446049250313e-16) (singleton (GEPlus 2)),ErrVal (UlpSum 2.220446049250313e-16) (singleton (GEPlus 1))],[])) + (PLine2 (GVec [GVal 0.7071067811865475 (singleton (GEPlus 1)), GVal (-0.7071067811865475) (singleton (GEPlus 2))]), + PLine2Err [] + [ErrVal (UlpSum 1.1102230246251565e-16) (singleton (GEPlus 1)), ErrVal (UlpSum 1.1102230246251565e-16) (singleton (GEPlus 2))] + (UlpSum 2.220446049250313e-16) (UlpSum 8.881784197001254e-16) mempty ([ErrVal (UlpSum 2.220446049250313e-16) (singleton (GEPlus 2)), ErrVal (UlpSum 2.220446049250313e-16) (singleton (GEPlus 1))],[])) (slist []) - (Just (PLine2 (GVec [GVal (-1.0) (singleton (GEPlus 2))]))) + (Just (PLine2 (GVec [GVal (-1.0) (singleton (GEPlus 2))]), + PLine2Err [ErrVal (UlpSum 2.220446049250313e-16) (singleton (GEPlus 2))] + [ErrVal (UlpSum 2.220446049250313e-16) (singleton (GEPlus 2))] + (UlpSum 2.220446049250313e-16) (UlpSum 8.881784197001254e-16) mempty mempty)) it "finds the outside arc of two PLines intersecting at 90 degrees (c2)" $ - averageNodes c2c3E1 c2c2E1 --> INode (PLine2 (GVec [GVal (-0.7071067811865475) (singleton (GEPlus 1)), GVal (-0.7071067811865475) (singleton (GEPlus 2))])) - (PLine2 (GVec [GVal 0.7071067811865475 (singleton (GEPlus 1)), GVal (-0.7071067811865475) (singleton (GEPlus 2))])) + averageNodes c2c3E1 c2c2E1 --> INode (PLine2 (GVec [GVal (-0.7071067811865475) (singleton (GEPlus 1)), GVal (-0.7071067811865475) (singleton (GEPlus 2))]), + PLine2Err [] + [ErrVal (UlpSum 1.1102230246251565e-16) (singleton (GEPlus 1)), ErrVal (UlpSum 1.1102230246251565e-16) (singleton (GEPlus 2))] + (UlpSum 2.220446049250313e-16) (UlpSum 8.881784197001254e-16) mempty ([ErrVal (UlpSum 2.220446049250313e-16) (singleton (GEPlus 2)),ErrVal (UlpSum 2.220446049250313e-16) (singleton (GEPlus 1))],[])) + (PLine2 (GVec [GVal 0.7071067811865475 (singleton (GEPlus 1)), GVal (-0.7071067811865475) (singleton (GEPlus 2))]), + PLine2Err [] + [ErrVal (UlpSum 1.1102230246251565e-16) (singleton (GEPlus 1)), ErrVal (UlpSum 1.1102230246251565e-16) (singleton (GEPlus 2))] + (UlpSum 2.220446049250313e-16) (UlpSum 8.881784197001254e-16) mempty ([ErrVal (UlpSum 2.220446049250313e-16) (singleton (GEPlus 2)), ErrVal (UlpSum 2.220446049250313e-16) (singleton (GEPlus 1))],[])) (slist []) - (Just (PLine2 (GVec [GVal (-1.0) (singleton (GEPlus 2))]))) + (Just (PLine2 (GVec [GVal (-1.0) (singleton (GEPlus 2))]), + PLine2Err [ErrVal (UlpSum 2.220446049250313e-16) (singleton (GEPlus 2))] + [ErrVal (UlpSum 2.220446049250313e-16) (singleton (GEPlus 2))] + (UlpSum 2.220446049250313e-16) (UlpSum 8.881784197001254e-16) mempty mempty)) it "finds the outside arc of two PLines intersecting at 90 degrees (c7)" $ - averageNodes c7c1E1 c7c2E1 --> INode (PLine2 (GVec [GVal (-0.7071067811865475) (singleton (GEPlus 1)), GVal 0.7071067811865475 (singleton (GEPlus 2))])) - (PLine2 (GVec [GVal 1.0606601717798212 (singleton (GEZero 1)), GVal (-0.7071067811865475) (singleton (GEPlus 1)), GVal (-0.7071067811865475) (singleton (GEPlus 2))])) + averageNodes c7c1E1 c7c2E1 --> INode (PLine2 (GVec [GVal (-0.7071067811865475) (singleton (GEPlus 1)), GVal 0.7071067811865475 (singleton (GEPlus 2))]), + PLine2Err [] + [ErrVal (UlpSum 1.1102230246251565e-16) (singleton (GEPlus 1)), ErrVal (UlpSum 1.1102230246251565e-16) (singleton (GEPlus 2))] + (UlpSum 2.220446049250313e-16) (UlpSum 8.881784197001254e-16) mempty mempty) + (PLine2 (GVec [GVal 1.0606601717798212 (singleton (GEZero 1)), GVal (-0.7071067811865475) (singleton (GEPlus 1)), GVal (-0.7071067811865475) (singleton (GEPlus 2))]), + PLine2Err [ErrVal (UlpSum 2.220446049250313e-16) (singleton (GEZero 1))] + [ErrVal (UlpSum 2.220446049250313e-16) (singleton (GEZero 1)), ErrVal (UlpSum 1.1102230246251565e-16) (singleton (GEPlus 1)), ErrVal (UlpSum 1.1102230246251565e-16) (singleton (GEPlus 2))] + (UlpSum 2.220446049250313e-16) (UlpSum 8.881784197001254e-16) mempty mempty) (slist []) - (Just (PLine2 (GVec [GVal 0.75 (singleton (GEZero 1)), GVal (-1.0) (singleton (GEPlus 1))]))) + (Just (PLine2 (GVec [GVal 0.75 (singleton (GEZero 1)), GVal (-1.0) (singleton (GEPlus 1))]), + PLine2Err [ErrVal (UlpSum 2.220446049250313e-16) (singleton (GEPlus 1))] + [ErrVal (UlpSum 1.1102230246251565e-16) (singleton (GEZero 1)), ErrVal (UlpSum 2.220446049250313e-16) (singleton (GEPlus 1))] + (UlpSum 2.220446049250313e-16) (UlpSum 8.881784197001254e-16) mempty mempty)) +-} describe "Motorcycles (Skeleton/Motorcycles)" $ do it "finds the motorcycle in our second simple shape" $ - convexMotorcycles c1 --> [Motorcycle (LineSeg (Point2 (-1.0,-1.0)) (Point2 (0.0,0.0)), LineSeg (Point2 (0.0,0.0)) (Point2 (1.0,-1.0))) (PLine2 (GVec [GVal 1.414213562373095 (singleton (GEPlus 1))])) (UlpSum 2.220446049250313e-16) 2.8284271247461903] + convexMotorcycles c1 --> [Motorcycle (LineSeg (Point2 (-1.0,-1.0)) (Point2 (0.0,0.0)), LineSeg (Point2 (0.0,0.0)) (Point2 (1.0,-1.0))) + (PLine2 (GVec [GVal 1.414213562373095 (singleton (GEPlus 1))])) + (PLine2Err [ErrVal (UlpSum 2.220446049250313e-16) (singleton (GEPlus 1))] mempty mempty mempty mempty mempty) + ] describe "Cells (Skeleton/Cells)" $ do it "finds the remains from the first cell of our first simple shape." $ remainderFrom (findFirstCellOfContour c0 $ findDivisions c0 $ fromMaybe (error "Got Nothing") $ crashMotorcycles c0 []) --> From 62c7667d610b2d11fd0d5c02aef49297292eb4e9 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Tue, 25 Oct 2022 00:20:02 +0000 Subject: [PATCH 036/206] make angleBetween2PL expose normalization ammounts, if they were found to be necessary. --- Graphics/Slicer/Math/PGA.hs | 18 ++++++--------- Graphics/Slicer/Math/PGAPrimitives.hs | 6 ++--- Graphics/Slicer/Math/Skeleton/Cells.hs | 6 ++--- Graphics/Slicer/Math/Skeleton/Concave.hs | 6 ++--- Graphics/Slicer/Math/Skeleton/Motorcycles.hs | 22 +++++++++--------- tests/Math/PGA.hs | 24 ++++++++++---------- 6 files changed, 39 insertions(+), 43 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index f5ed0bab0..16c17692e 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -122,7 +122,7 @@ plinesIntersectIn pl1 pl2 | otherwise = IntersectsIn res (resUlp, mempty, mempty, mempty, iaErr, mempty) where (idealNorm, idnErr) = idealNormOfP intersectPoint - (_, iaErr) = angleBetween2PL npl1 npl2 + (_, (_,_,iaErr)) = angleBetween2PL npl1 npl2 -- FIXME: how much do the potential normalization errors have an effect on the resultant angle? (intersectPoint, _) = intersect2PL pl1 pl2 (res, resUlp) = fromJust canonicalizedIntersection @@ -228,7 +228,7 @@ sameDirection a b = res >= maxAngle -- ceiling value. a value bigger than maxAngle is considered to be going the same direction. maxAngle :: ℝ maxAngle = realToFrac (1 - ulpVal resErr :: Rounded 'TowardInf ℝ) - (res, resErr) = angleBetween2PL a b + (res, (_,_,resErr)) = angleBetween2PL a b -- | A checker, to ensure two Projective Lines are going the opposite direction, and are parallel. -- FIXME: precision on inputs? @@ -238,7 +238,7 @@ oppositeDirection a b = res <= minAngle -- floor value. a value smaller than minAngle is considered to be going the opposite direction. minAngle :: ℝ minAngle = realToFrac (realToFrac (ulpVal resErr) + (-1) :: Rounded 'TowardNegInf ℝ) - (res, resErr) = angleBetween2PL a b + (res, (_,_,resErr)) = angleBetween2PL a b -- | Find a projective point a given distance along a line perpendicularly bisecting the given line at a given point. pPointOnPerpWithErr :: (ProjectiveLine2 a, ProjectivePoint2 b) => a -> b -> ℝ -> (PPoint2, UlpSum) @@ -323,21 +323,17 @@ type SegOrPLine2WithErr = Either (LineSeg, UlpSum) (PLine2,UlpSum) intersectsWithErr :: SegOrPLine2WithErr -> SegOrPLine2WithErr -> Either Intersection PIntersection intersectsWithErr (Left l1) (Left l2) = lineSegIntersectsLineSeg l1 l2 intersectsWithErr (Right (pl1,_)) (Right (pl2,_)) = Right $ plinesIntersectIn pl1 pl2 -intersectsWithErr (Left l1@(rawL1,_)) (Right pl1@(rawPL1,_)) = pLineIntersectsLineSeg pl1 l1 ulpScale +intersectsWithErr (Left l1@(rawL1,_)) (Right pl1@(rawPL1, _)) = pLineIntersectsLineSeg pl1 l1 ulpScale where ulpScale :: ℝ ulpScale = realToFrac $ ulpMultiplier * (abs (realToFrac angle) + angleErr) - (angle, UlpSum angleErr) = angleBetween2PL (npl1, npl1Err) (npl2, npl2Err) - (npl1, npl1Err) = normalizeL rawPL1 - (npl2, npl2Err) = normalizeL pl2 + (angle, (_,_, UlpSum angleErr)) = angleBetween2PL (rawPL1, mempty) (pl2, mempty) (pl2, _) = eToPLine2WithErr rawL1 -intersectsWithErr (Right pl1@(rawPL1,_)) (Left l1@(rawL1,_)) = pLineIntersectsLineSeg pl1 l1 ulpScale +intersectsWithErr (Right pl1@(rawPL1, _)) (Left l1@(rawL1,_)) = pLineIntersectsLineSeg pl1 l1 ulpScale where ulpScale :: ℝ ulpScale = realToFrac $ ulpMultiplier * (abs (realToFrac angle) + angleErr) - (angle, UlpSum angleErr) = angleBetween2PL (npl1, npl1Err) (npl2, npl2Err) - (npl1, npl1Err) = normalizeL rawPL1 - (npl2, npl2Err) = normalizeL pl2 + (angle, (_,_, UlpSum angleErr)) = angleBetween2PL (rawPL1, mempty) (pl2, mempty) (pl2, _) = eToPLine2WithErr rawL1 -- | Check if/where a line segment and a PLine intersect. diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index 88bdf3e2a..3faa77c50 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -149,7 +149,7 @@ newtype NPLine2 = NPLine2 GVec deriving (Eq, Generic, NFData, Show) class ProjectiveLine2 a where - angleBetween2PL :: (ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> (ℝ, UlpSum) + angleBetween2PL :: (ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> (ℝ, (PLine2Err, PLine2Err, UlpSum)) consLikeL :: a -> (GVec -> a) flipL :: a -> a forceBasisOfL :: a -> a @@ -164,7 +164,7 @@ class ProjectiveLine2 a where instance ProjectiveLine2 NPLine2 where angleBetween2PL l1 l2 = crushErr $ angleBetweenWithErr l1 l2 where - crushErr (res, (_,_,_,ulpSum)) = (res, ulpSum) + crushErr (res, (n1,n2,_,ulpSum)) = (res, (n1,n2,ulpSum)) consLikeL _ = NPLine2 flipL l = flipProjectiveLine l forceBasisOfL l = forceProjectiveLineBasis l @@ -179,7 +179,7 @@ instance ProjectiveLine2 NPLine2 where instance ProjectiveLine2 PLine2 where angleBetween2PL l1 l2 = crushErr $ angleBetweenWithErr l1 l2 where - crushErr (res, (_,_,_,ulpSum)) = (res, ulpSum) + crushErr (res, (n1,n2,_,ulpSum)) = (res, (n1,n2,ulpSum)) consLikeL _ = PLine2 flipL l = flipProjectiveLine l forceBasisOfL l = forceProjectiveLineBasis l diff --git a/Graphics/Slicer/Math/Skeleton/Cells.hs b/Graphics/Slicer/Math/Skeleton/Cells.hs index 2f95bdf8b..2d97d2842 100644 --- a/Graphics/Slicer/Math/Skeleton/Cells.hs +++ b/Graphics/Slicer/Math/Skeleton/Cells.hs @@ -52,7 +52,7 @@ import Graphics.Slicer.Math.Contour (lineSegsOfContour) import Graphics.Slicer.Math.Definitions (Contour, LineSeg(LineSeg), Point2, distance, endPoint, startPoint, fudgeFactor, makeLineSeg) -import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum)) +import Graphics.Slicer.Math.GeometricAlgebra (ulpVal) import Graphics.Slicer.Math.Intersections (intersectionOf) @@ -111,9 +111,9 @@ findDivisions contour crashTree = case motorcyclesIn crashTree of -- LOWHANGINGFRUIT: what about two motorcycles that are anticolinear? error "don't know what to do with these motorcycles." where - intersectionIsBehind m = angleFound < realToFrac angleErr + intersectionIsBehind m = angleFound < realToFrac (ulpVal angleErr) where - (angleFound, UlpSum angleErr) = angleBetween2PL (normalizeL $ outOf m) (eToPL $ lineSegToIntersection m) + (angleFound, (_,_, angleErr)) = angleBetween2PL (normalizeL $ outOf m) (eToPL $ lineSegToIntersection m) lineSegToIntersection m = makeLineSeg (ePointOf m) (pToEPoint2 intersectionPPoint) intersectionPPoint = intersectionOf (outOf firstMC) (outOf secondMC) (Slist (_:_) _) -> error "too many motorcycles." diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index 2e9e63ee9..9aadd955a 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -56,7 +56,7 @@ import Graphics.Slicer.Math.Contour (lineSegsOfContour) import Graphics.Slicer.Math.Definitions (Contour, LineSeg(LineSeg), Point2, endPoint, mapWithFollower, fudgeFactor, startPoint) -import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum)) +import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum), ulpVal) import Graphics.Slicer.Math.Intersections (intersectionOf, intersectionBetween, isCollinear, isParallel, isAntiCollinear, noIntersection) @@ -218,9 +218,9 @@ getOutsideArc ppoint1 npline1 ppoint2 npline2 towardIntersection :: (ProjectivePoint2 a) => a -> PLine2 -> CPPoint2 -> Bool towardIntersection pp1 pl1 pp2 | d <= realToFrac dErr = error $ "cannot resolve points finely enough.\nPPoint1: " <> show pp1 <> "\nPPoint2: " <> show pp2 <> "\nPLineIn: " <> show pl1 <> "\nnewPLine: " <> show newPLine <> "\n" - | otherwise = angleFound > realToFrac angleErr + | otherwise = angleFound > realToFrac (ulpVal angleErr) where - (angleFound, UlpSum angleErr) = angleBetween2PL newPLine (normalizeL pl1) + (angleFound, (_,_, angleErr)) = angleBetween2PL newPLine (normalizeL pl1) (d, UlpSum dErr) = distance2PP (fst $ canonicalize pp1) pp2 newPLine = normalizeL $ join2CPPoint2 (fst $ canonicalize pp1) pp2 diff --git a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs index 4ed3c773c..b7edb5003 100644 --- a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs +++ b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs @@ -54,7 +54,7 @@ import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2(NPLine2), PLine2(PLine2), PLi import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle), ENode(ENode), getFirstLineSeg, linePairs, CellDivide(CellDivide), DividingMotorcycles(DividingMotorcycles), MotorcycleIntersection(WithLineSeg, WithENode, WithMotorcycle)) -import Graphics.Slicer.Math.GeometricAlgebra (addVecPairWithErr, UlpSum(UlpSum)) +import Graphics.Slicer.Math.GeometricAlgebra (addVecPairWithErr, ulpVal) -- | The collision of two motorcycles. one lives, and one doesn't, unless it's a head on collision, in which case both die, and there is no survivor. data Collision = Collision { _inMotorcycles :: !(Motorcycle, Motorcycle, Slist Motorcycle), _survivor :: !(Maybe Motorcycle), collisionResult :: !CollisionType } @@ -155,9 +155,9 @@ crashMotorcycles contour holes _ -> Nothing where intersectionPPoint = intersectionOf (outOf mot1) (outOf mot2) - intersectionIsBehind m = angleFound < realToFrac angleErr + intersectionIsBehind m = angleFound < realToFrac (ulpVal angleErr) where - (angleFound, UlpSum angleErr) = angleBetween2PL (normalizeL $ outOf m) (eToPL $ lineSegToIntersection m) + (angleFound, (_,_, angleErr)) = angleBetween2PL (normalizeL $ outOf m) (eToPL $ lineSegToIntersection m) lineSegToIntersection m = makeLineSeg (ePointOf m) (pToEPoint2 intersectionPPoint) -- | Find the non-reflex virtexes of a contour and draw motorcycles from them. Useful for contours that are a 'hole' in a bigger contour. @@ -253,12 +253,12 @@ motorcycleMightIntersectWith lineSegs motorcycle then Nothing else Just intersection where - intersectionPointIsBehind point = angleFound < realToFrac angleErr + intersectionPointIsBehind point = angleFound < realToFrac (ulpVal angleErr) where - (angleFound, UlpSum angleErr) = angleBetween2PL (normalizeL $ outOf motorcycle) (eToPL $ lineSegToIntersection point) - intersectionCPPointIsBehind pPoint = angleFound < realToFrac angleErr + (angleFound, (_,_, angleErr)) = angleBetween2PL (normalizeL $ outOf motorcycle) (eToPL $ lineSegToIntersection point) + intersectionCPPointIsBehind pPoint = angleFound < realToFrac (ulpVal angleErr) where - (angleFound, UlpSum angleErr) = angleBetween2PL (normalizeL $ outOf motorcycle) (eToPL $ lineSegToIntersectionP pPoint) + (angleFound, (_,_, angleErr)) = angleBetween2PL (normalizeL $ outOf motorcycle) (eToPL $ lineSegToIntersectionP pPoint) lineSegToIntersection myPoint = makeLineSeg (ePointOf motorcycle) myPoint lineSegToIntersectionP myPPoint = makeLineSeg (ePointOf motorcycle) (pToEPoint2 myPPoint) @@ -296,12 +296,12 @@ motorcycleIntersectsAt contour motorcycle = case intersections of then Nothing else Just intersection where - intersectionPointIsBehind point = angleFound < realToFrac angleErr + intersectionPointIsBehind point = angleFound < realToFrac (ulpVal angleErr) where - (angleFound, UlpSum angleErr) = angleBetween2PL (normalizeL $ outOf motorcycle) (eToPL $ lineSegToIntersection point) - intersectionPPointIsBehind pPoint = angleFound < realToFrac angleErr + (angleFound, (_,_, angleErr)) = angleBetween2PL (normalizeL $ outOf motorcycle) (eToPL $ lineSegToIntersection point) + intersectionPPointIsBehind pPoint = angleFound < realToFrac (ulpVal angleErr) where - (angleFound, UlpSum angleErr) = angleBetween2PL (normalizeL $ outOf motorcycle) (eToPL $ lineSegToIntersectionP pPoint) + (angleFound, (_,_, angleErr)) = angleBetween2PL (normalizeL $ outOf motorcycle) (eToPL $ lineSegToIntersectionP pPoint) lineSegToIntersection myPoint = makeLineSeg (ePointOf motorcycle) myPoint lineSegToIntersectionP myPPoint = makeLineSeg (ePointOf motorcycle) (pToEPoint2 myPPoint) motorcyclePoint = canonicalizePPoint2 $ pPointOf motorcycle diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index 8a84dba05..deee6012c 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -403,18 +403,18 @@ prop_perpAt90Degrees x y rawX2 y2 rawD <> "angle2: " <> show angle2 <> "\n" <> "angle2Err: " <> show angle2Err <> "\n" where - (angle2, UlpSum angle2Err) = angleBetween2PL (normedPLine3, norm3Err) (normedPLine4, norm4Err) - (PPoint2 rawBisectorStart, UlpSum bisectorStartErr) = pPointBetweenPPointsWithErr sourceStart sourceEnd 0.5 0.5 - (bisectorEndRaw, UlpSum bisectorEndRawErr) = pPointOnPerpWithErr pline4 (PPoint2 rawBisectorStart) d - (bisectorEnd, UlpSum bisectorEndErr) = canonicalize bisectorEndRaw - (pline3, UlpSum pline3Err) = join2PP (CPPoint2 rawBisectorStart) bisectorEnd + (angle2, (_,_, angle2Err)) = angleBetween2PL (normedPLine3, norm3Err) (normedPLine4, norm4Err) + (PPoint2 rawBisectorStart, bisectorStartErr) = pPointBetweenPPointsWithErr sourceStart sourceEnd 0.5 0.5 + (bisectorEndRaw, bisectorEndRawErr) = pPointOnPerpWithErr pline4 (PPoint2 rawBisectorStart) d + (bisectorEnd, bisectorEndErr) = canonicalize bisectorEndRaw + (pline3, pline3Err) = join2PP (CPPoint2 rawBisectorStart) bisectorEnd (normedPLine3, norm3Err) = normalizeL pline3 sourceStart = makePPoint2 x y sourceEnd = makePPoint2 x2 y2 - (pline4, UlpSum pline4Err) = join2PP sourceStart sourceEnd + (pline4, pline4Err) = join2PP sourceStart sourceEnd (normedPLine4, norm4Err) = normalizeL pline4 - errTotal3 = angle2Err + pline3Err + pline4Err + bisectorStartErr + bisectorEndRawErr + bisectorEndErr - errTotal4 = angle2Err + pline3Err + pline4Err + bisectorStartErr + bisectorEndRawErr + bisectorEndErr + errTotal3 = ulpVal $ angle2Err <> pline3Err <> pline4Err <> bisectorStartErr <> bisectorEndRawErr <> bisectorEndErr + errTotal4 = ulpVal $ angle2Err <> pline3Err <> pline4Err <> bisectorStartErr <> bisectorEndRawErr <> bisectorEndErr x2 :: ℝ x2 = coerce rawX2 d :: ℝ @@ -709,7 +709,7 @@ prop_LineSegIntersectionStableAtX1Y1Point pointD rawD1 x1 y1 rawX2 rawY2 -- | A checker, to ensure an angle is what is expected. myAngleBetween :: NPLine2 -> NPLine2 -> Bool myAngleBetween a b - | realToFrac res + resErr >= 1.0-resErr = True + | realToFrac res + (ulpVal resErr) >= 1.0-(ulpVal resErr) = True | otherwise = error $ "angle wrong?\n" <> show a <> "\n" @@ -717,7 +717,7 @@ myAngleBetween a b <> show res <> "\n" <> show resErr <> "\n" where - (res, UlpSum resErr) = angleBetween2PL (a, mempty) (b, mempty) + (res, (_,_, resErr)) = angleBetween2PL (a, mempty) (b, mempty) -- | ensure that a right angle with one side parallel with an axis and the other side parallel to the other axis results in a line through the origin point. -- NOTE: hack, using angleBetween to filter out minor numerical imprecision. @@ -1321,9 +1321,9 @@ prop_obtuseBisectorOnBiggerSide_makeENode x y d1 rawR1 d2 rawR2 testFirstLine bisector = flipL $ outOf eNode prop_obtuseBisectorOnBiggerSide_makeINode :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> Positive ℝ -> Radian ℝ -> Bool -> Bool -> Expectation -prop_obtuseBisectorOnBiggerSide_makeINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 = (angleFound > realToFrac (1-angleErr), angleFound < realToFrac (-1 + angleErr :: Rounded 'TowardInf ℝ)) --> (True, False) +prop_obtuseBisectorOnBiggerSide_makeINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 = (angleFound > realToFrac (1-(ulpVal angleErr)), angleFound < realToFrac (-1 + (ulpVal angleErr) :: Rounded 'TowardInf ℝ)) --> (True, False) where - (angleFound, UlpSum angleErr) = angleBetween2PL bisector1 bisector2 + (angleFound, (_,_, angleErr)) = angleBetween2PL bisector1 bisector2 eNode = randomENode x y d1 rawR1 d2 rawR2 iNode = randomINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 bisector1 = normalizeL $ outOf iNode From 9fbcc867fffa5787eaf7029a1d0ff855d8474431 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Tue, 25 Oct 2022 01:11:23 +0000 Subject: [PATCH 037/206] remove old normalize interface, replacing it with normalizeL. --- Graphics/Slicer/Math/Lossy.hs | 6 +++--- Graphics/Slicer/Math/PGA.hs | 17 ++++++++-------- Graphics/Slicer/Math/PGAPrimitives.hs | 6 ------ tests/Math/PGA.hs | 29 ++++++++++++--------------- 4 files changed, 24 insertions(+), 34 deletions(-) diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index e3b2f30a0..1eecbd584 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -48,7 +48,7 @@ import Graphics.Slicer.Math.Definitions (LineSeg, Point2, makeLineSeg) import Graphics.Slicer.Math.Arcs (getFirstArcWithErr, getInsideArcWithErr) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PPoint2, ProjectiveLine2, ProjectivePoint2, angleBetween2PL, canonicalize, distance2PP, distanceBetweenPLinesWithErr, distancePPointToPLineWithErr, eToPLine2WithErr, eToPPoint2, join2PP, normalize, pPointBetweenPPointsWithErr, pPointOnPerpWithErr, pToEP, translateL) +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PPoint2, ProjectiveLine2, ProjectivePoint2, angleBetween2PL, canonicalize, distance2PP, distanceBetweenPLinesWithErr, distancePPointToPLineWithErr, eToPLine2WithErr, eToPPoint2, join2PP, normalizeL, pPointBetweenPPointsWithErr, pPointOnPerpWithErr, pToEP, translateL) angleBetween :: NPLine2 -> NPLine2 -> ℝ angleBetween nPLine1 nPLine2 = fst $ angleBetween2PL (nPLine1, mempty) (nPLine2, mempty) @@ -73,7 +73,7 @@ eToCPPoint2 point = eToPPoint2 point -- | Create a normalized projective line from a euclidian line segment. eToNPLine2 :: LineSeg -> NPLine2 -eToNPLine2 l1 = fst $ normalize $ fst $ eToPLine2WithErr l1 +eToNPLine2 l1 = fst $ normalizeL $ fst $ eToPLine2WithErr l1 -- | Create an un-normalized projective line from a euclidian line segment. eToPLine2 :: LineSeg -> PLine2 @@ -96,7 +96,7 @@ join2CPPoint2 pp1 pp2 = fst $ join2PP pp1 pp2 -- | Normalize a PLine2. normalizePLine2 :: (ProjectiveLine2 a) => a -> NPLine2 -normalizePLine2 pl = fst $ normalize pl +normalizePLine2 pl = fst $ normalizeL pl -- | Create a projective line from a pair of euclidian points. pLineFromEndpoints :: Point2 -> Point2 -> PLine2 diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 16c17692e..7dfe90576 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -51,7 +51,6 @@ module Graphics.Slicer.Math.PGA( intersectsWithErr, join2PP, makePPoint2, - normalize, normalizeL, outputIntersectsLineSeg, pLineIsLeft, @@ -91,7 +90,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (GNum(G0, GEPlus, GEZero), GVal(GVa import Graphics.Slicer.Math.Line (combineLineSegs) -import Graphics.Slicer.Math.PGAPrimitives(Arcable(errOfOut, hasArc, outOf), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(angleBetween2PL, flipL, forceBasisOfL, intersect2PL, normalize, normalizeL, normOfL, translateL, vecOfL), ProjectivePoint2(canonicalize, distance2PP, forceBasisOfP, idealNormOfP, join2PP, join2PPWithErr, pToEP, vecOfP), xIntercept, yIntercept) +import Graphics.Slicer.Math.PGAPrimitives(Arcable(errOfOut, hasArc, outOf), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(angleBetween2PL, flipL, forceBasisOfL, intersect2PL, normalizeL, normOfL, translateL, vecOfL), ProjectivePoint2(canonicalize, distance2PP, forceBasisOfP, idealNormOfP, join2PP, join2PPWithErr, pToEP, vecOfP), xIntercept, yIntercept) -- Our 2D plane coresponds to a Clifford algebra of 2,0,1. @@ -139,8 +138,8 @@ pLineIsLeft pl1 pl2 where -- FIXME: naieve implementation. use npl1Err and npl2Err to get two angle differences. (res, _) = angleCos npl1 npl2 - (npl1, _) = normalize pl1 - (npl2, _) = normalize pl2 + (npl1, _) = normalizeL pl1 + (npl2, _) = normalizeL pl2 -- | Find the cosine of the angle between the two lines. results in a value that is ~+1 when the first line points to the "left" of the second given line, and ~-1 when "right". angleCos :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, UlpSum) angleCos l1 l2 @@ -187,7 +186,7 @@ distancePPointToPLineWithErr point line (linePoint, lpErr) = fromJust $ canonicalizeIntersectionWithErr (PLine2 lvec) (PLine2 perpLine) ulpTotal = sumErrVals plMulErr <> sumErrVals plAddErr {- <> resErr -} <> newPLineErr <> lpErr foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(GVec vals) -> vals) $ vecOfP $ point - (NPLine2 nplvec,_) = normalize line + (NPLine2 nplvec,_) = normalizeL line -- | Determine if two points are on the same side of a given line. @@ -217,8 +216,8 @@ distanceBetweenPLinesWithErr line1 line2 = (ideal, resUlpSum) (likeRes, (likeMulErr, likeAddErr)) = p1 ⎣+ p2 p1 = vecOfL $ forceBasisOfL npl1 p2 = vecOfL $ forceBasisOfL npl2 - (npl1, _) = normalize line1 - (npl2, _) = normalize line2 + (npl1, _) = normalizeL line1 + (npl2, _) = normalizeL line2 -- | A checker, to ensure two Projective Lines are going the same direction, and are parallel. -- FIXME: precision on inputs? @@ -248,13 +247,13 @@ pPointOnPerpWithErr line ppoint d = (PPoint2 res, res = motor•pvec•reverseGVec motor (perpLine, (plMulErr,plAddErr))= lvec ⨅+ pvec lvec = vecOfL $ forceBasisOfL npl - (npl,lErr) = normalize line + (npl,_) = normalizeL line pvec = vecOfP $ forceBasisOfP ppoint motor = addVecPairWithoutErr (perpLine • gaIScaled) (GVec [GVal 1 (singleton G0)]) -- I, in this geometric algebra system. we multiply it times d/2, to shorten the number of multiples we have to do when creating the motor. gaIScaled = GVec [GVal (d/2) (fromList [GEZero 1, GEPlus 1, GEPlus 2])] gaIErr = UlpSum $ abs $ realToFrac $ doubleUlp $ d/2 - ulpTotal = sumErrVals plMulErr <> sumErrVals plAddErr <> gaIErr <>lErr + ulpTotal = sumErrVals plMulErr <> sumErrVals plAddErr <> gaIErr -- | Translate a point a given distance away from where it is, rotating it a given amount clockwise (in radians) around it's original location, with 0 degrees being aligned to the X axis. translateRotatePPoint2 :: (ProjectivePoint2 a) => a -> ℝ -> ℝ -> PPoint2 diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index 3faa77c50..20e5c7bfe 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -45,7 +45,6 @@ module Graphics.Slicer.Math.PGAPrimitives flipL, forceBasisOfL, intersect2PL, - normalize, normalizeL, normOfL, sqNormOfL, @@ -154,7 +153,6 @@ class ProjectiveLine2 a where flipL :: a -> a forceBasisOfL :: a -> a intersect2PL :: (ProjectiveLine2 b) => a -> b -> (PPoint2, (PLine2Err, PLine2Err, PPoint2Err)) - normalize :: a -> (NPLine2, UlpSum) normalizeL :: a -> (NPLine2, PLine2Err) normOfL :: a -> (ℝ, PLine2Err) sqNormOfL :: a -> (ℝ, UlpSum) @@ -169,7 +167,6 @@ instance ProjectiveLine2 NPLine2 where flipL l = flipProjectiveLine l forceBasisOfL l = forceProjectiveLineBasis l intersect2PL l1 l2 = intersectionOfProjectiveLinesWithErr l1 l2 - normalize l = (l, mempty) normalizeL l = (l, mempty) normOfL l = normOfProjectiveLineWithErr l sqNormOfL l = sqNormOfProjectiveLineWithErr l @@ -184,9 +181,6 @@ instance ProjectiveLine2 PLine2 where flipL l = flipProjectiveLine l forceBasisOfL l = forceProjectiveLineBasis l intersect2PL l1 l2 = intersectionOfProjectiveLinesWithErr l1 l2 - normalize l = crushErr $ normalizeProjectiveLineWithErr l - where - crushErr (res, PLine2Err _ _ c d _ _) = (res, c <> d) normalizeL l = normalizeProjectiveLineWithErr l normOfL l = normOfProjectiveLineWithErr l sqNormOfL l = sqNormOfProjectiveLineWithErr l diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index deee6012c..b436598f7 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -59,7 +59,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(GEZero, GEPlu import Graphics.Slicer.Math.Lossy (angleBetween, canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenPLines, distancePPointToPLine, eToCPPoint2, eToPLine2, getFirstArc, join2PPoint2, normalizePLine2, pPointOnPerp) -- Our 2D Projective Geometric Algebra library. -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PLine2Err(PLine2Err), canonicalize, pPointBetweenPPointsWithErr, distance2PP, distancePPointToPLineWithErr, eToPLine2WithErr, eToPL, eToPPoint2, intersect2PL, translateL, translateRotatePPoint2, angleBetween2PL, flipL, join2PP, makePPoint2, normalize, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, distancePPointToPLineWithErr, pPointOnPerpWithErr, outOf, pPointOf, outputIntersectsLineSeg, pPointBetweenPPointsWithErr) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PLine2Err(PLine2Err), canonicalize, pPointBetweenPPointsWithErr, distance2PP, distancePPointToPLineWithErr, eToPLine2WithErr, eToPL, eToPPoint2, intersect2PL, translateL, translateRotatePPoint2, angleBetween2PL, flipL, join2PP, makePPoint2, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, distancePPointToPLineWithErr, pPointOnPerpWithErr, outOf, pPointOf, outputIntersectsLineSeg, pPointBetweenPPointsWithErr) -- The primitives of our PGA only library, and error estimation code. @@ -507,14 +507,14 @@ prop_QuadBisectorCrosses rawX1 rawY1 rawX2 rawY2 <> show eNode <> "\n" <> "(" <> show x3 <> "," <> show y3 <> ")\n" where - intersect1 = intersectsWithErr (Right (PLine2 bisector1, UlpSum bisector1Err)) (Left (lineSeg1, mempty)) - intersect2 = intersectsWithErr (Right (PLine2 bisector1, UlpSum bisector1Err)) (Left (lineSeg2, mempty)) + intersect1 = intersectsWithErr (Right (PLine2 bisector1, mempty)) (Left (lineSeg1, mempty)) + intersect2 = intersectsWithErr (Right (PLine2 bisector1, mempty)) (Left (lineSeg2, mempty)) intersect3 = outputIntersectsLineSeg eNode lineSeg1 intersect4 = outputIntersectsLineSeg eNode lineSeg2 -- note that our bisector always intersects the origin. - (bisector, UlpSum bisectorUlp) = eToPLine2WithErr $ makeLineSeg (Point2 (0,0)) (Point2 (x3,y3)) - (NPLine2 bisector1, UlpSum bisector1Ulp) = normalize bisector - bisector1Err = bisectorUlp + bisector1Ulp + (bisector, bisectorRawErr) = eToPL $ makeLineSeg (Point2 (0,0)) (Point2 (x3,y3)) + (NPLine2 bisector1, bisector1NormErr) = normalizeL bisector + bisector1Err = bisectorRawErr <> bisector1NormErr bisector2 = getFirstArc (Point2 (x1,y1)) (Point2 (0,0)) (Point2 (x2,y2)) eNode = makeENode (Point2 (x1,y1)) (Point2 (0,0)) (Point2 (x2,y2)) -- X1, Y1 and X2 forced uniqueness. additionally, forced "not 180 degree opposition). @@ -557,18 +557,16 @@ prop_QuadBisectorCrossesMultiple rawX1 rawY1 rawX2 rawY2 rawTimes <> show bisector1 <> "\n" <> show eNode <> "\n" <> show (angleBetween (normalizePLine2 $ outOf eNode) (normalizePLine2 $ PLine2 bisector1)) <> "\n" - <> show bisector1Err <> "\n" <> "(" <> show x3 <> "," <> show y3 <> ")\n" <> "(" <> show x4 <> "," <> show y4 <> ")\n" where - intersect1 = intersectsWithErr (Right (PLine2 bisector1, UlpSum bisector1Err)) (Left (lineSeg1, mempty)) - intersect2 = intersectsWithErr (Right (PLine2 bisector1, UlpSum bisector1Err)) (Left (lineSeg2, mempty)) + intersect1 = intersectsWithErr (Right (PLine2 bisector1, mempty)) (Left (lineSeg1, mempty)) + intersect2 = intersectsWithErr (Right (PLine2 bisector1, mempty)) (Left (lineSeg2, mempty)) intersect3 = outputIntersectsLineSeg eNode lineSeg1 intersect4 = outputIntersectsLineSeg eNode lineSeg2 -- note that our bisector always intersects the origin. - (NPLine2 bisector1, UlpSum bisector1Ulp) = normalize bisector + (NPLine2 bisector1, bisector1ErrRaw) = normalizeL bisector (bisector, UlpSum bisectorUlp) = eToPLine2WithErr $ makeLineSeg (Point2 (0,0)) (Point2 (x3,y3)) - bisector1Err = bisectorUlp + bisector1Ulp eNode = makeENode (Point2 (x1,y1)) (Point2 (0,0)) (Point2 (x2,y2)) -- X1, Y1 and X2 forced uniqueness. additionally, forced "not 180 degree opposition). x1,y1,x2,y2,times :: ℝ @@ -1232,10 +1230,10 @@ prop_PLineWithinErrRange1 x1 y1 rawX2 rawY2 (distance2, UlpSum distance2Err) = distancePPointToPLineWithErr pPoint2 nPLine pPoint1 = makePPoint2 x1 y1 pPoint2 = makePPoint2 x2 y2 - (nPLine, UlpSum nPLineErr) = normalize pLine + (nPLine, _) = normalizeL pLine (pLine, UlpSum ulpPLine) = eToPLine2WithErr $ makeLineSeg (Point2 (x1,y1)) (Point2 (x2,y2)) - ulpTotal1 = ulpPLine + distance1Err + nPLineErr - ulpTotal2 = ulpPLine + distance2Err + nPLineErr + ulpTotal1 = ulpPLine + distance1Err + ulpTotal2 = ulpPLine + distance2Err -- make sure we do not try to create a 0 length line segment. (x2,y2) | x1 == rawX2 && y1 == rawY2 = if x1 == 0 && y1 == 0 @@ -1256,7 +1254,6 @@ prop_PLineWithinErrRange2 x1 y1 rawX2 rawY2 <> "distance1Err: " <> show distance1Err <> "\n" <> "distance2Err: " <> show distance2Err <> "\n" <> "PLine1ULP: " <> show ulpPLine <> "\n" - <> "PLine1NormULP: " <> show normErr <> "\n" <> "PLine1: " <> show pLine1 <> "\n" <> "NPLine1(vec): " <> show lvec <> "\n" <> "PPoint1: " <> show pPoint1 <> "\n" @@ -1267,7 +1264,7 @@ prop_PLineWithinErrRange2 x1 y1 rawX2 rawY2 (CPPoint2 pPoint1) = makePPoint2 x1 y1 (CPPoint2 pPoint2) = makePPoint2 x2 y2 (pLine1, UlpSum ulpPLine) = join2PP (CPPoint2 pPoint1) (CPPoint2 pPoint2) - (NPLine2 lvec, UlpSum normErr) = normalize pLine1 + (NPLine2 lvec, _) = normalizeL pLine1 ulpTotal1 = ulpPLine + distance1Err ulpTotal2 = ulpPLine + distance2Err -- make sure we do not try to create a 0 length line segment. From cf7a233afa3ef6cf83a7cce43e416a63fa6c4d49 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Tue, 25 Oct 2022 11:33:56 +0000 Subject: [PATCH 038/206] normalize names of projective line handling functions. --- Graphics/Slicer/Math/PGAPrimitives.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index 20e5c7bfe..37d15aacc 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -162,15 +162,15 @@ class ProjectiveLine2 a where instance ProjectiveLine2 NPLine2 where angleBetween2PL l1 l2 = crushErr $ angleBetweenWithErr l1 l2 where - crushErr (res, (n1,n2,_,ulpSum)) = (res, (n1,n2,ulpSum)) + crushErr (res, (n1,n2,_,resErr)) = (res, (n1,n2,resErr)) consLikeL _ = NPLine2 flipL l = flipProjectiveLine l forceBasisOfL l = forceProjectiveLineBasis l intersect2PL l1 l2 = intersectionOfProjectiveLinesWithErr l1 l2 normalizeL l = (l, mempty) normOfL l = normOfProjectiveLineWithErr l - sqNormOfL l = sqNormOfProjectiveLineWithErr l - translateL l d = (\(r,(PLine2Err _ _ _ _ t _)) -> (r,t)) $ translateProjectiveLine2WithErr l d + sqNormOfL l = squaredNormOfProjectiveLineWithErr l + translateL l d = (\(r,(PLine2Err _ _ _ _ t _)) -> (r,t)) $ translateProjectiveLineWithErr l d vecOfL (NPLine2 v) = v instance ProjectiveLine2 PLine2 where @@ -183,8 +183,8 @@ instance ProjectiveLine2 PLine2 where intersect2PL l1 l2 = intersectionOfProjectiveLinesWithErr l1 l2 normalizeL l = normalizeProjectiveLineWithErr l normOfL l = normOfProjectiveLineWithErr l - sqNormOfL l = sqNormOfProjectiveLineWithErr l - translateL l d = (\(r,(PLine2Err _ _ _ _ t _)) -> (r,t)) $ translateProjectiveLine2WithErr l d + sqNormOfL l = squaredNormOfProjectiveLineWithErr l + translateL l d = (\(r,(PLine2Err _ _ _ _ t _)) -> (r,t)) $ translateProjectiveLineWithErr l d vecOfL (PLine2 v) = v -- | the two types of error of a projective line. @@ -309,8 +309,8 @@ normOfProjectiveLineWithErr line = (res, resErr) (sqNormOfPLine2, sqNormUlp) = sqNormOfL line -- | Find the squared norm of a given Projective Line. -sqNormOfProjectiveLineWithErr :: (ProjectiveLine2 a) => a -> (ℝ, UlpSum) -sqNormOfProjectiveLineWithErr line = (res, ulpTotal) +squaredNormOfProjectiveLineWithErr :: (ProjectiveLine2 a) => a -> (ℝ, UlpSum) +squaredNormOfProjectiveLineWithErr line = (res, ulpTotal) where res = a*a+b*b a = valOf 0 $ getVal [GEPlus 1] vals @@ -323,8 +323,8 @@ sqNormOfProjectiveLineWithErr line = (res, ulpTotal) -- | Translate a line a given distance along it's perpendicular bisector. -- Uses the property that translation of a line is expressed on the GEZero component. -translateProjectiveLine2WithErr :: (ProjectiveLine2 a) => a -> ℝ -> (PLine2, PLine2Err) -translateProjectiveLine2WithErr line d = (PLine2 res, normErr <> PLine2Err resErrs mempty mempty mempty tUlp mempty) +translateProjectiveLineWithErr :: (ProjectiveLine2 a) => a -> ℝ -> (PLine2, PLine2Err) +translateProjectiveLineWithErr line d = (PLine2 res, normErr <> PLine2Err resErrs mempty mempty mempty tUlp mempty) where (res, resErrs) = addVecPairWithErr m $ vecOfL line m = GVec [GVal tAdd (singleton (GEZero 1))] From 45b875547881b3074e8795cf8a692730398af3a5 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Thu, 27 Oct 2022 16:49:49 +0000 Subject: [PATCH 039/206] move pPointBetweenPPointsWithErr into our typeclass, renaming it interpolate2PP. --- Graphics/Slicer/Math/Lossy.hs | 4 ++-- Graphics/Slicer/Math/PGA.hs | 24 ++++-------------------- Graphics/Slicer/Math/PGAPrimitives.hs | 22 +++++++++++++++++++++- tests/Math/PGA.hs | 6 +++--- 4 files changed, 30 insertions(+), 26 deletions(-) diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index 1eecbd584..ecef168a9 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -48,7 +48,7 @@ import Graphics.Slicer.Math.Definitions (LineSeg, Point2, makeLineSeg) import Graphics.Slicer.Math.Arcs (getFirstArcWithErr, getInsideArcWithErr) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PPoint2, ProjectiveLine2, ProjectivePoint2, angleBetween2PL, canonicalize, distance2PP, distanceBetweenPLinesWithErr, distancePPointToPLineWithErr, eToPLine2WithErr, eToPPoint2, join2PP, normalizeL, pPointBetweenPPointsWithErr, pPointOnPerpWithErr, pToEP, translateL) +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PPoint2, ProjectiveLine2, ProjectivePoint2, angleBetween2PL, canonicalize, distance2PP, distanceBetweenPLinesWithErr, distancePPointToPLineWithErr, eToPLine2WithErr, eToPPoint2, interpolate2PP, join2PP, normalizeL, pPointOnPerpWithErr, pToEP, translateL) angleBetween :: NPLine2 -> NPLine2 -> ℝ angleBetween nPLine1 nPLine2 = fst $ angleBetween2PL (nPLine1, mempty) (nPLine2, mempty) @@ -108,7 +108,7 @@ pToEPoint2 pp = fst $ pToEP pp -- | Find a point somewhere along the line between the two points given. -- requires two weights. the ratio of these weights determines the position of the found points, E.G: (2/3,1/3) is 1/3 the way FROM the stopPoint, and 2/3 the way FROM the startPoint. weights can sum to anything. pPointBetweenPPoints :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> ℝ -> ℝ -> PPoint2 -pPointBetweenPPoints startOfSeg stopOfSeg weight1 weight2 = fst $ pPointBetweenPPointsWithErr startOfSeg stopOfSeg weight1 weight2 +pPointBetweenPPoints startOfSeg stopOfSeg weight1 weight2 = fst $ interpolate2PP startOfSeg stopOfSeg weight1 weight2 -- | Find a projective point a given distance along a line perpendicularly bisecting the given line at a given point. pPointOnPerp :: (ProjectiveLine2 a, ProjectivePoint2 b) => a -> b -> ℝ -> PPoint2 diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 7dfe90576..fd64f48bf 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -46,6 +46,7 @@ module Graphics.Slicer.Math.PGA( eToPPoint2, eToPL, flipL, + interpolate2PP, intersect2PL, intersectsWith, intersectsWithErr, @@ -54,7 +55,6 @@ module Graphics.Slicer.Math.PGA( normalizeL, outputIntersectsLineSeg, pLineIsLeft, - pPointBetweenPPointsWithErr, pPointOnPerpWithErr, pPointsOnSameSideOfPLine, pToEP, @@ -86,11 +86,11 @@ import Graphics.Slicer.Definitions (ℝ) import Graphics.Slicer.Math.Definitions (Point2(Point2), LineSeg(LineSeg), addPoints, startPoint, endPoint, distance) -import Graphics.Slicer.Math.GeometricAlgebra (GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎣+), (⎤+), (⨅), (⨅+), (∧), (•), addValWithoutErr, addVecPairWithErr, addVecPairWithoutErr, getVal, mulScalarVecWithErr, sumErrVals, ulpVal, valOf) +import Graphics.Slicer.Math.GeometricAlgebra (GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎣+), (⎤+), (⨅), (⨅+), (∧), (•), addValWithoutErr, addVecPairWithoutErr, getVal, mulScalarVecWithErr, sumErrVals, ulpVal, valOf) import Graphics.Slicer.Math.Line (combineLineSegs) -import Graphics.Slicer.Math.PGAPrimitives(Arcable(errOfOut, hasArc, outOf), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(angleBetween2PL, flipL, forceBasisOfL, intersect2PL, normalizeL, normOfL, translateL, vecOfL), ProjectivePoint2(canonicalize, distance2PP, forceBasisOfP, idealNormOfP, join2PP, join2PPWithErr, pToEP, vecOfP), xIntercept, yIntercept) +import Graphics.Slicer.Math.PGAPrimitives(Arcable(errOfOut, hasArc, outOf), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(angleBetween2PL, flipL, forceBasisOfL, intersect2PL, normalizeL, normOfL, translateL, vecOfL), ProjectivePoint2(canonicalize, distance2PP, forceBasisOfP, idealNormOfP, interpolate2PP, join2PP, join2PPWithErr, pToEP, vecOfP), xIntercept, yIntercept) -- Our 2D plane coresponds to a Clifford algebra of 2,0,1. @@ -156,22 +156,6 @@ pLineIsLeft pl1 pl2 lvec1 = vecOfL l1 lvec2 = vecOfL l2 --- FIXME: automatically raise addVecRes to a CPPoint2 if it turns out to be canonical? -pPointBetweenPPointsWithErr :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> ℝ -> ℝ -> (PPoint2, UlpSum) -pPointBetweenPPointsWithErr startP stopP weight1 weight2 - | isNothing foundVal = error "tried to generate an ideal point?" - | otherwise = (PPoint2 addVecRes, ulpSum) - where - ulpSum = sumErrVals addVecResErr <> sumErrVals weighedStartErr <> sumErrVals weighedStopErr - foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(GVec vals) -> vals) addVecRes - (addVecRes, addVecResErr) = addVecPairWithErr weighedStart weighedStop - (weighedStart, weighedStartErr) = mulScalarVecWithErr weight1 rawStartPoint - (weighedStop, weighedStopErr) = mulScalarVecWithErr weight2 rawStopPoint - rawStartPoint = vecOfP startP' - rawStopPoint = vecOfP stopP' - (startP', _) = canonicalize startP - (stopP', _) = canonicalize stopP - -- FIXME: use the distance to increase ULP appropriately? distancePPointToPLineWithErr :: (ProjectivePoint2 a, ProjectiveLine2 b) => a -> b -> (ℝ, UlpSum) distancePPointToPLineWithErr point line @@ -423,7 +407,7 @@ onSegment ls i startUlp endUlp = (midDistance, UlpSum midDistanceErr) = distance2PP mid i (endDistance, UlpSum endDistanceErr) = distance2PP end i start = eToPPoint2 $ startPoint ls - (mid, UlpSum midErr) = pPointBetweenPPointsWithErr start end 0.5 0.5 + (mid, UlpSum midErr) = interpolate2PP start end 0.5 0.5 end = eToPPoint2 $ endPoint ls lengthOfSegment = distance (startPoint ls) (endPoint ls) startFudgeFactor, midFudgeFactor, endFudgeFactor :: ℝ diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index 37d15aacc..3b2757b7d 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -56,6 +56,7 @@ module Graphics.Slicer.Math.PGAPrimitives distance2PP, forceBasisOfP, idealNormOfP, + interpolate2PP, join2PP, join2PPWithErr, pToEP, @@ -85,7 +86,7 @@ import Graphics.Slicer.Definitions (ℝ) import Graphics.Slicer.Math.Definitions (Point2(Point2)) -import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎣+), (⎤+), addErr, addValWithoutErr, addVecPairWithErr, divVecScalarWithErr, eValOf, getVal, scalarPart, sumErrVals, valOf) +import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎣+), (⎤+), addErr, addValWithoutErr, addVecPairWithErr, divVecScalarWithErr, eValOf, getVal, mulScalarVecWithErr, scalarPart, sumErrVals, valOf) -------------------------------- --- common support functions --- @@ -463,6 +464,7 @@ class (Show a) => ProjectivePoint2 a where distance2PP :: (ProjectivePoint2 b) => a -> b -> (ℝ, UlpSum) forceBasisOfP :: a -> a idealNormOfP :: a -> (ℝ, UlpSum) + interpolate2PP :: (ProjectivePoint2 b) => a -> b -> ℝ -> ℝ -> (PPoint2, UlpSum) join2PP :: (ProjectivePoint2 b) => a -> b -> (PLine2, UlpSum) join2PPWithErr :: (ProjectivePoint2 b) => a -> b -> (PLine2, PLine2Err) pToEP :: a -> (Point2, UlpSum) @@ -476,6 +478,7 @@ instance ProjectivePoint2 PPoint2 where crushErr a = a forceBasisOfP a = forceProjectivePointBasis a idealNormOfP a = idealNormPPoint2WithErr a + interpolate2PP p1 p2 = pPointBetweenPPointsWithErr p1 p2 join2PP a b = crushErr $ join2ProjectivePointsWithErr a b where crushErr (res, (PPoint2Err _ cp1Errs _ _ _ _ _ @@ -497,6 +500,7 @@ instance ProjectivePoint2 CPPoint2 where crushErr a = a forceBasisOfP p = forceProjectivePointBasis p idealNormOfP p = idealNormPPoint2WithErr p + interpolate2PP p1 p2 = pPointBetweenPPointsWithErr p1 p2 join2PP a b = crushErr $ join2ProjectivePointsWithErr a b where crushErr (res, (PPoint2Err _ cp1Errs _ _ _ _ _ @@ -590,6 +594,22 @@ join2ProjectivePointsWithErr pp1 pp2 = (PLine2 res, (cp1, cp1Errs) = canonicalizePPoint2WithErr pp1 (cp2, cp2Errs) = canonicalizePPoint2WithErr pp2 +-- FIXME: automatically raise addVecRes to a CPPoint2 if it turns out to be canonical? +pPointBetweenPPointsWithErr :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> ℝ -> ℝ -> (PPoint2, UlpSum) +pPointBetweenPPointsWithErr startP stopP weight1 weight2 + | isNothing foundVal = error "tried to generate an ideal point?" + | otherwise = (PPoint2 addVecRes, ulpSum) + where + ulpSum = sumErrVals addVecResErr <> sumErrVals weighedStartErr <> sumErrVals weighedStopErr + foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(GVec vals) -> vals) addVecRes + (addVecRes, addVecResErr) = addVecPairWithErr weighedStart weighedStop + (weighedStart, weighedStartErr) = mulScalarVecWithErr weight1 rawStartPoint + (weighedStop, weighedStopErr) = mulScalarVecWithErr weight2 rawStopPoint + rawStartPoint = vecOfP startP' + rawStopPoint = vecOfP stopP' + (startP', _) = canonicalize startP + (stopP', _) = canonicalize stopP + -- | Maybe create a euclidian point from a projective point. Will fail if the projective point is ideal. projectivePointToPoint2 :: (ProjectivePoint2 a) => a -> Maybe (Point2, PPoint2Err) projectivePointToPoint2 ppoint diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index b436598f7..0898e54f5 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -59,7 +59,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(GEZero, GEPlu import Graphics.Slicer.Math.Lossy (angleBetween, canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenPLines, distancePPointToPLine, eToCPPoint2, eToPLine2, getFirstArc, join2PPoint2, normalizePLine2, pPointOnPerp) -- Our 2D Projective Geometric Algebra library. -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PLine2Err(PLine2Err), canonicalize, pPointBetweenPPointsWithErr, distance2PP, distancePPointToPLineWithErr, eToPLine2WithErr, eToPL, eToPPoint2, intersect2PL, translateL, translateRotatePPoint2, angleBetween2PL, flipL, join2PP, makePPoint2, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, distancePPointToPLineWithErr, pPointOnPerpWithErr, outOf, pPointOf, outputIntersectsLineSeg, pPointBetweenPPointsWithErr) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PLine2Err(PLine2Err), canonicalize, distance2PP, distancePPointToPLineWithErr, eToPLine2WithErr, eToPL, eToPPoint2, interpolate2PP, intersect2PL, translateL, translateRotatePPoint2, angleBetween2PL, flipL, join2PP, makePPoint2, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, distancePPointToPLineWithErr, pPointOnPerpWithErr, outOf, pPointOf, outputIntersectsLineSeg) -- The primitives of our PGA only library, and error estimation code. @@ -404,7 +404,7 @@ prop_perpAt90Degrees x y rawX2 y2 rawD <> "angle2Err: " <> show angle2Err <> "\n" where (angle2, (_,_, angle2Err)) = angleBetween2PL (normedPLine3, norm3Err) (normedPLine4, norm4Err) - (PPoint2 rawBisectorStart, bisectorStartErr) = pPointBetweenPPointsWithErr sourceStart sourceEnd 0.5 0.5 + (PPoint2 rawBisectorStart, bisectorStartErr) = interpolate2PP sourceStart sourceEnd 0.5 0.5 (bisectorEndRaw, bisectorEndRawErr) = pPointOnPerpWithErr pline4 (PPoint2 rawBisectorStart) d (bisectorEnd, bisectorEndErr) = canonicalize bisectorEndRaw (pline3, pline3Err) = join2PP (CPPoint2 rawBisectorStart) bisectorEnd @@ -921,7 +921,7 @@ prop_TriangleNoDivides centerX centerY rawRadians rawDists = findDivisions trian pLine = eToPLine2 firstSeg firstPoints = firstPointPairOfContour triangle (p1, p2) = firstPointPairOfContour triangle - (myMidPoint,_) = pPointBetweenPPointsWithErr (eToPPoint2 p1) (eToPPoint2 p2) 0.5 0.5 + (myMidPoint,_) = interpolate2PP (eToPPoint2 p1) (eToPPoint2 p2) 0.5 0.5 -- we normalize this for Ganja.js. (NPLine2 pLineToInside) = normalizePLine2 $ join2PPoint2 myMidPoint innerPoint (NPLine2 pLineToOutside) = normalizePLine2 $ join2PPoint2 innerPoint $ (\(CPPoint2 a) -> PPoint2 a) $ eToPPoint2 outsidePoint From a021514e57a439bd82ca1dcd85d26ab15086b121 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 29 Oct 2022 11:54:57 +0000 Subject: [PATCH 040/206] add fuzzinessOfL and pLineErrAtPPoint, and clean up the types of several ProjectiveLine instances to use PLine2Err instead of UlpSum --- Graphics/Slicer/Math/Contour.hs | 4 +- Graphics/Slicer/Math/Ganja.hs | 16 ++-- Graphics/Slicer/Math/Lossy.hs | 8 +- Graphics/Slicer/Math/PGA.hs | 32 +++---- Graphics/Slicer/Math/PGAPrimitives.hs | 91 +++++++++++++++----- Graphics/Slicer/Math/Skeleton/Cells.hs | 4 +- Graphics/Slicer/Math/Skeleton/Definitions.hs | 8 +- tests/Math/PGA.hs | 78 ++++++++--------- 8 files changed, 143 insertions(+), 98 deletions(-) diff --git a/Graphics/Slicer/Math/Contour.hs b/Graphics/Slicer/Math/Contour.hs index 02067d7d9..36feb1f00 100644 --- a/Graphics/Slicer/Math/Contour.hs +++ b/Graphics/Slicer/Math/Contour.hs @@ -52,7 +52,7 @@ import Graphics.Slicer.Math.Intersections (contourIntersectionCount, noIntersect import Graphics.Slicer.Math.Lossy (join2PPoint2, pPointBetweenPPoints, pToEPoint2) -import Graphics.Slicer.Math.PGA (PPoint2, eToPPoint2, eToPLine2WithErr, pLineIsLeft, pPointOnPerpWithErr) +import Graphics.Slicer.Math.PGA (PPoint2, eToPPoint2, eToPL, pLineIsLeft, pPointOnPerpWithErr) -- Unapologetically ripped from ImplicitCAD. -- Added the ability to look at line segments backwards. @@ -232,7 +232,7 @@ insideIsLeft contour myMidPoint = pPointBetweenPPoints (eToPPoint2 p1) (eToPPoint2 p2) 0.5 0.5 pLineToInside = join2PPoint2 myMidPoint innerPoint innerPoint = fromJust $ innerContourPoint contour - (pline1,_) = eToPLine2WithErr $ makeLineSeg p1 p2 + (pline1,_) = eToPL $ makeLineSeg p1 p2 -- | Find a point on the interior of a given contour, on the perpendicular bisector of the first line segment, a given distance away from the line segment. innerContourPoint :: Contour -> Maybe PPoint2 diff --git a/Graphics/Slicer/Math/Ganja.hs b/Graphics/Slicer/Math/Ganja.hs index 3c3b44afe..3ad64632c 100644 --- a/Graphics/Slicer/Math/Ganja.hs +++ b/Graphics/Slicer/Math/Ganja.hs @@ -110,11 +110,11 @@ import Graphics.Slicer.Math.Contour (makePointContour, maybeFlipContour, pointsO import Graphics.Slicer.Math.Definitions (Contour, Point2(Point2), LineSeg, endPoint, mapWithFollower, startPoint, makeLineSeg) -import Graphics.Slicer.Math.GeometricAlgebra (GNum(GEPlus, GEZero), GVec(GVec), getVal, valOf, UlpSum) +import Graphics.Slicer.Math.GeometricAlgebra (GNum(GEPlus, GEZero), GVec(GVec), getVal, valOf) import Graphics.Slicer.Math.Lossy (eToPLine2, join2PPoint2, normalizePLine2, pPointBetweenPPoints, pToEPoint2) -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), PLine2(PLine2), PPoint2(PPoint2), PLine2Err, eToPLine2WithErr, eToPL, eToPPoint2, flipL, normalizeL, translateRotatePPoint2, outOf, pPointOf, NPLine2(NPLine2)) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), PLine2(PLine2), PPoint2(PPoint2), PLine2Err, eToPL, eToPPoint2, flipL, normalizeL, translateRotatePPoint2, outOf, pPointOf, NPLine2(NPLine2)) import Graphics.Slicer.Math.Skeleton.Concave (makeENode, getOutsideArc) @@ -671,8 +671,8 @@ randomPLine :: ℝ -> ℝ -> NonZero ℝ -> NonZero ℝ -> PLine2 randomPLine x y dx dy = fst $ randomPLineWithErr x y dx dy -- | A helper function. constructs a random PLine. -randomPLineWithErr :: ℝ -> ℝ -> NonZero ℝ -> NonZero ℝ -> (PLine2, UlpSum) -randomPLineWithErr x y dx dy = eToPLine2WithErr $ makeLineSeg (Point2 (x, y)) (Point2 (coerce dx, coerce dy)) +randomPLineWithErr :: ℝ -> ℝ -> NonZero ℝ -> NonZero ℝ -> (PLine2, PLine2Err) +randomPLineWithErr x y dx dy = eToPL $ makeLineSeg (Point2 (x, y)) (Point2 (coerce dx, coerce dy)) -- | A helper function. constructs a random PLine. randomPL :: ℝ -> ℝ -> NonZero ℝ -> NonZero ℝ -> (PLine2, PLine2Err) @@ -684,12 +684,12 @@ randomLineSeg x y dx dy = makeLineSeg (Point2 (x, y)) (Point2 (dx,dy)) -- | A PLine that does not follow the X = Y line, and does not follow the other given line. -randomPLineThroughOrigin :: ℝ -> ℝ -> (PLine2, UlpSum) -randomPLineThroughOrigin x y = eToPLine2WithErr $ makeLineSeg (Point2 (x,y)) (Point2 (0,0)) +randomPLineThroughOrigin :: ℝ -> ℝ -> (PLine2, PLine2Err) +randomPLineThroughOrigin x y = eToPL $ makeLineSeg (Point2 (x,y)) (Point2 (0,0)) -- | A PLine that does not follow the X = Y line, and does not follow the other given line. -randomPLineThroughPoint :: ℝ -> ℝ -> ℝ -> (PLine2, UlpSum) -randomPLineThroughPoint x y d = eToPLine2WithErr $ makeLineSeg (Point2 (x,y)) (Point2 (d,d)) +randomPLineThroughPoint :: ℝ -> ℝ -> ℝ -> (PLine2, PLine2Err) +randomPLineThroughPoint x y d = eToPL $ makeLineSeg (Point2 (x,y)) (Point2 (d,d)) -- | A line segment ending at the origin. additionally, guaranteed not to be on the X = Y line. randomLineSegFromPointNotX1Y1 :: ℝ -> ℝ -> ℝ -> LineSeg diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index ecef168a9..5708491d2 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -48,7 +48,7 @@ import Graphics.Slicer.Math.Definitions (LineSeg, Point2, makeLineSeg) import Graphics.Slicer.Math.Arcs (getFirstArcWithErr, getInsideArcWithErr) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PPoint2, ProjectiveLine2, ProjectivePoint2, angleBetween2PL, canonicalize, distance2PP, distanceBetweenPLinesWithErr, distancePPointToPLineWithErr, eToPLine2WithErr, eToPPoint2, interpolate2PP, join2PP, normalizeL, pPointOnPerpWithErr, pToEP, translateL) +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PPoint2, ProjectiveLine2, ProjectivePoint2, angleBetween2PL, canonicalize, distance2PP, distanceBetweenPLinesWithErr, distancePPointToPLineWithErr, eToPL, eToPPoint2, interpolate2PP, join2PP, normalizeL, pPointOnPerpWithErr, pToEP, translateL) angleBetween :: NPLine2 -> NPLine2 -> ℝ angleBetween nPLine1 nPLine2 = fst $ angleBetween2PL (nPLine1, mempty) (nPLine2, mempty) @@ -73,11 +73,11 @@ eToCPPoint2 point = eToPPoint2 point -- | Create a normalized projective line from a euclidian line segment. eToNPLine2 :: LineSeg -> NPLine2 -eToNPLine2 l1 = fst $ normalizeL $ fst $ eToPLine2WithErr l1 +eToNPLine2 l1 = fst $ normalizeL $ fst $ eToPL l1 -- | Create an un-normalized projective line from a euclidian line segment. eToPLine2 :: LineSeg -> PLine2 -eToPLine2 l1 = fst $ eToPLine2WithErr l1 +eToPLine2 l1 = fst $ eToPL l1 -- | Get a PLine in the direction of the inside of the contour, at the angle bisector of the intersection of the line segment, and another segment from the end of the given line segment, toward the given point. getFirstArc :: Point2 -> Point2 -> Point2 -> PLine2 @@ -100,7 +100,7 @@ normalizePLine2 pl = fst $ normalizeL pl -- | Create a projective line from a pair of euclidian points. pLineFromEndpoints :: Point2 -> Point2 -> PLine2 -pLineFromEndpoints point1 point2 = fst $ eToPLine2WithErr $ makeLineSeg point1 point2 +pLineFromEndpoints point1 point2 = fst $ eToPL $ makeLineSeg point1 point2 pToEPoint2 :: (ProjectivePoint2 a) => a -> Point2 pToEPoint2 pp = fst $ pToEP pp diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index fd64f48bf..5f117e394 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -42,7 +42,6 @@ module Graphics.Slicer.Math.PGA( distance2PP, distanceBetweenPLinesWithErr, distancePPointToPLineWithErr, - eToPLine2WithErr, eToPPoint2, eToPL, flipL, @@ -90,7 +89,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (GNum(G0, GEPlus, GEZero), GVal(GVa import Graphics.Slicer.Math.Line (combineLineSegs) -import Graphics.Slicer.Math.PGAPrimitives(Arcable(errOfOut, hasArc, outOf), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(angleBetween2PL, flipL, forceBasisOfL, intersect2PL, normalizeL, normOfL, translateL, vecOfL), ProjectivePoint2(canonicalize, distance2PP, forceBasisOfP, idealNormOfP, interpolate2PP, join2PP, join2PPWithErr, pToEP, vecOfP), xIntercept, yIntercept) +import Graphics.Slicer.Math.PGAPrimitives(Arcable(errOfOut, hasArc, outOf), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(angleBetween2PL, flipL, forceBasisOfL, intersect2PL, normalizeL, normOfL, translateL, vecOfL), ProjectivePoint2(canonicalize, distance2PP, forceBasisOfP, idealNormOfP, interpolate2PP, join2PP, pToEP, vecOfP), xIntercept, yIntercept) -- Our 2D plane coresponds to a Clifford algebra of 2,0,1. @@ -168,7 +167,7 @@ distancePPointToPLineWithErr point line lvec = vecOfL $ forceBasisOfL (PLine2 nplvec) npvec = vecOfP $ forceBasisOfP point (linePoint, lpErr) = fromJust $ canonicalizeIntersectionWithErr (PLine2 lvec) (PLine2 perpLine) - ulpTotal = sumErrVals plMulErr <> sumErrVals plAddErr {- <> resErr -} <> newPLineErr <> lpErr + ulpTotal = sumErrVals plMulErr <> sumErrVals plAddErr <> lpErr foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(GVec vals) -> vals) $ vecOfP $ point (NPLine2 nplvec,_) = normalizeL line @@ -246,7 +245,7 @@ translateRotatePPoint2 ppoint d rotation = PPoint2 $ translator•pvec•reverse pvec = vecOfP ppoint xLineThroughPPoint2 = (pvec ⨅ xLineVec) • pvec where - xLineVec = vecOfL $ forceBasisOfL $ fst $ eToPLine2WithErr (LineSeg (Point2 (0,0)) (Point2 (1,0))) + xLineVec = vecOfL $ forceBasisOfL $ fst $ eToPL (LineSeg (Point2 (0,0)) (Point2 (1,0))) angledLineThroughPPoint2 = vecOfL $ forceBasisOfL $ PLine2 $ rotator•xLineThroughPPoint2•reverseGVec rotator where rotator = addVecPairWithoutErr (fst $ mulScalarVecWithErr (sin $ rotation/2) pvec) (GVec [GVal (cos $ rotation/2) (singleton G0)]) @@ -311,13 +310,13 @@ intersectsWithErr (Left l1@(rawL1,_)) (Right pl1@(rawPL1, _)) = pLineIntersectsL ulpScale :: ℝ ulpScale = realToFrac $ ulpMultiplier * (abs (realToFrac angle) + angleErr) (angle, (_,_, UlpSum angleErr)) = angleBetween2PL (rawPL1, mempty) (pl2, mempty) - (pl2, _) = eToPLine2WithErr rawL1 + (pl2, _) = eToPL rawL1 intersectsWithErr (Right pl1@(rawPL1, _)) (Left l1@(rawL1,_)) = pLineIntersectsLineSeg pl1 l1 ulpScale where ulpScale :: ℝ ulpScale = realToFrac $ ulpMultiplier * (abs (realToFrac angle) + angleErr) (angle, (_,_, UlpSum angleErr)) = angleBetween2PL (rawPL1, mempty) (pl2, mempty) - (pl2, _) = eToPLine2WithErr rawL1 + (pl2, _) = eToPL rawL1 -- | Check if/where a line segment and a PLine intersect. pLineIntersectsLineSeg :: (PLine2, UlpSum) -> (LineSeg, UlpSum) -> ℝ -> Either Intersection PIntersection @@ -330,7 +329,7 @@ pLineIntersectsLineSeg (pl1, UlpSum pl1Err) (l1, UlpSum l1Err) ulpScale | hasIntersection && valOf 0 foundVal == 0 = error "intersection, but cannot cannonicalize." | hasIntersection && startDistance <= ulpStartSum = Left $ HitStartPoint l1 | hasIntersection && endDistance <= ulpEndSum = Left $ HitEndPoint l1 - | hasIntersection = Right $ IntersectsIn rawIntersection (UlpSum $ realToFrac ulpStartSum, UlpSum $ realToFrac ulpEndSum, UlpSum pl1Err, UlpSum pl2Err, mempty, UlpSum rawIntersectionErr) + | hasIntersection = Right $ IntersectsIn rawIntersection (UlpSum $ realToFrac ulpStartSum, UlpSum $ realToFrac ulpEndSum, UlpSum pl1Err, mempty, mempty, UlpSum rawIntersectionErr) | hasRawIntersection = Left $ NoIntersection rawIntersection (UlpSum $ realToFrac ulpStartSum, UlpSum $ realToFrac ulpEndSum, mempty, mempty) | otherwise = Left $ NoIntersection ((\(PPoint2 v) -> CPPoint2 v) rawIntersect) (mempty, mempty, mempty, mempty) where @@ -343,7 +342,7 @@ pLineIntersectsLineSeg (pl1, UlpSum pl1Err) (l1, UlpSum l1Err) ulpScale ulpEndSum = realToFrac $ ulpTotal+endDistanceErr -- | the sum of all ULPs. used to expand the hitcircle of an endpoint. -- Note: we do not use rawIntersectionErr here. - ulpTotal = pl1Err + pl2Err + l1Err + ulpTotal = l1Err dumpULPs = "pl1Err: " <> show pl1Err <> "\npl2Err: " <> show pl2Err <> "\nl1Err: " <> show l1Err <> "\nrawIntersectErr: " <> show rawIntersectErr <> "\n" hasIntersection = hasRawIntersection && onSegment l1 rawIntersection ulpStartSum ulpEndSum hasRawIntersection = valOf 0 foundVal /= 0 @@ -351,7 +350,7 @@ pLineIntersectsLineSeg (pl1, UlpSum pl1Err) (l1, UlpSum l1Err) ulpScale -- FIXME: remove the canonicalization from this function, moving it to the callers. (rawIntersection, UlpSum rawIntersectionErr) = canonicalize rawIntersect (rawIntersect, rawIntersectErr) = intersect2PL pl1 pl2 - (pl2, UlpSum pl2Err) = eToPLine2WithErr l1 + (pl2, pl2Err) = eToPL l1 -- | Check if/where two line segments intersect. lineSegIntersectsLineSeg :: (LineSeg, UlpSum) -> (LineSeg, UlpSum) -> Either Intersection PIntersection @@ -384,10 +383,10 @@ lineSegIntersectsLineSeg (l1, UlpSum l1Err) (l2, UlpSum ulpL2) end1 = eToPPoint2 $ endPoint l1 start2 = eToPPoint2 $ startPoint l2 end2 = eToPPoint2 $ endPoint l2 - (pl1, UlpSum pl1Err) = eToPLine2WithErr l1 - (pl2, UlpSum pl2Err) = eToPLine2WithErr l2 + (pl1, pl1Err) = eToPL l1 + (pl2, pl2Err) = eToPL l2 -- | the sum of all ULPs. used to expand the hitcircle of an endpoint. - ulpTotal = pl1Err + pl2Err + l1Err + ulpL2 + ulpTotal = l1Err + ulpL2 dumpULPs = "pl1Err: " <> show pl1Err <> "\npl2Err: " <> show pl2Err <> "\nl1Err: " <> show l1Err <> "\nrawIntersectErr: " <> show rawIntersectErr <> "\n" hasIntersection = hasRawIntersection && onSegment l1 rawIntersection ulpStartSum1 ulpEndSum1 && onSegment l2 rawIntersection ulpStartSum2 ulpEndSum2 hasRawIntersection = valOf 0 foundVal /= 0 @@ -441,7 +440,7 @@ combineConsecutiveLineSegs lines = case lines of canCombineLineSegs l1@(LineSeg p1 s1) l2@(LineSeg p2 _) = sameLineSeg && sameMiddlePoint where -- FIXME: this does not take into account the Err introduced by eToPLine2. - sameLineSeg = plinesIntersectIn (fst $ eToPLine2WithErr l1) (fst $ eToPLine2WithErr l2) == PCollinear + sameLineSeg = plinesIntersectIn (fst $ eToPL l1) (fst $ eToPL l2) == PCollinear sameMiddlePoint = p2 == addPoints p1 s1 ------------------------------------------------ @@ -473,15 +472,10 @@ reverseGVec (GVec vals) = GVec $ foldl' addValWithoutErr [] , GVal (negate $ valOf 0 $ getVal [GEZero 1, GEPlus 1, GEPlus 2] vals) (fromList [GEZero 1, GEPlus 1, GEPlus 2]) ] -eToPLine2WithErr :: LineSeg -> (PLine2, UlpSum) -eToPLine2WithErr l1 = (res, resErr) - where - (res, resErr) = join2PP (eToPPoint2 $ startPoint l1) (eToPPoint2 $ endPoint l1) - eToPL :: LineSeg -> (PLine2, PLine2Err) eToPL l1 = (res, resErr) where - (res, resErr) = join2PPWithErr (eToPPoint2 $ startPoint l1) (eToPPoint2 $ endPoint l1) + (res, resErr) = join2PP (eToPPoint2 $ startPoint l1) (eToPPoint2 $ endPoint l1) -- | Get the sum of the error involved in storing the values in a given PLine2. ulpOfPLine2 :: (ProjectiveLine2 a) => a -> UlpSum diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index 3b2757b7d..ded1d04fd 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -58,25 +58,25 @@ module Graphics.Slicer.Math.PGAPrimitives idealNormOfP, interpolate2PP, join2PP, - join2PPWithErr, pToEP, vecOfP ), + pLineErrAtPPoint, xIntercept, yIntercept ) where -import Prelude(Bool, Eq((==),(/=)), Monoid(mempty), Ord, Semigroup((<>)), Show(show), ($), (+), (*), (/), (<$>), (&&), abs, error, filter, negate, otherwise, realToFrac, sqrt) +import Prelude(Bool, Eq((==),(/=)), Monoid(mempty), Ord, Semigroup((<>)), Show(show), ($), (+), (*), (/), (<$>), (&&), abs, error, filter, fst, negate, otherwise, realToFrac, snd, sqrt) import Control.DeepSeq (NFData) import Data.Bits.Floating.Ulp (doubleUlp) -import Data.Either (Either(Left, Right)) +import Data.Either (Either(Left, Right), fromRight, isRight) import Data.List (foldl', sort) -import Data.Maybe (Maybe(Just,Nothing), fromMaybe, isJust, isNothing) +import Data.Maybe (Maybe(Just,Nothing), fromJust, fromMaybe, isJust, isNothing) import Data.Set (Set, elems, fromList, singleton) @@ -86,7 +86,7 @@ import Graphics.Slicer.Definitions (ℝ) import Graphics.Slicer.Math.Definitions (Point2(Point2)) -import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎣+), (⎤+), addErr, addValWithoutErr, addVecPairWithErr, divVecScalarWithErr, eValOf, getVal, mulScalarVecWithErr, scalarPart, sumErrVals, valOf) +import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎣+), (⎤+), addErr, addValWithoutErr, addVecPairWithErr, divVecScalarWithErr, eValOf, getVal, mulScalarVecWithErr, scalarPart, sumErrVals, ulpVal, valOf) -------------------------------- --- common support functions --- @@ -153,6 +153,7 @@ class ProjectiveLine2 a where consLikeL :: a -> (GVec -> a) flipL :: a -> a forceBasisOfL :: a -> a + fuzzinessOfL :: (a, PLine2Err) -> UlpSum intersect2PL :: (ProjectiveLine2 b) => a -> b -> (PPoint2, (PLine2Err, PLine2Err, PPoint2Err)) normalizeL :: a -> (NPLine2, PLine2Err) normOfL :: a -> (ℝ, PLine2Err) @@ -167,6 +168,7 @@ instance ProjectiveLine2 NPLine2 where consLikeL _ = NPLine2 flipL l = flipProjectiveLine l forceBasisOfL l = forceProjectiveLineBasis l + fuzzinessOfL l = fuzzinessOfProjectiveLine l intersect2PL l1 l2 = intersectionOfProjectiveLinesWithErr l1 l2 normalizeL l = (l, mempty) normOfL l = normOfProjectiveLineWithErr l @@ -181,6 +183,7 @@ instance ProjectiveLine2 PLine2 where consLikeL _ = PLine2 flipL l = flipProjectiveLine l forceBasisOfL l = forceProjectiveLineBasis l + fuzzinessOfL l = fuzzinessOfProjectiveLine l intersect2PL l1 l2 = intersectionOfProjectiveLinesWithErr l1 l2 normalizeL l = normalizeProjectiveLineWithErr l normOfL l = normOfProjectiveLineWithErr l @@ -259,6 +262,19 @@ forceProjectiveLineBasis line _ -> Nothing vec@(GVec vals) = vecOfL line +-- | determine the amount of error when trying to resolve a projective line. +-- NOTE: a projective line's error varies depending where on that line you are trying to resolve it. +-- for complete results, combine this with scaling xIntercept and yIntercept. +fuzzinessOfProjectiveLine :: (ProjectiveLine2 a) => (a, PLine2Err) -> UlpSum +fuzzinessOfProjectiveLine (inPLine, inPLineErr) = tUlp <> joinAddTErr <> joinMulTErr <> normalizeTErr <> additionTErr + where + (PLine2Err additionErr normalizeErr _ _ tUlp (joinMulErr, joinAddErr)) = inPLineErr <> normalizeErrRaw + additionTErr = eValOf mempty (getVal [GEZero 1] additionErr) + normalizeTErr = eValOf mempty (getVal [GEZero 1] normalizeErr) + joinMulTErr = eValOf mempty (getVal [GEZero 1] joinMulErr) + joinAddTErr = eValOf mempty (getVal [GEZero 1] joinAddErr) + (_,normalizeErrRaw) = normalizeL inPLine + -- | Find out where two lines intersect, returning a projective point, and the error quotent. -- Note that this should only be used when you can guarantee these are not collinear, or parallel. intersectionOfProjectiveLinesWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PPoint2, (PLine2Err, PLine2Err, PPoint2Err)) @@ -338,6 +354,37 @@ translateProjectiveLineWithErr line d = (PLine2 res, normErr <> PLine2Err resErr --- Projective Line Error Calculation --- ----------------------------------------- +-- | when given a PLine, and two points guaranteed to be on it, return the maximum distance between a given projective point known to be on the PLine and the 'real' line. +-- FIXME: accept a error on the projectivePoint, and return an error estimate. +pLineErrAtPPoint :: (ProjectiveLine2 a, ProjectivePoint2 b) => (a, PLine2Err) -> b -> UlpSum +pLineErrAtPPoint (inPLine, inPLineErr) errPoint + -- both intercepts are real. this line is not parallel or collinear to X or Y axises, and does not pass through the origin. + | xInterceptIsRight && yInterceptIsRight = tFuzz <> xInterceptFuzz <> yInterceptFuzz + -- only the xIntercept is real. this line is parallel to the Y axis. + | xInterceptIsRight = tFuzz <> rawXInterceptFuzz + -- only the yIntercept is real. this line is parallel to the X axis. + | yInterceptIsRight = tFuzz <> rawYInterceptFuzz + -- passes through the origin? + | otherwise = tFuzz + where + xInterceptIsRight = isJust (xIntercept (nPLine,nPLineErr)) + && isRight (fst $ fromJust $ xIntercept (nPLine,nPLineErr)) + && fromRight 0 (fst $ fromJust $ xIntercept (nPLine, nPLineErr)) /= 0 + yInterceptIsRight = isJust (yIntercept (nPLine,nPLineErr)) + && isRight (fst $ fromJust $ yIntercept (nPLine,nPLineErr)) + && fromRight 0 (fst $ fromJust $ yIntercept (nPLine, nPLineErr)) /= 0 + xInterceptFuzz = UlpSum $ ulpVal rawXInterceptFuzz * ((realToFrac xInterceptDistance + ulpVal rawXInterceptFuzz) / realToFrac yInterceptDistance) * realToFrac (abs xPos) + yInterceptFuzz = UlpSum $ ulpVal rawYInterceptFuzz * ((realToFrac yInterceptDistance + ulpVal rawYInterceptFuzz) / realToFrac xInterceptDistance) * realToFrac (abs yPos) + rawYInterceptFuzz = snd $ fromJust $ yIntercept (nPLine, nPLineErr) + rawXInterceptFuzz = snd $ fromJust $ xIntercept (nPLine, nPLineErr) + yInterceptDistance = fromRight 0 $ fst $ fromJust $ xIntercept (nPLine, nPLineErr) + xInterceptDistance = fromRight 0 $ fst $ fromJust $ xIntercept (nPLine, nPLineErr) + tFuzz = fuzzinessOfL (nPLine, nPLineErr) + -- FIXME: collect this error, and take it into account. + (Point2 (xPos,yPos),_) = pToEP errPoint + nPLineErr = nPLineErrRaw <> inPLineErr + (nPLine, nPLineErrRaw) = normalizeL inPLine + -- | find the approximate point that a given line crosses the X axis. xIntercept :: (ProjectiveLine2 a) => (a, PLine2Err) -> Maybe (Either a ℝ, UlpSum) xIntercept (line, lineErr) @@ -465,26 +512,28 @@ class (Show a) => ProjectivePoint2 a where forceBasisOfP :: a -> a idealNormOfP :: a -> (ℝ, UlpSum) interpolate2PP :: (ProjectivePoint2 b) => a -> b -> ℝ -> ℝ -> (PPoint2, UlpSum) - join2PP :: (ProjectivePoint2 b) => a -> b -> (PLine2, UlpSum) - join2PPWithErr :: (ProjectivePoint2 b) => a -> b -> (PLine2, PLine2Err) +-- join2PP :: (ProjectivePoint2 b) => a -> b -> (PLine2, UlpSum) + join2PP :: (ProjectivePoint2 b) => a -> b -> (PLine2, PLine2Err) pToEP :: a -> (Point2, UlpSum) vecOfP :: a -> GVec instance ProjectivePoint2 PPoint2 where canonicalize p = (\(a, PPoint2Err _ cp1Errs _ _ _ _ _) -> (a,sumErrVals cp1Errs)) $ canonicalizePPoint2WithErr p consLikeP (PPoint2 _) = PPoint2 - distance2PP p1 p2 = crushErr $ distanceBetweenPPointsWithErr p1 p2 + distance2PP p1 p2 = crushErr $ distanceBetweenProjectivePointsWithErr p1 p2 where - crushErr a = a + crushErr (a,(_,_,_,b)) = (a,b) forceBasisOfP a = forceProjectivePointBasis a idealNormOfP a = idealNormPPoint2WithErr a interpolate2PP p1 p2 = pPointBetweenPPointsWithErr p1 p2 +{- join2PP a b = crushErr $ join2ProjectivePointsWithErr a b where crushErr (res, (PPoint2Err _ cp1Errs _ _ _ _ _ ,PPoint2Err _ cp2Errs _ _ _ _ _ ,PLine2Err _ _ _ _ _ (resMulErrs, resAddErrs))) = (res, sumErrVals resMulErrs <> sumErrVals resAddErrs <> sumErrVals cp1Errs <> sumErrVals cp2Errs) - join2PPWithErr a b = crushErr $ join2ProjectivePointsWithErr a b +-} + join2PP a b = crushErr $ join2ProjectivePointsWithErr a b where crushErr (res, (_,_,resErr)) = (res, resErr) pToEP p = crushErr $ fromMaybe (error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point.") $ projectivePointToPoint2 p @@ -495,18 +544,20 @@ instance ProjectivePoint2 PPoint2 where instance ProjectivePoint2 CPPoint2 where canonicalize p = (p, mempty) consLikeP (CPPoint2 _) = CPPoint2 - distance2PP p1 p2 = crushErr $ distanceBetweenPPointsWithErr p1 p2 + distance2PP p1 p2 = crushErr $ distanceBetweenProjectivePointsWithErr p1 p2 where - crushErr a = a + crushErr (a,(_,_,_,b)) = (a,b) forceBasisOfP p = forceProjectivePointBasis p idealNormOfP p = idealNormPPoint2WithErr p interpolate2PP p1 p2 = pPointBetweenPPointsWithErr p1 p2 +{- join2PP a b = crushErr $ join2ProjectivePointsWithErr a b where crushErr (res, (PPoint2Err _ cp1Errs _ _ _ _ _ ,PPoint2Err _ cp2Errs _ _ _ _ _ ,PLine2Err _ _ _ _ _ (resMulErrs, resAddErrs))) = (res, sumErrVals resMulErrs <> sumErrVals resAddErrs <> sumErrVals cp1Errs <> sumErrVals cp2Errs) - join2PPWithErr a b = crushErr $ join2ProjectivePointsWithErr a b +-} + join2PP a b = crushErr $ join2ProjectivePointsWithErr a b where crushErr (res, (_,_,resErr)) = (res, resErr) pToEP p = crushErr $ fromMaybe (error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point.") $ projectivePointToPoint2 p @@ -540,14 +591,14 @@ canonicalizePPoint2WithErr point (GVec rawVals) = vecOfP point foundVal = getVal [GEPlus 1, GEPlus 2] rawVals -distanceBetweenPPointsWithErr :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> (ℝ, UlpSum) -distanceBetweenPPointsWithErr point1 point2 = (res, ulpTotal) +distanceBetweenProjectivePointsWithErr :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> (ℝ, (PPoint2Err, PPoint2Err, PLine2Err, UlpSum)) +distanceBetweenProjectivePointsWithErr point1 point2 = (res, (cPoint1Err, cPoint2Err, resErr <> newPLineErr, ulpTotal)) where - (res, _) = normOfL newPLine - (newPLine, newPLineUlp) = join2PP cpoint1 cpoint2 - ulpTotal = newPLineUlp -- resErr -- <> PLine2Err _ _ _ _ _ newPLineUlp - (cpoint1, _) = canonicalize point1 - (cpoint2, _) = canonicalize point2 + ulpTotal = pLineErrAtPPoint (newPLine, newPLineErr) cPoint1 + (res, resErr) = normOfL newPLine + (newPLine, newPLineErr) = join2PP cPoint1 cPoint2 + (cPoint1, cPoint1Err) = canonicalizePPoint2WithErr point1 + (cPoint2, cPoint2Err) = canonicalizePPoint2WithErr point2 -- | runtime basis coersion. ensure all of the '0' components exist on a Projective Point. forceProjectivePointBasis :: (ProjectivePoint2 a) => a -> a diff --git a/Graphics/Slicer/Math/Skeleton/Cells.hs b/Graphics/Slicer/Math/Skeleton/Cells.hs index 2d97d2842..6153a4aaf 100644 --- a/Graphics/Slicer/Math/Skeleton/Cells.hs +++ b/Graphics/Slicer/Math/Skeleton/Cells.hs @@ -60,7 +60,7 @@ import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, import Graphics.Slicer.Math.PGA (Arcable(outOf), CPPoint2(CPPoint2), Pointable(canPoint, ePointOf, pPointOf), PIntersection(PAntiCollinear, IntersectsIn), PPoint2(PPoint2), angleBetween2PL, distance2PP, eToPL, eToPPoint2, normalizeL, plinesIntersectIn) -import Graphics.Slicer.Math.PGAPrimitives (join2PPWithErr) +import Graphics.Slicer.Math.PGAPrimitives (join2PP) data UnsupportedReason = INodeCrossesDivide ![(INode,CellDivide)] !NodeTree deriving (Show, Eq) @@ -369,7 +369,7 @@ addNodeTreesAlongDivide nodeTree1 nodeTree2 division = mergeNodeTrees (adjustedN case nub $ insOf $ lastINodeOf iNodeGens of [] -> error "unpossible." [_] -> NodeTree eNodes $ INodeSet $ init gens - (_:_) -> NodeTree eNodes $ INodeSet $ init gens <> one [makeINode (nub $ insOf $ lastINodeOf iNodeGens) (Just $ join2PPWithErr (finalPointOfNodeTree nodeTree) myCrossover)] + (_:_) -> NodeTree eNodes $ INodeSet $ init gens <> one [makeINode (nub $ insOf $ lastINodeOf iNodeGens) (Just $ join2PP (finalPointOfNodeTree nodeTree) myCrossover)] -- | find the last resolvable point in a NodeTree finalPointOfNodeTree (NodeTree _ iNodeGens) | canPoint (lastINodeOf iNodeGens) = pPointOf $ lastINodeOf iNodeGens diff --git a/Graphics/Slicer/Math/Skeleton/Definitions.hs b/Graphics/Slicer/Math/Skeleton/Definitions.hs index 045a8cb88..32b6ac0ab 100644 --- a/Graphics/Slicer/Math/Skeleton/Definitions.hs +++ b/Graphics/Slicer/Math/Skeleton/Definitions.hs @@ -55,7 +55,7 @@ import Graphics.Slicer.Math.Definitions (Contour, LineSeg(LineSeg), Point2, mapW import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum), addVecPair) -import Graphics.Slicer.Math.PGA (plinesIntersectIn, PIntersection(IntersectsIn), flipL, PLine2(PLine2), PLine2Err, pLineIsLeft, distance2PP, Pointable(canPoint, pPointOf, ePointOf), Arcable(errOfOut, hasArc, outOf), CPPoint2(CPPoint2), PPoint2(PPoint2), canonicalize, eToPLine2WithErr, eToPPoint2, pToEP, vecOfL) +import Graphics.Slicer.Math.PGA (plinesIntersectIn, PIntersection(IntersectsIn), flipL, PLine2(PLine2), PLine2Err, pLineIsLeft, distance2PP, Pointable(canPoint, pPointOf, ePointOf), Arcable(errOfOut, hasArc, outOf), CPPoint2(CPPoint2), PPoint2(PPoint2), canonicalize, eToPL, eToPPoint2, pToEP, vecOfL) -- | A point where two lines segments that are part of a contour intersect, emmiting an arc toward the interior of a contour. -- FIXME: a source should have a different UlpSum for it's point and it's output. @@ -311,12 +311,12 @@ ancestorsOf (INodeSet generations) -- | Examine two line segments that are part of a Contour, and determine if they are concave toward the interior of the Contour. if they are, construct a PLine2 bisecting them, pointing toward the interior of the Contour. concavePLines :: LineSeg -> LineSeg -> Maybe PLine2 concavePLines seg1 seg2 - | Just True == pLineIsLeft (fst $ eToPLine2WithErr seg1) (fst $ eToPLine2WithErr seg2) = Just $ PLine2 $ addVecPair pv1 pv2 + | Just True == pLineIsLeft (fst $ eToPL seg1) (fst $ eToPL seg2) = Just $ PLine2 $ addVecPair pv1 pv2 | otherwise = Nothing where - (PLine2 pv1,_) = eToPLine2WithErr seg1 + (PLine2 pv1,_) = eToPL seg1 pv2 = vecOfL $ flipL pl2 - (pl2,_) = eToPLine2WithErr seg2 + (pl2,_) = eToPL seg2 -- | check if an INodeSet is empty. hasNoINodes :: INodeSet -> Bool diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index 0898e54f5..159b2242d 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -59,11 +59,11 @@ import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(GEZero, GEPlu import Graphics.Slicer.Math.Lossy (angleBetween, canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenPLines, distancePPointToPLine, eToCPPoint2, eToPLine2, getFirstArc, join2PPoint2, normalizePLine2, pPointOnPerp) -- Our 2D Projective Geometric Algebra library. -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PLine2Err(PLine2Err), canonicalize, distance2PP, distancePPointToPLineWithErr, eToPLine2WithErr, eToPL, eToPPoint2, interpolate2PP, intersect2PL, translateL, translateRotatePPoint2, angleBetween2PL, flipL, join2PP, makePPoint2, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, distancePPointToPLineWithErr, pPointOnPerpWithErr, outOf, pPointOf, outputIntersectsLineSeg) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PLine2Err(PLine2Err), canonicalize, distance2PP, distancePPointToPLineWithErr, eToPL, eToPPoint2, interpolate2PP, intersect2PL, translateL, translateRotatePPoint2, angleBetween2PL, flipL, join2PP, makePPoint2, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, distancePPointToPLineWithErr, pPointOnPerpWithErr, outOf, pPointOf, outputIntersectsLineSeg) -- The primitives of our PGA only library, and error estimation code. -import Graphics.Slicer.Math.PGAPrimitives (xIntercept, yIntercept) +import Graphics.Slicer.Math.PGAPrimitives (pLineErrAtPPoint, xIntercept, yIntercept) -- Our Contour library. import Graphics.Slicer.Math.Contour (contourContainsContour, getContours, pointsOfContour, numPointsOfContour, justOneContourFrom, lineSegsOfContour, makeLineSegContour, makePointContour, insideIsLeft, innerContourPoint, firstPointPairOfContour, firstLineSegOfContour) @@ -413,8 +413,8 @@ prop_perpAt90Degrees x y rawX2 y2 rawD sourceEnd = makePPoint2 x2 y2 (pline4, pline4Err) = join2PP sourceStart sourceEnd (normedPLine4, norm4Err) = normalizeL pline4 - errTotal3 = ulpVal $ angle2Err <> pline3Err <> pline4Err <> bisectorStartErr <> bisectorEndRawErr <> bisectorEndErr - errTotal4 = ulpVal $ angle2Err <> pline3Err <> pline4Err <> bisectorStartErr <> bisectorEndRawErr <> bisectorEndErr + errTotal3 = ulpVal $ angle2Err -- <> pline3Err <> pline4Err -- <> bisectorStartErr <> bisectorEndRawErr <> bisectorEndErr + errTotal4 = ulpVal $ angle2Err -- <> pline3Err <> pline4Err -- <> bisectorStartErr <> bisectorEndRawErr <> bisectorEndErr x2 :: ℝ x2 = coerce rawX2 d :: ℝ @@ -467,9 +467,9 @@ prop_PerpTranslateID x y dx dy rawT res = distanceBetweenPLines resPLine origPLine (resPLine, UlpSum resPLineErr) = translateL translatedPLine (-t) (translatedPLine, UlpSum translatedPLineErr) = translateL origPLine t - (origPLine, UlpSum origPLineErr) = randomPLineWithErr x y dx dy + (origPLine, origPLineErr) = randomPLineWithErr x y dx dy resErr, t :: ℝ - resErr = realToFrac (resPLineErr + translatedPLineErr + origPLineErr) + resErr = realToFrac (resPLineErr + translatedPLineErr) t = coerce rawT pgaSpec :: Spec @@ -566,7 +566,7 @@ prop_QuadBisectorCrossesMultiple rawX1 rawY1 rawX2 rawY2 rawTimes intersect4 = outputIntersectsLineSeg eNode lineSeg2 -- note that our bisector always intersects the origin. (NPLine2 bisector1, bisector1ErrRaw) = normalizeL bisector - (bisector, UlpSum bisectorUlp) = eToPLine2WithErr $ makeLineSeg (Point2 (0,0)) (Point2 (x3,y3)) + (bisector, bisectorErr) = eToPL $ makeLineSeg (Point2 (0,0)) (Point2 (x3,y3)) eNode = makeENode (Point2 (x1,y1)) (Point2 (0,0)) (Point2 (x2,y2)) -- X1, Y1 and X2 forced uniqueness. additionally, forced "not 180 degree opposition). x1,y1,x2,y2,times :: ℝ @@ -621,13 +621,13 @@ prop_LineSegIntersectionStableAtOrigin d1 x1 y1 rawX2 rawY2 ) <> "\n" <> "(x2,y2): " <> show (x2,y2) <> "\n" where - res1 = intersectsWithErr (Right pLineThroughOriginNotX1Y1NotOther) (Left (x1y1LineSegToOrigin,mempty)) - res2 = intersectsWithErr (Right pLineThroughOriginNotX1Y1NotOther) (Left (lineSegFromOrigin,mempty)) + res1 = intersectsWithErr (Right (pLineThroughOriginNotX1Y1NotOther,mempty)) (Left (x1y1LineSegToOrigin,mempty)) + res2 = intersectsWithErr (Right (pLineThroughOriginNotX1Y1NotOther,mempty)) (Left (lineSegFromOrigin,mempty)) distanceStart = case res2 of (Left (NoIntersection iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP iPoint (eToCPPoint2 $ Point2 (0,0))) <> "\nUlpSum:" <> show ulpSum <> "\n" (Right (IntersectsIn iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP iPoint (eToCPPoint2 $ Point2 (0,0))) <> "\nUlpSum:" <> show ulpSum <> "\n" _ -> "" - pLineThroughOriginNotX1Y1NotOther = randomPLineThroughOrigin x2 y2 + (pLineThroughOriginNotX1Y1NotOther,_) = randomPLineThroughOrigin x2 y2 x1y1LineSegToOrigin = randomX1Y1LineSegToOrigin d1 lineSegFromOrigin = randomLineSegFromOriginNotX1Y1 x1 y1 isEndPoint (Left (HitEndPoint _)) = True @@ -667,8 +667,8 @@ prop_LineSegIntersectionStableAtX1Y1Point pointD rawD1 x1 y1 rawX2 rawY2 <> distanceEnd ) <> "\n" where - res1 = intersectsWithErr (Right pLineThroughPointNotX1Y1NotOther) (Left (x1y1LineSegToPoint,mempty)) - res2 = intersectsWithErr (Right pLineThroughPointNotX1Y1NotOther) (Left (lineSegFromPointNotX1Y1,mempty)) + res1 = intersectsWithErr (Right (pLineThroughPointNotX1Y1NotOther,mempty)) (Left (x1y1LineSegToPoint,mempty)) + res2 = intersectsWithErr (Right (pLineThroughPointNotX1Y1NotOther,mempty)) (Left (lineSegFromPointNotX1Y1,mempty)) distanceStart = case res2 of (Left (NoIntersection iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP iPoint (eToCPPoint2 $ Point2 (d2,d2))) <> "\nUlpSum:" <> show ulpSum <> "\n" (Right (IntersectsIn iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP iPoint (eToCPPoint2 $ Point2 (d2,d2))) <> "\nUlpSum:" <> show ulpSum <> "\n" @@ -677,7 +677,7 @@ prop_LineSegIntersectionStableAtX1Y1Point pointD rawD1 x1 y1 rawX2 rawY2 (Left (NoIntersection iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP iPoint (eToCPPoint2 $ Point2 (d2,d2))) <> "\nUlpSum:" <> show ulpSum <> "\n" (Right (IntersectsIn iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP iPoint (eToCPPoint2 $ Point2 (d2,d2))) <> "\nUlpSum:" <> show ulpSum <> "\n" _ -> "" - pLineThroughPointNotX1Y1NotOther = randomPLineThroughPoint x2 y2 d2 + (pLineThroughPointNotX1Y1NotOther,_) = randomPLineThroughPoint x2 y2 d2 x1y1LineSegToPoint = randomX1Y1LineSegToPoint d1 d2 lineSegFromPointNotX1Y1 = randomLineSegFromPointNotX1Y1 x1 y1 d2 isEndPoint (Left (HitEndPoint _)) = True @@ -1220,8 +1220,8 @@ prop_PLineWithinErrRange1 x1 y1 rawX2 rawY2 <> "ulpTotal2: " <> show ulpTotal2 <> "\n" <> "distance1Err: " <> show distance1Err <> "\n" <> "distance2Err: " <> show distance2Err <> "\n" - <> "PLine1ULP: " <> show ulpPLine <> "\n" <> "PLine: " <> show pLine <> "\n" + <> "PLine1Err: " <> show pLineErr <> "\n" <> "NPLine: " <> show nPLine <> "\n" <> "PPoint1: " <> show pPoint1 <> "\n" <> "PPoint2: " <> show pPoint2 <> "\n" @@ -1231,9 +1231,9 @@ prop_PLineWithinErrRange1 x1 y1 rawX2 rawY2 pPoint1 = makePPoint2 x1 y1 pPoint2 = makePPoint2 x2 y2 (nPLine, _) = normalizeL pLine - (pLine, UlpSum ulpPLine) = eToPLine2WithErr $ makeLineSeg (Point2 (x1,y1)) (Point2 (x2,y2)) - ulpTotal1 = ulpPLine + distance1Err - ulpTotal2 = ulpPLine + distance2Err + (pLine, pLineErr) = eToPL $ makeLineSeg (Point2 (x1,y1)) (Point2 (x2,y2)) + ulpTotal1 = distance1Err + ulpTotal2 = distance2Err -- make sure we do not try to create a 0 length line segment. (x2,y2) | x1 == rawX2 && y1 == rawY2 = if x1 == 0 && y1 == 0 @@ -1243,8 +1243,8 @@ prop_PLineWithinErrRange1 x1 y1 rawX2 rawY2 prop_PLineWithinErrRange2 :: ℝ -> ℝ -> ℝ -> ℝ -> Bool prop_PLineWithinErrRange2 x1 y1 rawX2 rawY2 - | distance1 > realToFrac ulpTotal1 = error $ "startPoint outside of expected range:\n" <> dumpRes - | distance2 > realToFrac ulpTotal2 = error $ "endPoint outside of expected range:\n" <> dumpRes + | distance1 > realToFrac (ulpVal ulpTotal1) = error $ "startPoint outside of expected range:\n" <> dumpRes + | distance2 > realToFrac (ulpVal ulpTotal2) = error $ "endPoint outside of expected range:\n" <> dumpRes | otherwise = True where dumpRes = "distance1: " <> show distance1 <> "\n" @@ -1253,20 +1253,21 @@ prop_PLineWithinErrRange2 x1 y1 rawX2 rawY2 <> "ulpTotal2: " <> show ulpTotal2 <> "\n" <> "distance1Err: " <> show distance1Err <> "\n" <> "distance2Err: " <> show distance2Err <> "\n" - <> "PLine1ULP: " <> show ulpPLine <> "\n" <> "PLine1: " <> show pLine1 <> "\n" - <> "NPLine1(vec): " <> show lvec <> "\n" + <> "PLine1Err: " <> show pLine1Err <> "\n" <> "PPoint1: " <> show pPoint1 <> "\n" <> "PPoint2: " <> show pPoint2 <> "\n" + <> "xIntercept(PLine1): " <> show (xIntercept (pLine1,pLine1Err)) <> "\n" + <> "yIntercept(PLine1): " <> show (yIntercept (pLine1,pLine1Err)) <> "\n" -- distance1 and distance2 should be 0, in an ideal world. - (distance1, UlpSum distance1Err) = distancePPointToPLineWithErr (PPoint2 pPoint1) pLine1 - (distance2, UlpSum distance2Err) = distancePPointToPLineWithErr (PPoint2 pPoint2) pLine1 - (CPPoint2 pPoint1) = makePPoint2 x1 y1 - (CPPoint2 pPoint2) = makePPoint2 x2 y2 - (pLine1, UlpSum ulpPLine) = join2PP (CPPoint2 pPoint1) (CPPoint2 pPoint2) - (NPLine2 lvec, _) = normalizeL pLine1 - ulpTotal1 = ulpPLine + distance1Err - ulpTotal2 = ulpPLine + distance2Err + (distance1, distance1Err) = distancePPointToPLineWithErr pPoint1 pLine1 + (distance2, distance2Err) = distancePPointToPLineWithErr pPoint2 pLine1 + pPoint1 = makePPoint2 x1 y1 + pPoint2 = makePPoint2 x2 y2 + (pLine1, pLine1Err) = join2PP pPoint1 pPoint2 + ulpTotal1, ulpTotal2 :: UlpSum + ulpTotal1 = distance1Err <> pLineErrAtPPoint (pLine1, pLine1Err) pPoint1 + ulpTotal2 = distance2Err <> pLineErrAtPPoint (pLine1, pLine1Err) pPoint2 -- make sure we do not try to create a 0 length line segment. (x2,y2) | x1 == rawX2 && y1 == rawY2 = if x1 == 0 && y1 == 0 @@ -1285,7 +1286,6 @@ prop_PPointOnPerpWithinErrRange x1 y1 rawX2 rawY2 rawD <> "distance1: " <> show res1 <> "\n" <> "distance2: " <> show res2 <> "\n" <> "PLine: " <> show pLine <> "\n" - <> "PLineULP: " <> show ulpPLine <> "\n" <> "ulpTotal1: " <> show ulpTotal1 <> "\n" <> "ulpTotal2: " <> show ulpTotal2 <> "\n" -- res should be d, in an ideal world. @@ -1295,9 +1295,9 @@ prop_PPointOnPerpWithinErrRange x1 y1 rawX2 rawY2 rawD (perp2, UlpSum ulpSumPerp2) = pPointOnPerpWithErr pLine (PPoint2 pPoint2) d (CPPoint2 pPoint1) = makePPoint2 x1 y1 (CPPoint2 pPoint2) = makePPoint2 x2 y2 - (pLine, UlpSum ulpPLine) = join2PP (CPPoint2 pPoint1) (CPPoint2 pPoint2) - ulpTotal1 = ulpPLine + res1Err + ulpSumPerp1 - ulpTotal2 = ulpPLine + res2Err + ulpSumPerp2 + (pLine, _) = join2PP (CPPoint2 pPoint1) (CPPoint2 pPoint2) + ulpTotal1 = res1Err + ulpSumPerp1 + ulpTotal2 = res2Err + ulpSumPerp2 d :: ℝ d = coerce rawD -- make sure we do not try to create a 0 length line segment. @@ -1369,9 +1369,9 @@ prop_PLinesIntersectAtOrigin rawX y rawX2 rawY2 (foundDistance, UlpSum distanceErr) = distance2PP originPPoint2 intersectionCPPoint2 (intersectionCPPoint2, UlpSum canonicalizationErr) = canonicalize intersectionPPoint2 (intersectionPPoint2, intersectionErr) = intersect2PL randomPLine1 randomPLine2 - (randomPLine1, UlpSum pline1Err) = randomPLineThroughOrigin x y - (randomPLine2, UlpSum pline2Err) = randomPLineThroughOrigin x2 y2 - errSum = pline1Err + pline2Err + distanceErr + canonicalizationErr + (randomPLine1, _) = randomPLineThroughOrigin x y + (randomPLine2, _) = randomPLineThroughOrigin x2 y2 + errSum = distanceErr + canonicalizationErr x,x2,y2 :: ℝ x = coerce rawX x2 @@ -1397,9 +1397,9 @@ prop_PLinesIntersectAtPoint rawX y rawX2 rawY2 targetX targetY (foundDistance, UlpSum distanceErr) = distance2PP targetPPoint2 intersectionCPPoint2 (intersectionCPPoint2, UlpSum canonicalizationErr) = canonicalize intersectionPPoint2 (intersectionPPoint2, intersectionErr) = intersect2PL randomPLine1 randomPLine2 - (randomPLine1, UlpSum pline1Err) = randomPLineWithErr x y targetX targetY - (randomPLine2, UlpSum pline2Err) = randomPLineWithErr x2 y2 targetX targetY - errSum = pline1Err + pline2Err + distanceErr + canonicalizationErr + (randomPLine1, _) = randomPLineWithErr x y targetX targetY + (randomPLine2, _) = randomPLineWithErr x2 y2 targetX targetY + errSum = distanceErr + canonicalizationErr x,x2,y2 :: ℝ x = coerce rawX x2 From dd60c1dfa860f6353ea8d000b6939c2d115b08c4 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 29 Oct 2022 14:59:06 +0000 Subject: [PATCH 041/206] expose fuzzinessOfL, for testing. --- Graphics/Slicer/Math/PGAPrimitives.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index ded1d04fd..c0c194475 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -44,6 +44,7 @@ module Graphics.Slicer.Math.PGAPrimitives angleBetween2PL, flipL, forceBasisOfL, + fuzzinessOfL, intersect2PL, normalizeL, normOfL, From 32b2d8adc7e4454e81f28f960310784be1f6f6fe Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 29 Oct 2022 22:03:37 +0000 Subject: [PATCH 042/206] add angleCosBetween2PL and fuzzinessOfP to PGAPrimitives, and adapt angleBetween2PL to drop the unused error inputs. --- Graphics/Slicer/Math/Lossy.hs | 6 +- Graphics/Slicer/Math/PGA.hs | 77 ++++--------- Graphics/Slicer/Math/PGAPrimitives.hs | 112 ++++++++++++++----- Graphics/Slicer/Math/Skeleton/Cells.hs | 4 +- Graphics/Slicer/Math/Skeleton/Concave.hs | 4 +- Graphics/Slicer/Math/Skeleton/Motorcycles.hs | 12 +- tests/Math/PGA.hs | 20 ++-- 7 files changed, 128 insertions(+), 107 deletions(-) diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index 5708491d2..446d047f1 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -39,7 +39,7 @@ module Graphics.Slicer.Math.Lossy ( translatePLine2 ) where -import Prelude (($), fst, mempty) +import Prelude (($), fst) -- The numeric type in HSlice. import Graphics.Slicer.Definitions (ℝ) @@ -50,8 +50,8 @@ import Graphics.Slicer.Math.Arcs (getFirstArcWithErr, getInsideArcWithErr) import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PPoint2, ProjectiveLine2, ProjectivePoint2, angleBetween2PL, canonicalize, distance2PP, distanceBetweenPLinesWithErr, distancePPointToPLineWithErr, eToPL, eToPPoint2, interpolate2PP, join2PP, normalizeL, pPointOnPerpWithErr, pToEP, translateL) -angleBetween :: NPLine2 -> NPLine2 -> ℝ -angleBetween nPLine1 nPLine2 = fst $ angleBetween2PL (nPLine1, mempty) (nPLine2, mempty) +angleBetween :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> ℝ +angleBetween pLine1 pLine2 = fst $ angleBetween2PL pLine1 pLine2 -- | canonicalize a euclidian point. canonicalizePPoint2 :: PPoint2 -> CPPoint2 diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 5f117e394..08302e83d 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -89,7 +89,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (GNum(G0, GEPlus, GEZero), GVal(GVa import Graphics.Slicer.Math.Line (combineLineSegs) -import Graphics.Slicer.Math.PGAPrimitives(Arcable(errOfOut, hasArc, outOf), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(angleBetween2PL, flipL, forceBasisOfL, intersect2PL, normalizeL, normOfL, translateL, vecOfL), ProjectivePoint2(canonicalize, distance2PP, forceBasisOfP, idealNormOfP, interpolate2PP, join2PP, pToEP, vecOfP), xIntercept, yIntercept) +import Graphics.Slicer.Math.PGAPrimitives(Arcable(errOfOut, hasArc, outOf), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(angleBetween2PL, angleCosBetween2PL, flipL, forceBasisOfL, intersect2PL, normalizeL, normOfL, translateL, vecOfL), ProjectivePoint2(canonicalize, distance2PP, forceBasisOfP, idealNormOfP, interpolate2PP, join2PP, pToEP, vecOfP), canonicalizedIntersectionOf2PL, xIntercept, yIntercept) -- Our 2D plane coresponds to a Clifford algebra of 2,0,1. @@ -111,22 +111,20 @@ plinesIntersectIn :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> PInters plinesIntersectIn pl1 pl2 | isNothing canonicalizedIntersection || (idealNorm <= realToFrac (ulpVal idnErr) - && (sameDirection npl1 npl2 || - oppositeDirection npl1 npl2)) = if sameDirection npl1 npl2 - then PCollinear - else PAntiCollinear - | sameDirection npl1 npl2 = PParallel - | oppositeDirection npl1 npl2 = PAntiParallel - | otherwise = IntersectsIn res (resUlp, mempty, mempty, mempty, iaErr, mempty) + && (sameDirection pl1 pl2 || + oppositeDirection pl1 pl2)) = if sameDirection pl1 pl2 + then PCollinear + else PAntiCollinear + | sameDirection pl1 pl2 = PParallel + | oppositeDirection pl1 pl2 = PAntiParallel + | otherwise = IntersectsIn res (mempty, mempty, mempty, mempty, iaErr, mempty) where (idealNorm, idnErr) = idealNormOfP intersectPoint - (_, (_,_,iaErr)) = angleBetween2PL npl1 npl2 + (_, (_,_,iaErr)) = angleBetween2PL pl1 pl2 -- FIXME: how much do the potential normalization errors have an effect on the resultant angle? (intersectPoint, _) = intersect2PL pl1 pl2 - (res, resUlp) = fromJust canonicalizedIntersection - canonicalizedIntersection = canonicalizeIntersectionWithErr pl1 pl2 - npl1 = normalizeL pl1 - npl2 = normalizeL pl2 + (res, _) = fromJust canonicalizedIntersection + canonicalizedIntersection = canonicalizedIntersectionOf2PL pl1 pl2 -- | Check if the second line's direction is on the 'left' side of the first line, assuming they intersect. If they don't intersect, return Nothing. pLineIsLeft :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Maybe Bool @@ -136,42 +134,27 @@ pLineIsLeft pl1 pl2 | otherwise = Just $ res > 0 where -- FIXME: naieve implementation. use npl1Err and npl2Err to get two angle differences. - (res, _) = angleCos npl1 npl2 + (res, _) = angleCosBetween2PL npl1 npl2 (npl1, _) = normalizeL pl1 (npl2, _) = normalizeL pl2 - -- | Find the cosine of the angle between the two lines. results in a value that is ~+1 when the first line points to the "left" of the second given line, and ~-1 when "right". - angleCos :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, UlpSum) - angleCos l1 l2 - | isNothing canonicalizedIntersection = (0, mempty) - | otherwise = (angle, iPointErr) - where - angle = valOf 0 $ getVal [GEZero 1, GEPlus 1, GEPlus 2] $ (\(GVec a) -> a) $ lvec2 ∧ (motor • iPointVec • antiMotor) - (CPPoint2 iPointVec, iPointErr) = fromJust canonicalizedIntersection - motor = addVecPairWithoutErr (lvec1•gaI) (GVec [GVal 1 (singleton G0)]) - antiMotor = addVecPairWithoutErr (lvec1•gaI) (GVec [GVal (-1) (singleton G0)]) - canonicalizedIntersection = canonicalizeIntersectionWithErr (NPLine2 lvec1) (NPLine2 lvec2) - -- I, the infinite point. - gaI = GVec [GVal 1 (fromList [GEZero 1, GEPlus 1, GEPlus 2])] - lvec1 = vecOfL l1 - lvec2 = vecOfL l2 -- FIXME: use the distance to increase ULP appropriately? +-- FIXME: we lose a lot of error in this function. distancePPointToPLineWithErr :: (ProjectivePoint2 a, ProjectiveLine2 b) => a -> b -> (ℝ, UlpSum) distancePPointToPLineWithErr point line | valOf 0 foundVal == 0 = error "attempted to get the distance of an ideal point." | otherwise = (res, ulpTotal) where (res, _) = normOfL newPLine - (newPLine, newPLineErr) = join2PP point linePoint + (newPLine, _) = join2PP point linePoint (perpLine, (plMulErr,plAddErr))= lvec ⨅+ npvec lvec = vecOfL $ forceBasisOfL (PLine2 nplvec) npvec = vecOfP $ forceBasisOfP point - (linePoint, lpErr) = fromJust $ canonicalizeIntersectionWithErr (PLine2 lvec) (PLine2 perpLine) - ulpTotal = sumErrVals plMulErr <> sumErrVals plAddErr <> lpErr + (linePoint, _) = fromJust $ canonicalizedIntersectionOf2PL (PLine2 lvec) (PLine2 perpLine) + ulpTotal = sumErrVals plMulErr <> sumErrVals plAddErr foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(GVec vals) -> vals) $ vecOfP $ point (NPLine2 nplvec,_) = normalizeL line - -- | Determine if two points are on the same side of a given line. pPointsOnSameSideOfPLine :: (ProjectivePoint2 a, ProjectivePoint2 b, ProjectiveLine2 c) => a -> b -> c -> Maybe Bool pPointsOnSameSideOfPLine point1 point2 line @@ -204,7 +187,7 @@ distanceBetweenPLinesWithErr line1 line2 = (ideal, resUlpSum) -- | A checker, to ensure two Projective Lines are going the same direction, and are parallel. -- FIXME: precision on inputs? -sameDirection :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Bool +sameDirection :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Bool sameDirection a b = res >= maxAngle where -- ceiling value. a value bigger than maxAngle is considered to be going the same direction. @@ -214,7 +197,7 @@ sameDirection a b = res >= maxAngle -- | A checker, to ensure two Projective Lines are going the opposite direction, and are parallel. -- FIXME: precision on inputs? -oppositeDirection :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Bool +oppositeDirection :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Bool oppositeDirection a b = res <= minAngle where -- floor value. a value smaller than minAngle is considered to be going the opposite direction. @@ -296,7 +279,7 @@ outputIntersectsLineSeg source l1 | otherwise = error $ "no arc from source?\n" <> show source <> "\n" - canonicalizedIntersection = canonicalizeIntersectionWithErr pl1 pl2 + canonicalizedIntersection = canonicalizedIntersectionOf2PL pl1 pl2 -- | A type alias, for cases where either input is acceptable. type SegOrPLine2WithErr = Either (LineSeg, UlpSum) (PLine2,UlpSum) @@ -309,13 +292,13 @@ intersectsWithErr (Left l1@(rawL1,_)) (Right pl1@(rawPL1, _)) = pLineIntersectsL where ulpScale :: ℝ ulpScale = realToFrac $ ulpMultiplier * (abs (realToFrac angle) + angleErr) - (angle, (_,_, UlpSum angleErr)) = angleBetween2PL (rawPL1, mempty) (pl2, mempty) + (angle, (_,_, UlpSum angleErr)) = angleBetween2PL rawPL1 pl2 (pl2, _) = eToPL rawL1 intersectsWithErr (Right pl1@(rawPL1, _)) (Left l1@(rawL1,_)) = pLineIntersectsLineSeg pl1 l1 ulpScale where ulpScale :: ℝ ulpScale = realToFrac $ ulpMultiplier * (abs (realToFrac angle) + angleErr) - (angle, (_,_, UlpSum angleErr)) = angleBetween2PL (rawPL1, mempty) (pl2, mempty) + (angle, (_,_, UlpSum angleErr)) = angleBetween2PL rawPL1 pl2 (pl2, _) = eToPL rawL1 -- | Check if/where a line segment and a PLine intersect. @@ -329,7 +312,7 @@ pLineIntersectsLineSeg (pl1, UlpSum pl1Err) (l1, UlpSum l1Err) ulpScale | hasIntersection && valOf 0 foundVal == 0 = error "intersection, but cannot cannonicalize." | hasIntersection && startDistance <= ulpStartSum = Left $ HitStartPoint l1 | hasIntersection && endDistance <= ulpEndSum = Left $ HitEndPoint l1 - | hasIntersection = Right $ IntersectsIn rawIntersection (UlpSum $ realToFrac ulpStartSum, UlpSum $ realToFrac ulpEndSum, UlpSum pl1Err, mempty, mempty, UlpSum rawIntersectionErr) + | hasIntersection = Right $ IntersectsIn rawIntersection (UlpSum $ realToFrac ulpStartSum, UlpSum $ realToFrac ulpEndSum, UlpSum pl1Err, mempty, mempty, mempty) | hasRawIntersection = Left $ NoIntersection rawIntersection (UlpSum $ realToFrac ulpStartSum, UlpSum $ realToFrac ulpEndSum, mempty, mempty) | otherwise = Left $ NoIntersection ((\(PPoint2 v) -> CPPoint2 v) rawIntersect) (mempty, mempty, mempty, mempty) where @@ -347,8 +330,8 @@ pLineIntersectsLineSeg (pl1, UlpSum pl1Err) (l1, UlpSum l1Err) ulpScale hasIntersection = hasRawIntersection && onSegment l1 rawIntersection ulpStartSum ulpEndSum hasRawIntersection = valOf 0 foundVal /= 0 foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(PPoint2 (GVec vals)) -> vals) rawIntersect - -- FIXME: remove the canonicalization from this function, moving it to the callers. - (rawIntersection, UlpSum rawIntersectionErr) = canonicalize rawIntersect + -- FIXME: shouldn't we be doing something with this error? + (rawIntersection, _) = canonicalize rawIntersect (rawIntersect, rawIntersectErr) = intersect2PL pl1 pl2 (pl2, pl2Err) = eToPL l1 @@ -490,16 +473,4 @@ ulpOfPLine2 line = UlpSum $ sum $ abs . realToFrac . doubleUlp . (\(GVal r _) -> ulpOfLineSeg :: LineSeg -> UlpSum ulpOfLineSeg (LineSeg (Point2 (x1,y1)) (Point2 (x2,y2))) = UlpSum $ sum $ abs . realToFrac . doubleUlp <$> [x1, y1, x2, y2] --- | Canonicalize the intersection resulting from two PLines. --- NOTE: Returns nothing when the PLines are (anti)parallel. --- FIXME: this ulpsum is wrong. try to actually calculate a range here. -canonicalizeIntersectionWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Maybe (CPPoint2, UlpSum) -canonicalizeIntersectionWithErr pl1 pl2 - | isNothing foundVal = Nothing - | otherwise = Just (cpp1, ulpTotal) - where - (cpp1, canonicalizationErr) = canonicalize pp1 - (pp1, _) = intersect2PL pl1 pl2 - ulpTotal = canonicalizationErr - foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(PPoint2 (GVec vals)) -> vals) pp1 diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index c0c194475..cb911259b 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -39,9 +39,10 @@ module Graphics.Slicer.Math.PGAPrimitives pPointOf ), PPoint2(PPoint2), - PPoint2Err, + PPoint2Err(PPoint2Err), ProjectiveLine2( angleBetween2PL, + angleCosBetween2PL, flipL, forceBasisOfL, fuzzinessOfL, @@ -56,12 +57,14 @@ module Graphics.Slicer.Math.PGAPrimitives canonicalize, distance2PP, forceBasisOfP, + fuzzinessOfP, idealNormOfP, interpolate2PP, join2PP, pToEP, vecOfP ), + canonicalizedIntersectionOf2PL, pLineErrAtPPoint, xIntercept, yIntercept @@ -87,7 +90,7 @@ import Graphics.Slicer.Definitions (ℝ) import Graphics.Slicer.Math.Definitions (Point2(Point2)) -import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎣+), (⎤+), addErr, addValWithoutErr, addVecPairWithErr, divVecScalarWithErr, eValOf, getVal, mulScalarVecWithErr, scalarPart, sumErrVals, ulpVal, valOf) +import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎣+), (⎤+), (∧), (•), addErr, addValWithoutErr, addVecPairWithErr, addVecPairWithoutErr, divVecScalarWithErr, eValOf, getVal, mulScalarVecWithErr, scalarPart, sumErrVals, ulpVal, valOf) -------------------------------- --- common support functions --- @@ -150,7 +153,8 @@ newtype NPLine2 = NPLine2 GVec deriving (Eq, Generic, NFData, Show) class ProjectiveLine2 a where - angleBetween2PL :: (ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> (ℝ, (PLine2Err, PLine2Err, UlpSum)) + angleBetween2PL :: (ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, UlpSum)) + angleCosBetween2PL :: (ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, UlpSum)) consLikeL :: a -> (GVec -> a) flipL :: a -> a forceBasisOfL :: a -> a @@ -166,6 +170,7 @@ instance ProjectiveLine2 NPLine2 where angleBetween2PL l1 l2 = crushErr $ angleBetweenWithErr l1 l2 where crushErr (res, (n1,n2,_,resErr)) = (res, (n1,n2,resErr)) + angleCosBetween2PL l1 l2 = angleCosBetweenProjectiveLines l1 l2 consLikeL _ = NPLine2 flipL l = flipProjectiveLine l forceBasisOfL l = forceProjectiveLineBasis l @@ -181,6 +186,7 @@ instance ProjectiveLine2 PLine2 where angleBetween2PL l1 l2 = crushErr $ angleBetweenWithErr l1 l2 where crushErr (res, (n1,n2,_,ulpSum)) = (res, (n1,n2,ulpSum)) + angleCosBetween2PL l1 l2 = angleCosBetweenProjectiveLines l1 l2 consLikeL _ = PLine2 flipL l = flipProjectiveLine l forceBasisOfL l = forceProjectiveLineBasis l @@ -222,11 +228,9 @@ instance Monoid PLine2Err where -- | Return the sine of the angle between the two lines, along with the error. -- Results in a value that is ~+1 when a line points in the same direction of the other given line, and ~-1 when pointing backwards. -angleBetweenWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> (ℝ, (PLine2Err, PLine2Err, ([ErrVal], [ErrVal]), UlpSum)) -angleBetweenWithErr (line1, line1Err) (line2, line2Err) - | line1Err == mempty && line2Err == mempty = (scalarPart likeRes, resErr) - -- FIXME: use the input errors to define our output error here. - | otherwise = (scalarPart likeRes, resErr) +-- FIXME: accept, and do something with input error. +angleBetweenWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, ([ErrVal], [ErrVal]), UlpSum)) +angleBetweenWithErr line1 line2 = (scalarPart likeRes, resErr) where resErr = (npl1Err, npl2Err, (likeMulErr,likeAddErr), ulpSum) -- FIXME: this returned ULPsum is wrong. actually try to interpret it. @@ -280,15 +284,13 @@ fuzzinessOfProjectiveLine (inPLine, inPLineErr) = tUlp <> joinAddTErr <> joinMul -- Note that this should only be used when you can guarantee these are not collinear, or parallel. intersectionOfProjectiveLinesWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PPoint2, (PLine2Err, PLine2Err, PPoint2Err)) intersectionOfProjectiveLinesWithErr line1 line2 = (res, - (npl1Err, - npl2Err, + (pl1ResErr, + pl2ResErr, PPoint2Err resErrs mempty mempty mempty mempty iAngleErr iAngleUnlikeErr)) where -- Since the angle of intersection has an effect on how well this point was resolved, save it with the point. - (iAngleErr,(_,_,iAngleUnlikeErr,_)) = angleBetweenWithErr (npl1, npl1Err) (npl2, npl2Err) - (res, (_,_, resErrs)) = meetOfProjectiveLinesWithErr npl1 npl2 - (npl1, npl1Err) = normalizeProjectiveLineWithErr line1 - (npl2, npl2Err) = normalizeProjectiveLineWithErr line2 + (iAngleErr,(_,_,iAngleUnlikeErr,_)) = angleBetweenWithErr line1 line2 + (res, (pl1ResErr, pl2ResErr, resErrs)) = meetOfProjectiveLinesWithErr line1 line2 -- | A typed meet function. the meeting of two lines is a point. -- kept separate from pLineIntersection for verification reasons. @@ -446,6 +448,44 @@ yIntercept (line, lineErr) rawY = getVal [GEPlus 2] pLineVals (GVec pLineVals) = vecOfL line +--------------------------------------- +--- Projective Line Mixed Functions --- +--------------------------------------- +{- functions that are part of the projective line API, but use parts of the Projective Point API. -} + +-- | Find the cosine of the angle between the two lines, along with the error. +-- Results in a value that is ~+1 when the first line points to the "left" of the second given line, and ~-1 when pointing "right". +-- FIXME: iPointErr is not +/- radians. +-- FIXME: lots of places for precision related error here, that are not recorded or reported. +-- FIXME: does not accept input imprecision. +angleCosBetweenProjectiveLines :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, UlpSum)) +angleCosBetweenProjectiveLines line1 line2 + | isNothing canonicalizedIntersection = (0, mempty) + | otherwise = (angle, (npl1Err, npl2Err, sumPPointErrs iPointErr)) + where + angle = valOf 0 $ getVal [GEZero 1, GEPlus 1, GEPlus 2] $ (\(GVec a) -> a) $ lvec2 ∧ (motor • iPointVec • antiMotor) + (CPPoint2 iPointVec, (_,_,PPoint2Err _ iPointErr _ _ _ _ _)) = fromJust canonicalizedIntersection + motor = addVecPairWithoutErr (lvec1 • gaI) (GVec [GVal 1 (singleton G0)]) + antiMotor = addVecPairWithoutErr (lvec1 • gaI) (GVec [GVal (-1) (singleton G0)]) + canonicalizedIntersection = canonicalizedIntersectionOf2PL (NPLine2 lvec1) (NPLine2 lvec2) + -- I, the infinite point. + gaI = GVec [GVal 1 (fromList [GEZero 1, GEPlus 1, GEPlus 2])] + lvec1 = vecOfL $ forceBasisOfL npl1 + lvec2 = vecOfL $ forceBasisOfL npl2 + (npl1, npl1Err) = normalizeProjectiveLineWithErr line1 + (npl2, npl2Err) = normalizeProjectiveLineWithErr line2 + +-- | get the Canonicalized intersection of two lines. +-- NOTE: Returns Nothing when the PLines are (anti)parallel. +canonicalizedIntersectionOf2PL :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Maybe (CPPoint2, (PLine2Err, PLine2Err, PPoint2Err)) +canonicalizedIntersectionOf2PL l1 l2 + | isNothing foundVal = Nothing + | otherwise = Just (cpp1, (l1Err, l2Err, pp1Err <> cpp1Err)) + where + (cpp1, cpp1Err) = canonicalize pp1 + (pp1, (l1Err,l2Err,pp1Err)) = intersect2PL l1 l2 + foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(GVec vals) -> vals) $ vecOfP pp1 + -------------------------------- --- Projective Point Support --- -------------------------------- @@ -507,33 +547,27 @@ class Arcable a where outOf :: a -> PLine2 class (Show a) => ProjectivePoint2 a where - canonicalize :: a -> (CPPoint2, UlpSum) + canonicalize :: a -> (CPPoint2, PPoint2Err) consLikeP :: a -> (GVec -> a) distance2PP :: (ProjectivePoint2 b) => a -> b -> (ℝ, UlpSum) forceBasisOfP :: a -> a + fuzzinessOfP :: (a, PPoint2Err) -> UlpSum idealNormOfP :: a -> (ℝ, UlpSum) interpolate2PP :: (ProjectivePoint2 b) => a -> b -> ℝ -> ℝ -> (PPoint2, UlpSum) --- join2PP :: (ProjectivePoint2 b) => a -> b -> (PLine2, UlpSum) join2PP :: (ProjectivePoint2 b) => a -> b -> (PLine2, PLine2Err) pToEP :: a -> (Point2, UlpSum) vecOfP :: a -> GVec instance ProjectivePoint2 PPoint2 where - canonicalize p = (\(a, PPoint2Err _ cp1Errs _ _ _ _ _) -> (a,sumErrVals cp1Errs)) $ canonicalizePPoint2WithErr p + canonicalize p = canonicalizePPoint2WithErr p consLikeP (PPoint2 _) = PPoint2 distance2PP p1 p2 = crushErr $ distanceBetweenProjectivePointsWithErr p1 p2 where crushErr (a,(_,_,_,b)) = (a,b) forceBasisOfP a = forceProjectivePointBasis a + fuzzinessOfP a = pPointFuzziness a idealNormOfP a = idealNormPPoint2WithErr a interpolate2PP p1 p2 = pPointBetweenPPointsWithErr p1 p2 -{- - join2PP a b = crushErr $ join2ProjectivePointsWithErr a b - where - crushErr (res, (PPoint2Err _ cp1Errs _ _ _ _ _ - ,PPoint2Err _ cp2Errs _ _ _ _ _ - ,PLine2Err _ _ _ _ _ (resMulErrs, resAddErrs))) = (res, sumErrVals resMulErrs <> sumErrVals resAddErrs <> sumErrVals cp1Errs <> sumErrVals cp2Errs) --} join2PP a b = crushErr $ join2ProjectivePointsWithErr a b where crushErr (res, (_,_,resErr)) = (res, resErr) @@ -549,15 +583,9 @@ instance ProjectivePoint2 CPPoint2 where where crushErr (a,(_,_,_,b)) = (a,b) forceBasisOfP p = forceProjectivePointBasis p + fuzzinessOfP a = pPointFuzziness a idealNormOfP p = idealNormPPoint2WithErr p interpolate2PP p1 p2 = pPointBetweenPPointsWithErr p1 p2 -{- - join2PP a b = crushErr $ join2ProjectivePointsWithErr a b - where - crushErr (res, (PPoint2Err _ cp1Errs _ _ _ _ _ - ,PPoint2Err _ cp2Errs _ _ _ _ _ - ,PLine2Err _ _ _ _ _ (resMulErrs, resAddErrs))) = (res, sumErrVals resMulErrs <> sumErrVals resAddErrs <> sumErrVals cp1Errs <> sumErrVals cp2Errs) --} join2PP a b = crushErr $ join2ProjectivePointsWithErr a b where crushErr (res, (_,_,resErr)) = (res, resErr) @@ -674,3 +702,25 @@ projectivePointToPoint2 ppoint e12Val = valOf 0 (getVal [GEPlus 1, GEPlus 2] rawVals) (GVec rawVals) = vecOfP ppoint +------------------------------------------ +--- Projective Point Error Calculation --- +------------------------------------------ + +sumPPointErrs :: [ErrVal] -> UlpSum +sumPPointErrs errs = eValOf mempty (getVal [GEZero 1, GEPlus 1] errs) + <> eValOf mempty (getVal [GEZero 1, GEPlus 2] errs) + <> eValOf mempty (getVal [GEPlus 1, GEPlus 2] errs) + +-- | determine the amount of error in resolving a projective point. +-- FIXME: this 1000 is completely made up BS. +pPointFuzziness :: (ProjectivePoint2 a) => (a, PPoint2Err) -> UlpSum +pPointFuzziness (inPPoint, inErr) = UlpSum $ sumTotal * realToFrac (1+(1000*(abs angleIn + realToFrac (ulpVal $ sumPPointErrs angleUnlikeAddErr <> sumPPointErrs angleUnlikeMulErr)))) + where + sumTotal = ulpVal $ sumPPointErrs pJoinAddErr + <> sumPPointErrs pJoinMulErr + <> sumPPointErrs pCanonicalizeErr + <> sumPPointErrs pAddErr + <> sumPPointErrs pIn1MulErr + <> sumPPointErrs pIn2MulErr + (PPoint2Err (pJoinAddErr, pJoinMulErr) pCanonicalizeErr pAddErr pIn1MulErr pIn2MulErr angleIn (angleUnlikeAddErr,angleUnlikeMulErr)) = cpErr <> inErr + (_, cpErr) = canonicalize inPPoint diff --git a/Graphics/Slicer/Math/Skeleton/Cells.hs b/Graphics/Slicer/Math/Skeleton/Cells.hs index 6153a4aaf..675bc1b5e 100644 --- a/Graphics/Slicer/Math/Skeleton/Cells.hs +++ b/Graphics/Slicer/Math/Skeleton/Cells.hs @@ -58,7 +58,7 @@ import Graphics.Slicer.Math.Intersections (intersectionOf) import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, eToCPPoint2, eToPLine2, pToEPoint2) -import Graphics.Slicer.Math.PGA (Arcable(outOf), CPPoint2(CPPoint2), Pointable(canPoint, ePointOf, pPointOf), PIntersection(PAntiCollinear, IntersectsIn), PPoint2(PPoint2), angleBetween2PL, distance2PP, eToPL, eToPPoint2, normalizeL, plinesIntersectIn) +import Graphics.Slicer.Math.PGA (Arcable(outOf), CPPoint2(CPPoint2), Pointable(canPoint, ePointOf, pPointOf), PIntersection(PAntiCollinear, IntersectsIn), PPoint2(PPoint2), angleBetween2PL, distance2PP, eToPPoint2, plinesIntersectIn) import Graphics.Slicer.Math.PGAPrimitives (join2PP) @@ -113,7 +113,7 @@ findDivisions contour crashTree = case motorcyclesIn crashTree of where intersectionIsBehind m = angleFound < realToFrac (ulpVal angleErr) where - (angleFound, (_,_, angleErr)) = angleBetween2PL (normalizeL $ outOf m) (eToPL $ lineSegToIntersection m) + (angleFound, (_,_, angleErr)) = angleBetween2PL (outOf m) (eToPLine2 $ lineSegToIntersection m) lineSegToIntersection m = makeLineSeg (ePointOf m) (pToEPoint2 intersectionPPoint) intersectionPPoint = intersectionOf (outOf firstMC) (outOf secondMC) (Slist (_:_) _) -> error "too many motorcycles." diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index 9aadd955a..71d9c4cdb 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -220,9 +220,9 @@ towardIntersection pp1 pl1 pp2 | d <= realToFrac dErr = error $ "cannot resolve points finely enough.\nPPoint1: " <> show pp1 <> "\nPPoint2: " <> show pp2 <> "\nPLineIn: " <> show pl1 <> "\nnewPLine: " <> show newPLine <> "\n" | otherwise = angleFound > realToFrac (ulpVal angleErr) where - (angleFound, (_,_, angleErr)) = angleBetween2PL newPLine (normalizeL pl1) + (angleFound, (_,_, angleErr)) = angleBetween2PL newPLine pl1 (d, UlpSum dErr) = distance2PP (fst $ canonicalize pp1) pp2 - newPLine = normalizeL $ join2CPPoint2 (fst $ canonicalize pp1) pp2 + newPLine = join2CPPoint2 (fst $ canonicalize pp1) pp2 -- | Make a first generation node. makeENode :: Point2 -> Point2 -> Point2 -> ENode diff --git a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs index b7edb5003..9a750b895 100644 --- a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs +++ b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs @@ -50,7 +50,7 @@ import Graphics.Slicer.Math.Intersections (getMotorcycleSegSetIntersections, get import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, pPointBetweenPPoints, distanceBetweenPPoints, eToCPPoint2, eToPLine2, normalizePLine2, pLineFromEndpoints, pToEPoint2, translatePLine2) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), PPoint2, Arcable(outOf), Pointable(canPoint, ePointOf, pPointOf), eToPL, flipL, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, PIntersection(IntersectsIn,PAntiCollinear), plinesIntersectIn, angleBetween2PL, outputIntersectsLineSeg) +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), PPoint2, Arcable(outOf), Pointable(canPoint, ePointOf, pPointOf), flipL, pLineIsLeft, pPointsOnSameSideOfPLine, PIntersection(IntersectsIn,PAntiCollinear), plinesIntersectIn, angleBetween2PL, outputIntersectsLineSeg) import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle), ENode(ENode), getFirstLineSeg, linePairs, CellDivide(CellDivide), DividingMotorcycles(DividingMotorcycles), MotorcycleIntersection(WithLineSeg, WithENode, WithMotorcycle)) @@ -157,7 +157,7 @@ crashMotorcycles contour holes intersectionPPoint = intersectionOf (outOf mot1) (outOf mot2) intersectionIsBehind m = angleFound < realToFrac (ulpVal angleErr) where - (angleFound, (_,_, angleErr)) = angleBetween2PL (normalizeL $ outOf m) (eToPL $ lineSegToIntersection m) + (angleFound, (_,_, angleErr)) = angleBetween2PL (outOf m) (eToPLine2 $ lineSegToIntersection m) lineSegToIntersection m = makeLineSeg (ePointOf m) (pToEPoint2 intersectionPPoint) -- | Find the non-reflex virtexes of a contour and draw motorcycles from them. Useful for contours that are a 'hole' in a bigger contour. @@ -255,10 +255,10 @@ motorcycleMightIntersectWith lineSegs motorcycle where intersectionPointIsBehind point = angleFound < realToFrac (ulpVal angleErr) where - (angleFound, (_,_, angleErr)) = angleBetween2PL (normalizeL $ outOf motorcycle) (eToPL $ lineSegToIntersection point) + (angleFound, (_,_, angleErr)) = angleBetween2PL (outOf motorcycle) (eToPLine2 $ lineSegToIntersection point) intersectionCPPointIsBehind pPoint = angleFound < realToFrac (ulpVal angleErr) where - (angleFound, (_,_, angleErr)) = angleBetween2PL (normalizeL $ outOf motorcycle) (eToPL $ lineSegToIntersectionP pPoint) + (angleFound, (_,_, angleErr)) = angleBetween2PL (outOf motorcycle) (eToPLine2 $ lineSegToIntersectionP pPoint) lineSegToIntersection myPoint = makeLineSeg (ePointOf motorcycle) myPoint lineSegToIntersectionP myPPoint = makeLineSeg (ePointOf motorcycle) (pToEPoint2 myPPoint) @@ -298,10 +298,10 @@ motorcycleIntersectsAt contour motorcycle = case intersections of where intersectionPointIsBehind point = angleFound < realToFrac (ulpVal angleErr) where - (angleFound, (_,_, angleErr)) = angleBetween2PL (normalizeL $ outOf motorcycle) (eToPL $ lineSegToIntersection point) + (angleFound, (_,_, angleErr)) = angleBetween2PL (outOf motorcycle) (eToPLine2 $ lineSegToIntersection point) intersectionPPointIsBehind pPoint = angleFound < realToFrac (ulpVal angleErr) where - (angleFound, (_,_, angleErr)) = angleBetween2PL (normalizeL $ outOf motorcycle) (eToPL $ lineSegToIntersectionP pPoint) + (angleFound, (_,_, angleErr)) = angleBetween2PL (outOf motorcycle) (eToPLine2 $ lineSegToIntersectionP pPoint) lineSegToIntersection myPoint = makeLineSeg (ePointOf motorcycle) myPoint lineSegToIntersectionP myPPoint = makeLineSeg (ePointOf motorcycle) (pToEPoint2 myPPoint) motorcyclePoint = canonicalizePPoint2 $ pPointOf motorcycle diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index 159b2242d..fe94bdf40 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -403,7 +403,7 @@ prop_perpAt90Degrees x y rawX2 y2 rawD <> "angle2: " <> show angle2 <> "\n" <> "angle2Err: " <> show angle2Err <> "\n" where - (angle2, (_,_, angle2Err)) = angleBetween2PL (normedPLine3, norm3Err) (normedPLine4, norm4Err) + (angle2, (_,_, angle2Err)) = angleBetween2PL normedPLine3 normedPLine4 (PPoint2 rawBisectorStart, bisectorStartErr) = interpolate2PP sourceStart sourceEnd 0.5 0.5 (bisectorEndRaw, bisectorEndRawErr) = pPointOnPerpWithErr pline4 (PPoint2 rawBisectorStart) d (bisectorEnd, bisectorEndErr) = canonicalize bisectorEndRaw @@ -715,7 +715,7 @@ myAngleBetween a b <> show res <> "\n" <> show resErr <> "\n" where - (res, (_,_, resErr)) = angleBetween2PL (a, mempty) (b, mempty) + (res, (_,_, resErr)) = angleBetween2PL a b -- | ensure that a right angle with one side parallel with an axis and the other side parallel to the other axis results in a line through the origin point. -- NOTE: hack, using angleBetween to filter out minor numerical imprecision. @@ -1323,8 +1323,8 @@ prop_obtuseBisectorOnBiggerSide_makeINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 (angleFound, (_,_, angleErr)) = angleBetween2PL bisector1 bisector2 eNode = randomENode x y d1 rawR1 d2 rawR2 iNode = randomINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 - bisector1 = normalizeL $ outOf iNode - bisector2 = normalizeL $ flipL $ outOf eNode + bisector1 = outOf iNode + bisector2 = flipL $ outOf eNode prop_eNodeTowardIntersection1 :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> Positive ℝ -> Radian ℝ -> Expectation prop_eNodeTowardIntersection1 x y d1 rawR1 d2 rawR2 = l1TowardIntersection --> True @@ -1366,12 +1366,12 @@ prop_PLinesIntersectAtOrigin rawX y rawX2 rawY2 <> show intersectionErr <> "\n" where originPPoint2 = makePPoint2 0 0 - (foundDistance, UlpSum distanceErr) = distance2PP originPPoint2 intersectionCPPoint2 - (intersectionCPPoint2, UlpSum canonicalizationErr) = canonicalize intersectionPPoint2 + (foundDistance, UlpSum distanceErr) = distance2PP originPPoint2 intersectionPPoint2 (intersectionPPoint2, intersectionErr) = intersect2PL randomPLine1 randomPLine2 (randomPLine1, _) = randomPLineThroughOrigin x y (randomPLine2, _) = randomPLineThroughOrigin x2 y2 - errSum = distanceErr + canonicalizationErr + (_, canonicalizationErr) = canonicalize intersectionPPoint2 + errSum = distanceErr -- + canonicalizationErr x,x2,y2 :: ℝ x = coerce rawX x2 @@ -1394,12 +1394,12 @@ prop_PLinesIntersectAtPoint rawX y rawX2 rawY2 targetX targetY <> show intersectionErr <> "\n" where (targetPPoint2) = makePPoint2 (coerce targetX) (coerce targetY) - (foundDistance, UlpSum distanceErr) = distance2PP targetPPoint2 intersectionCPPoint2 - (intersectionCPPoint2, UlpSum canonicalizationErr) = canonicalize intersectionPPoint2 + (foundDistance, UlpSum distanceErr) = distance2PP targetPPoint2 intersectionPPoint2 (intersectionPPoint2, intersectionErr) = intersect2PL randomPLine1 randomPLine2 (randomPLine1, _) = randomPLineWithErr x y targetX targetY (randomPLine2, _) = randomPLineWithErr x2 y2 targetX targetY - errSum = distanceErr + canonicalizationErr + (_, canonicalizationErr) = canonicalize intersectionPPoint2 + errSum = distanceErr -- + canonicalizationErr x,x2,y2 :: ℝ x = coerce rawX x2 From 0c88df268fea27cc8de168054a62f2e018f4a3ab Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 30 Oct 2022 10:01:33 +0000 Subject: [PATCH 043/206] move canonicalizedIntersectionOf2PL into the ProjectiveLine2 typeclass. --- Graphics/Slicer/Math/PGA.hs | 2 +- Graphics/Slicer/Math/PGAPrimitives.hs | 13 ++++++++----- Graphics/Slicer/Math/Skeleton/Concave.hs | 2 +- 3 files changed, 10 insertions(+), 7 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 08302e83d..b77b4d05a 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -85,7 +85,7 @@ import Graphics.Slicer.Definitions (ℝ) import Graphics.Slicer.Math.Definitions (Point2(Point2), LineSeg(LineSeg), addPoints, startPoint, endPoint, distance) -import Graphics.Slicer.Math.GeometricAlgebra (GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎣+), (⎤+), (⨅), (⨅+), (∧), (•), addValWithoutErr, addVecPairWithoutErr, getVal, mulScalarVecWithErr, sumErrVals, ulpVal, valOf) +import Graphics.Slicer.Math.GeometricAlgebra (GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎣+), (⎤+), (⨅), (⨅+), (•), addValWithoutErr, addVecPairWithoutErr, getVal, mulScalarVecWithErr, sumErrVals, ulpVal, valOf) import Graphics.Slicer.Math.Line (combineLineSegs) diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index cb911259b..7d9ef5459 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -20,7 +20,7 @@ {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} -- | The purpose of this file is to hold primitive projective geometric algebraic arithmatic. --- Primitives here are defined as functions that work on types which have an implementation of the ProjectivePoint2 or ProjectiveLine2 typeclasses. +-- Primitives here are defined as functions that work on types which have an implementation of the ProjectivePoint2 or ProjectiveLine2 typeclasses. Think "pure 2D PGA functions only". module Graphics.Slicer.Math.PGAPrimitives ( @@ -43,6 +43,7 @@ module Graphics.Slicer.Math.PGAPrimitives ProjectiveLine2( angleBetween2PL, angleCosBetween2PL, + canonicalizedIntersectionOf2PL, flipL, forceBasisOfL, fuzzinessOfL, @@ -64,7 +65,6 @@ module Graphics.Slicer.Math.PGAPrimitives pToEP, vecOfP ), - canonicalizedIntersectionOf2PL, pLineErrAtPPoint, xIntercept, yIntercept @@ -155,6 +155,7 @@ newtype NPLine2 = NPLine2 GVec class ProjectiveLine2 a where angleBetween2PL :: (ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, UlpSum)) angleCosBetween2PL :: (ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, UlpSum)) + canonicalizedIntersectionOf2PL :: (ProjectiveLine2 b) => a -> b -> Maybe (CPPoint2, (PLine2Err, PLine2Err, PPoint2Err)) consLikeL :: a -> (GVec -> a) flipL :: a -> a forceBasisOfL :: a -> a @@ -171,6 +172,7 @@ instance ProjectiveLine2 NPLine2 where where crushErr (res, (n1,n2,_,resErr)) = (res, (n1,n2,resErr)) angleCosBetween2PL l1 l2 = angleCosBetweenProjectiveLines l1 l2 + canonicalizedIntersectionOf2PL l1 l2 = canonicalizedIntersectionOfProjectiveLines l1 l2 consLikeL _ = NPLine2 flipL l = flipProjectiveLine l forceBasisOfL l = forceProjectiveLineBasis l @@ -187,6 +189,7 @@ instance ProjectiveLine2 PLine2 where where crushErr (res, (n1,n2,_,ulpSum)) = (res, (n1,n2,ulpSum)) angleCosBetween2PL l1 l2 = angleCosBetweenProjectiveLines l1 l2 + canonicalizedIntersectionOf2PL l1 l2 = canonicalizedIntersectionOfProjectiveLines l1 l2 consLikeL _ = PLine2 flipL l = flipProjectiveLine l forceBasisOfL l = forceProjectiveLineBasis l @@ -267,7 +270,7 @@ forceProjectiveLineBasis line _ -> Nothing vec@(GVec vals) = vecOfL line --- | determine the amount of error when trying to resolve a projective line. +-- | determine the amount of translation error when trying to resolve a projective line. -- NOTE: a projective line's error varies depending where on that line you are trying to resolve it. -- for complete results, combine this with scaling xIntercept and yIntercept. fuzzinessOfProjectiveLine :: (ProjectiveLine2 a) => (a, PLine2Err) -> UlpSum @@ -477,8 +480,8 @@ angleCosBetweenProjectiveLines line1 line2 -- | get the Canonicalized intersection of two lines. -- NOTE: Returns Nothing when the PLines are (anti)parallel. -canonicalizedIntersectionOf2PL :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Maybe (CPPoint2, (PLine2Err, PLine2Err, PPoint2Err)) -canonicalizedIntersectionOf2PL l1 l2 +canonicalizedIntersectionOfProjectiveLines :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Maybe (CPPoint2, (PLine2Err, PLine2Err, PPoint2Err)) +canonicalizedIntersectionOfProjectiveLines l1 l2 | isNothing foundVal = Nothing | otherwise = Just (cpp1, (l1Err, l2Err, pp1Err <> cpp1Err)) where diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index 71d9c4cdb..a313754c1 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -62,7 +62,7 @@ import Graphics.Slicer.Math.Intersections (intersectionOf, intersectionBetween, import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, distancePPointToPLine, eToPLine2, join2CPPoint2, normalizePLine2) -import Graphics.Slicer.Math.PGA (Arcable(errOfOut, hasArc, outOf), Pointable(canPoint, pPointOf), PLine2(PLine2), PLine2Err, ProjectivePoint2, CPPoint2(CPPoint2), PPoint2(PPoint2), canonicalize, distance2PP, flipL, normalizeL, pLineIsLeft, angleBetween2PL, distancePPointToPLineWithErr, NPLine2(NPLine2)) +import Graphics.Slicer.Math.PGA (Arcable(errOfOut, hasArc, outOf), Pointable(canPoint, pPointOf), PLine2(PLine2), PLine2Err, ProjectivePoint2, CPPoint2(CPPoint2), PPoint2(PPoint2), canonicalize, distance2PP, flipL, pLineIsLeft, angleBetween2PL, distancePPointToPLineWithErr, NPLine2(NPLine2)) import Graphics.Slicer.Math.Skeleton.Definitions (ENode(ENode), ENodeSet(ENodeSet), INode(INode), INodeSet(INodeSet), NodeTree(NodeTree), concavePLines, getFirstLineSeg, getLastLineSeg, finalOutOf, firstInOf, getPairs, indexPLinesTo, insOf, lastINodeOf, linePairs, makeINode, sortedPLinesWithErr, isLoop) From 36066fd5831b9a82f3acdf4bc10f51b011a3104b Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 30 Oct 2022 11:48:49 +0000 Subject: [PATCH 044/206] let canonicalizedIntersectionOf2PL do normalization error calculation for angleCosBetween2PL. --- Graphics/Slicer/Math/PGAPrimitives.hs | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index 7d9ef5459..d5293fc9c 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -20,7 +20,7 @@ {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} -- | The purpose of this file is to hold primitive projective geometric algebraic arithmatic. --- Primitives here are defined as functions that work on types which have an implementation of the ProjectivePoint2 or ProjectiveLine2 typeclasses. Think "pure 2D PGA functions only". +-- Primitives here are defined as functions that work on types which have an implementation of the ProjectivePoint2 or ProjectiveLine2 typeclasses. Think "Pure 2D PGA functions only". module Graphics.Slicer.Math.PGAPrimitives ( @@ -467,16 +467,14 @@ angleCosBetweenProjectiveLines line1 line2 | otherwise = (angle, (npl1Err, npl2Err, sumPPointErrs iPointErr)) where angle = valOf 0 $ getVal [GEZero 1, GEPlus 1, GEPlus 2] $ (\(GVec a) -> a) $ lvec2 ∧ (motor • iPointVec • antiMotor) - (CPPoint2 iPointVec, (_,_,PPoint2Err _ iPointErr _ _ _ _ _)) = fromJust canonicalizedIntersection + (CPPoint2 iPointVec, (npl1Err, npl2Err, PPoint2Err _ iPointErr _ _ _ _ _)) = fromJust canonicalizedIntersection motor = addVecPairWithoutErr (lvec1 • gaI) (GVec [GVal 1 (singleton G0)]) antiMotor = addVecPairWithoutErr (lvec1 • gaI) (GVec [GVal (-1) (singleton G0)]) - canonicalizedIntersection = canonicalizedIntersectionOf2PL (NPLine2 lvec1) (NPLine2 lvec2) + canonicalizedIntersection = canonicalizedIntersectionOf2PL line1 line2 -- I, the infinite point. gaI = GVec [GVal 1 (fromList [GEZero 1, GEPlus 1, GEPlus 2])] - lvec1 = vecOfL $ forceBasisOfL npl1 - lvec2 = vecOfL $ forceBasisOfL npl2 - (npl1, npl1Err) = normalizeProjectiveLineWithErr line1 - (npl2, npl2Err) = normalizeProjectiveLineWithErr line2 + lvec1 = vecOfL $ forceBasisOfL line1 + lvec2 = vecOfL $ forceBasisOfL line2 -- | get the Canonicalized intersection of two lines. -- NOTE: Returns Nothing when the PLines are (anti)parallel. From f99cc2cfd069ff69872926cc3eb8377316f4e534 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 30 Oct 2022 13:52:08 +0000 Subject: [PATCH 045/206] change translateL to return a PLine2Err instead of a UlpSum. --- Graphics/Slicer/Math/PGAPrimitives.hs | 6 +++--- tests/Math/PGA.hs | 8 ++++---- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index d5293fc9c..a4ac64bd7 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -164,7 +164,7 @@ class ProjectiveLine2 a where normalizeL :: a -> (NPLine2, PLine2Err) normOfL :: a -> (ℝ, PLine2Err) sqNormOfL :: a -> (ℝ, UlpSum) - translateL :: a -> ℝ -> (PLine2, UlpSum) + translateL :: a -> ℝ -> (PLine2, PLine2Err) vecOfL :: a -> GVec instance ProjectiveLine2 NPLine2 where @@ -181,7 +181,7 @@ instance ProjectiveLine2 NPLine2 where normalizeL l = (l, mempty) normOfL l = normOfProjectiveLineWithErr l sqNormOfL l = squaredNormOfProjectiveLineWithErr l - translateL l d = (\(r,(PLine2Err _ _ _ _ t _)) -> (r,t)) $ translateProjectiveLineWithErr l d + translateL l d = translateProjectiveLineWithErr l d vecOfL (NPLine2 v) = v instance ProjectiveLine2 PLine2 where @@ -198,7 +198,7 @@ instance ProjectiveLine2 PLine2 where normalizeL l = normalizeProjectiveLineWithErr l normOfL l = normOfProjectiveLineWithErr l sqNormOfL l = squaredNormOfProjectiveLineWithErr l - translateL l d = (\(r,(PLine2Err _ _ _ _ t _)) -> (r,t)) $ translateProjectiveLineWithErr l d + translateL l d = translateProjectiveLineWithErr l d vecOfL (PLine2 v) = v -- | the two types of error of a projective line. diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index fe94bdf40..d67f21a55 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -63,7 +63,7 @@ import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(P -- The primitives of our PGA only library, and error estimation code. -import Graphics.Slicer.Math.PGAPrimitives (pLineErrAtPPoint, xIntercept, yIntercept) +import Graphics.Slicer.Math.PGAPrimitives (fuzzinessOfL, pLineErrAtPPoint, xIntercept, yIntercept) -- Our Contour library. import Graphics.Slicer.Math.Contour (contourContainsContour, getContours, pointsOfContour, numPointsOfContour, justOneContourFrom, lineSegsOfContour, makeLineSegContour, makePointContour, insideIsLeft, innerContourPoint, firstPointPairOfContour, firstLineSegOfContour) @@ -465,11 +465,11 @@ prop_PerpTranslateID x y dx dy rawT <> "resErr: " <> show resErr <> "\n" where res = distanceBetweenPLines resPLine origPLine - (resPLine, UlpSum resPLineErr) = translateL translatedPLine (-t) - (translatedPLine, UlpSum translatedPLineErr) = translateL origPLine t + (resPLine, resPLineErr) = translateL translatedPLine (-t) + (translatedPLine, translatedPLineErr) = translateL origPLine t (origPLine, origPLineErr) = randomPLineWithErr x y dx dy resErr, t :: ℝ - resErr = realToFrac (resPLineErr + translatedPLineErr) + resErr = realToFrac $ ulpVal $ fuzzinessOfL (resPLine, resPLineErr) <> fuzzinessOfL (translatedPLine, translatedPLineErr) t = coerce rawT pgaSpec :: Spec From a6479eb3e2df5a533de6ef153c78147a0bb052e3 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 30 Oct 2022 21:19:44 +0000 Subject: [PATCH 046/206] comment changes, and internal function name changes. mostly removing WithErr from function names. --- Graphics/Slicer/Math/PGAPrimitives.hs | 172 +++++++++++++------------- 1 file changed, 85 insertions(+), 87 deletions(-) diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index a4ac64bd7..391d5a784 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -168,7 +168,7 @@ class ProjectiveLine2 a where vecOfL :: a -> GVec instance ProjectiveLine2 NPLine2 where - angleBetween2PL l1 l2 = crushErr $ angleBetweenWithErr l1 l2 + angleBetween2PL l1 l2 = crushErr $ angleBetween l1 l2 where crushErr (res, (n1,n2,_,resErr)) = (res, (n1,n2,resErr)) angleCosBetween2PL l1 l2 = angleCosBetweenProjectiveLines l1 l2 @@ -177,15 +177,15 @@ instance ProjectiveLine2 NPLine2 where flipL l = flipProjectiveLine l forceBasisOfL l = forceProjectiveLineBasis l fuzzinessOfL l = fuzzinessOfProjectiveLine l - intersect2PL l1 l2 = intersectionOfProjectiveLinesWithErr l1 l2 + intersect2PL l1 l2 = intersectionOfProjectiveLines l1 l2 normalizeL l = (l, mempty) - normOfL l = normOfProjectiveLineWithErr l - sqNormOfL l = squaredNormOfProjectiveLineWithErr l - translateL l d = translateProjectiveLineWithErr l d + normOfL l = normOfProjectiveLine l + sqNormOfL l = squaredNormOfProjectiveLine l + translateL l d = translateProjectiveLine l d vecOfL (NPLine2 v) = v instance ProjectiveLine2 PLine2 where - angleBetween2PL l1 l2 = crushErr $ angleBetweenWithErr l1 l2 + angleBetween2PL l1 l2 = crushErr $ angleBetween l1 l2 where crushErr (res, (n1,n2,_,ulpSum)) = (res, (n1,n2,ulpSum)) angleCosBetween2PL l1 l2 = angleCosBetweenProjectiveLines l1 l2 @@ -194,11 +194,11 @@ instance ProjectiveLine2 PLine2 where flipL l = flipProjectiveLine l forceBasisOfL l = forceProjectiveLineBasis l fuzzinessOfL l = fuzzinessOfProjectiveLine l - intersect2PL l1 l2 = intersectionOfProjectiveLinesWithErr l1 l2 - normalizeL l = normalizeProjectiveLineWithErr l - normOfL l = normOfProjectiveLineWithErr l - sqNormOfL l = squaredNormOfProjectiveLineWithErr l - translateL l d = translateProjectiveLineWithErr l d + intersect2PL l1 l2 = intersectionOfProjectiveLines l1 l2 + normalizeL l = normalizeProjectiveLine l + normOfL l = normOfProjectiveLine l + sqNormOfL l = squaredNormOfProjectiveLine l + translateL l d = translateProjectiveLine l d vecOfL (PLine2 v) = v -- | the two types of error of a projective line. @@ -231,9 +231,9 @@ instance Monoid PLine2Err where -- | Return the sine of the angle between the two lines, along with the error. -- Results in a value that is ~+1 when a line points in the same direction of the other given line, and ~-1 when pointing backwards. --- FIXME: accept, and do something with input error. -angleBetweenWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, ([ErrVal], [ErrVal]), UlpSum)) -angleBetweenWithErr line1 line2 = (scalarPart likeRes, resErr) +-- FIXME: accept input error, and do something with it. +angleBetween :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, ([ErrVal], [ErrVal]), UlpSum)) +angleBetween line1 line2 = (scalarPart likeRes, resErr) where resErr = (npl1Err, npl2Err, (likeMulErr,likeAddErr), ulpSum) -- FIXME: this returned ULPsum is wrong. actually try to interpret it. @@ -241,8 +241,8 @@ angleBetweenWithErr line1 line2 = (scalarPart likeRes, resErr) (likeRes, (likeMulErr, likeAddErr)) = l1 ⎣+ l2 l1 = vecOfL $ forceBasisOfL npl1 l2 = vecOfL $ forceBasisOfL npl2 - (npl1, npl1Err) = normalizeProjectiveLineWithErr line1 - (npl2, npl2Err) = normalizeProjectiveLineWithErr line2 + (npl1, npl1Err) = normalizeL line1 + (npl2, npl2Err) = normalizeL line2 -- | Reverse a line. same line, but pointed in the other direction. flipProjectiveLine :: (ProjectiveLine2 a) => a -> a @@ -270,9 +270,9 @@ forceProjectiveLineBasis line _ -> Nothing vec@(GVec vals) = vecOfL line --- | determine the amount of translation error when trying to resolve a projective line. --- NOTE: a projective line's error varies depending where on that line you are trying to resolve it. --- for complete results, combine this with scaling xIntercept and yIntercept. +-- | Determine the amount of translation error when trying to resolve a projective line. +-- NOTE: A projective line's error varies depending where on that line you are trying to resolve it. +-- For complete results, combine this with scaling xIntercept and yIntercept. fuzzinessOfProjectiveLine :: (ProjectiveLine2 a) => (a, PLine2Err) -> UlpSum fuzzinessOfProjectiveLine (inPLine, inPLineErr) = tUlp <> joinAddTErr <> joinMulTErr <> normalizeTErr <> additionTErr where @@ -283,35 +283,33 @@ fuzzinessOfProjectiveLine (inPLine, inPLineErr) = tUlp <> joinAddTErr <> joinMul joinAddTErr = eValOf mempty (getVal [GEZero 1] joinAddErr) (_,normalizeErrRaw) = normalizeL inPLine --- | Find out where two lines intersect, returning a projective point, and the error quotent. --- Note that this should only be used when you can guarantee these are not collinear, or parallel. -intersectionOfProjectiveLinesWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PPoint2, (PLine2Err, PLine2Err, PPoint2Err)) -intersectionOfProjectiveLinesWithErr line1 line2 = (res, - (pl1ResErr, - pl2ResErr, - PPoint2Err resErrs mempty mempty mempty mempty iAngleErr iAngleUnlikeErr)) +-- | Find out where two lines intersect, returning a projective point, and the error quotents. +-- Note: This should only be used when you can guarantee the input lines are not collinear, or parallel. +intersectionOfProjectiveLines :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PPoint2, (PLine2Err, PLine2Err, PPoint2Err)) +intersectionOfProjectiveLines line1 line2 = (res,(line1Err, line2Err, resErr)) where + (res, (line1Err, line2Err, resUnlikeErrs)) = meetOfProjectiveLines line1 line2 + resErr = PPoint2Err resUnlikeErrs mempty mempty mempty mempty iAngleErr iAngleUnlikeErr -- Since the angle of intersection has an effect on how well this point was resolved, save it with the point. - (iAngleErr,(_,_,iAngleUnlikeErr,_)) = angleBetweenWithErr line1 line2 - (res, (pl1ResErr, pl2ResErr, resErrs)) = meetOfProjectiveLinesWithErr line1 line2 + (iAngleErr,(_,_,iAngleUnlikeErr,_)) = angleBetween line1 line2 -- | A typed meet function. the meeting of two lines is a point. --- kept separate from pLineIntersection for verification reasons. -meetOfProjectiveLinesWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PPoint2, (PLine2Err, PLine2Err, ([ErrVal], [ErrVal]))) -meetOfProjectiveLinesWithErr line1 line2 = (PPoint2 res, - (npl1Err, - npl2Err, - resUnlikeErr)) +-- Kept separate from pLineIntersection for verification reasons. +meetOfProjectiveLines :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PPoint2, (PLine2Err, PLine2Err, ([ErrVal], [ErrVal]))) +meetOfProjectiveLines line1 line2 = (PPoint2 res, + (npl1Err, + npl2Err, + resUnlikeErr)) where (res, resUnlikeErr) = pv1 ⎤+ pv2 pv1 = vecOfL $ forceBasisOfL npl1 pv2 = vecOfL $ forceBasisOfL npl2 - (npl1, npl1Err) = normalizeProjectiveLineWithErr line1 - (npl2, npl2Err) = normalizeProjectiveLineWithErr line2 + (npl1, npl1Err) = normalizeL line1 + (npl2, npl2Err) = normalizeL line2 -- | Normalize a Projective Line. -normalizeProjectiveLineWithErr :: (ProjectiveLine2 a) => a -> (NPLine2, PLine2Err) -normalizeProjectiveLineWithErr line = (res, resErr) +normalizeProjectiveLine :: (ProjectiveLine2 a) => a -> (NPLine2, PLine2Err) +normalizeProjectiveLine line = (res, resErr) where (res, resErr) = case norm of 1.0 -> (NPLine2 vec , normErr) @@ -321,8 +319,8 @@ normalizeProjectiveLineWithErr line = (res, resErr) vec = vecOfL line -- | Find the norm of a given Projective Line. -normOfProjectiveLineWithErr :: (ProjectiveLine2 a) => a -> (ℝ, PLine2Err) -normOfProjectiveLineWithErr line = (res, resErr) +normOfProjectiveLine :: (ProjectiveLine2 a) => a -> (ℝ, PLine2Err) +normOfProjectiveLine line = (res, resErr) where (res, resErr) = case sqNormOfPLine2 of 1.0 -> (1.0 , PLine2Err mempty mempty mempty sqNormUlp mempty mempty) @@ -332,8 +330,8 @@ normOfProjectiveLineWithErr line = (res, resErr) (sqNormOfPLine2, sqNormUlp) = sqNormOfL line -- | Find the squared norm of a given Projective Line. -squaredNormOfProjectiveLineWithErr :: (ProjectiveLine2 a) => a -> (ℝ, UlpSum) -squaredNormOfProjectiveLineWithErr line = (res, ulpTotal) +squaredNormOfProjectiveLine :: (ProjectiveLine2 a) => a -> (ℝ, UlpSum) +squaredNormOfProjectiveLine line = (res, ulpTotal) where res = a*a+b*b a = valOf 0 $ getVal [GEPlus 1] vals @@ -346,8 +344,8 @@ squaredNormOfProjectiveLineWithErr line = (res, ulpTotal) -- | Translate a line a given distance along it's perpendicular bisector. -- Uses the property that translation of a line is expressed on the GEZero component. -translateProjectiveLineWithErr :: (ProjectiveLine2 a) => a -> ℝ -> (PLine2, PLine2Err) -translateProjectiveLineWithErr line d = (PLine2 res, normErr <> PLine2Err resErrs mempty mempty mempty tUlp mempty) +translateProjectiveLine :: (ProjectiveLine2 a) => a -> ℝ -> (PLine2, PLine2Err) +translateProjectiveLine line d = (PLine2 res, normErr <> PLine2Err resErrs mempty mempty mempty tUlp mempty) where (res, resErrs) = addVecPairWithErr m $ vecOfL line m = GVec [GVal tAdd (singleton (GEZero 1))] @@ -364,20 +362,20 @@ translateProjectiveLineWithErr line d = (PLine2 res, normErr <> PLine2Err resErr -- FIXME: accept a error on the projectivePoint, and return an error estimate. pLineErrAtPPoint :: (ProjectiveLine2 a, ProjectivePoint2 b) => (a, PLine2Err) -> b -> UlpSum pLineErrAtPPoint (inPLine, inPLineErr) errPoint - -- both intercepts are real. this line is not parallel or collinear to X or Y axises, and does not pass through the origin. + -- Both intercepts are real. This line is not parallel or collinear to X or Y axises, and does not pass through the origin. | xInterceptIsRight && yInterceptIsRight = tFuzz <> xInterceptFuzz <> yInterceptFuzz - -- only the xIntercept is real. this line is parallel to the Y axis. + -- Only the xIntercept is real. This line is parallel to the Y axis. | xInterceptIsRight = tFuzz <> rawXInterceptFuzz - -- only the yIntercept is real. this line is parallel to the X axis. + -- Only the yIntercept is real. This line is parallel to the X axis. | yInterceptIsRight = tFuzz <> rawYInterceptFuzz - -- passes through the origin? + -- This line passes through the origin (0,0). | otherwise = tFuzz where - xInterceptIsRight = isJust (xIntercept (nPLine,nPLineErr)) - && isRight (fst $ fromJust $ xIntercept (nPLine,nPLineErr)) + xInterceptIsRight = isJust (xIntercept (nPLine, nPLineErr)) + && isRight (fst $ fromJust $ xIntercept (nPLine, nPLineErr)) && fromRight 0 (fst $ fromJust $ xIntercept (nPLine, nPLineErr)) /= 0 - yInterceptIsRight = isJust (yIntercept (nPLine,nPLineErr)) - && isRight (fst $ fromJust $ yIntercept (nPLine,nPLineErr)) + yInterceptIsRight = isJust (yIntercept (nPLine, nPLineErr)) + && isRight (fst $ fromJust $ yIntercept (nPLine, nPLineErr)) && fromRight 0 (fst $ fromJust $ yIntercept (nPLine, nPLineErr)) /= 0 xInterceptFuzz = UlpSum $ ulpVal rawXInterceptFuzz * ((realToFrac xInterceptDistance + ulpVal rawXInterceptFuzz) / realToFrac yInterceptDistance) * realToFrac (abs xPos) yInterceptFuzz = UlpSum $ ulpVal rawYInterceptFuzz * ((realToFrac yInterceptDistance + ulpVal rawYInterceptFuzz) / realToFrac xInterceptDistance) * realToFrac (abs yPos) @@ -391,20 +389,20 @@ pLineErrAtPPoint (inPLine, inPLineErr) errPoint nPLineErr = nPLineErrRaw <> inPLineErr (nPLine, nPLineErrRaw) = normalizeL inPLine --- | find the approximate point that a given line crosses the X axis. +-- | Find the point that a given line crosses the X axis. xIntercept :: (ProjectiveLine2 a) => (a, PLine2Err) -> Maybe (Either a ℝ, UlpSum) xIntercept (line, lineErr) - -- handle a line that is parallel to the X axis. + -- Handle a line that is parallel to the X axis. | isNothing rawX = Nothing - -- use X and T to calculate our answer + -- Use X and T to calculate our answer. | isJust rawT = Just (Right xDivRes, xDivErr) - -- is colinear with the X axis. + -- This line is (anti)colinear with the X axis. | isNothing rawY = Just (Left line, mempty) - -- we have an X and a Y, but no T? this line passes through the origin. + -- We have an X and a Y, but no T component? This line passes through the origin. | isNothing rawT = Just (Right 0, mempty) | otherwise = error "totality failure: we should never get here." where - -- negate is required, because the result is inverted. + -- Negate is required, because the result is inverted. xDivRes = negate $ valOf 0 rawT / valOf 0 rawX xDivErr = rawXErr <> rawTErr <> UlpSum (abs $ realToFrac $ doubleUlp xDivRes) rawTErr = eValOf mempty (getVal [GEZero 1] lAddErr) @@ -421,18 +419,18 @@ xIntercept (line, lineErr) rawY = getVal [GEPlus 2] pLineVals (GVec pLineVals) = vecOfL line --- | find the point that a given line crosses the Y axis. +-- | Find the point that a given line crosses the Y axis. yIntercept :: (ProjectiveLine2 a) => (a, PLine2Err) -> Maybe (Either a ℝ, UlpSum) yIntercept (line, lineErr) - -- handle a line that is parallel to the Y axis. + -- Handle a line that is parallel to the Y axis. | isNothing rawY = Nothing - -- use Y and T to calculate our answer + -- Use Y and T to calculate our answer. | isJust rawT = Just $ (Right yDivRes, yDivErr) - -- is along the Y axis. + -- This line is (anti)colnear with the Y axis. | isNothing rawX = Just (Left line, mempty) -- we have an X and a Y? this line passes through the origin. | isNothing rawT = Just (Right 0, mempty) - | otherwise = error "we should never get here" + | otherwise = error "totality failure: we should never get here" where -- negate is required, because the result is inverted. yDivRes = negate $ valOf 0 rawT / valOf 0 rawY @@ -560,16 +558,16 @@ class (Show a) => ProjectivePoint2 a where vecOfP :: a -> GVec instance ProjectivePoint2 PPoint2 where - canonicalize p = canonicalizePPoint2WithErr p + canonicalize p = canonicalizePPoint2 p consLikeP (PPoint2 _) = PPoint2 - distance2PP p1 p2 = crushErr $ distanceBetweenProjectivePointsWithErr p1 p2 + distance2PP p1 p2 = crushErr $ distanceBetweenProjectivePoints p1 p2 where crushErr (a,(_,_,_,b)) = (a,b) forceBasisOfP a = forceProjectivePointBasis a fuzzinessOfP a = pPointFuzziness a - idealNormOfP a = idealNormPPoint2WithErr a - interpolate2PP p1 p2 = pPointBetweenPPointsWithErr p1 p2 - join2PP a b = crushErr $ join2ProjectivePointsWithErr a b + idealNormOfP a = idealNormPPoint2 a + interpolate2PP p1 p2 = pPointBetweenPPoints p1 p2 + join2PP a b = crushErr $ join2ProjectivePoints a b where crushErr (res, (_,_,resErr)) = (res, resErr) pToEP p = crushErr $ fromMaybe (error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point.") $ projectivePointToPoint2 p @@ -580,14 +578,14 @@ instance ProjectivePoint2 PPoint2 where instance ProjectivePoint2 CPPoint2 where canonicalize p = (p, mempty) consLikeP (CPPoint2 _) = CPPoint2 - distance2PP p1 p2 = crushErr $ distanceBetweenProjectivePointsWithErr p1 p2 + distance2PP p1 p2 = crushErr $ distanceBetweenProjectivePoints p1 p2 where crushErr (a,(_,_,_,b)) = (a,b) forceBasisOfP p = forceProjectivePointBasis p fuzzinessOfP a = pPointFuzziness a - idealNormOfP p = idealNormPPoint2WithErr p - interpolate2PP p1 p2 = pPointBetweenPPointsWithErr p1 p2 - join2PP a b = crushErr $ join2ProjectivePointsWithErr a b + idealNormOfP p = idealNormPPoint2 p + interpolate2PP p1 p2 = pPointBetweenPPoints p1 p2 + join2PP a b = crushErr $ join2ProjectivePoints a b where crushErr (res, (_,_,resErr)) = (res, resErr) pToEP p = crushErr $ fromMaybe (error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point.") $ projectivePointToPoint2 p @@ -598,8 +596,8 @@ instance ProjectivePoint2 CPPoint2 where -- | canonicalize a euclidian point. -- Note: Normalization of euclidian points in PGA is really just canonicalization. -- Note: For precision, we go through some work to not bother dividing the GP1,GP2 component with itsself, and just substitute in the answer, as exactly 1. -canonicalizePPoint2WithErr :: (ProjectivePoint2 a) => a -> (CPPoint2, PPoint2Err) -canonicalizePPoint2WithErr point +canonicalizePPoint2 :: (ProjectivePoint2 a) => a -> (CPPoint2, PPoint2Err) +canonicalizePPoint2 point | isNothing foundVal = error $ "tried to canonicalize an ideal point: " <> show point <> "\n" -- Handle the ID case. | valOf 1 foundVal == 1 = (CPPoint2 $ GVec rawVals, mempty) @@ -621,14 +619,14 @@ canonicalizePPoint2WithErr point (GVec rawVals) = vecOfP point foundVal = getVal [GEPlus 1, GEPlus 2] rawVals -distanceBetweenProjectivePointsWithErr :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> (ℝ, (PPoint2Err, PPoint2Err, PLine2Err, UlpSum)) -distanceBetweenProjectivePointsWithErr point1 point2 = (res, (cPoint1Err, cPoint2Err, resErr <> newPLineErr, ulpTotal)) +distanceBetweenProjectivePoints :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> (ℝ, (PPoint2Err, PPoint2Err, PLine2Err, UlpSum)) +distanceBetweenProjectivePoints point1 point2 = (res, (cPoint1Err, cPoint2Err, resErr <> newPLineErr, ulpTotal)) where ulpTotal = pLineErrAtPPoint (newPLine, newPLineErr) cPoint1 (res, resErr) = normOfL newPLine (newPLine, newPLineErr) = join2PP cPoint1 cPoint2 - (cPoint1, cPoint1Err) = canonicalizePPoint2WithErr point1 - (cPoint2, cPoint2Err) = canonicalizePPoint2WithErr point2 + (cPoint1, cPoint1Err) = canonicalize point1 + (cPoint2, cPoint2Err) = canonicalize point2 -- | runtime basis coersion. ensure all of the '0' components exist on a Projective Point. forceProjectivePointBasis :: (ProjectivePoint2 a) => a -> a @@ -645,8 +643,8 @@ forceProjectivePointBasis point vec@(GVec vals) = vecOfP point -- | find the idealized norm of a projective point (ideal or not). -idealNormPPoint2WithErr :: (ProjectivePoint2 a) => a -> (ℝ, UlpSum) -idealNormPPoint2WithErr ppoint +idealNormPPoint2 :: (ProjectivePoint2 a) => a -> (ℝ, UlpSum) +idealNormPPoint2 ppoint | preRes == 0 = (0, mempty) | otherwise = (res, ulpTotal) where @@ -665,19 +663,19 @@ idealNormPPoint2WithErr ppoint (GVec rawVals) = vecOfP ppoint -- | a typed join function. join two points, returning a line. -join2ProjectivePointsWithErr :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> (PLine2, (PPoint2Err, PPoint2Err, PLine2Err)) -join2ProjectivePointsWithErr pp1 pp2 = (PLine2 res, +join2ProjectivePoints :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> (PLine2, (PPoint2Err, PPoint2Err, PLine2Err)) +join2ProjectivePoints pp1 pp2 = (PLine2 res, (cp1Errs, cp2Errs, PLine2Err mempty mempty mempty mempty mempty resUlp)) where (res,resUlp) = pv1 ∨+ pv2 pv1 = vecOfP $ forceBasisOfP cp1 pv2 = vecOfP $ forceBasisOfP cp2 - (cp1, cp1Errs) = canonicalizePPoint2WithErr pp1 - (cp2, cp2Errs) = canonicalizePPoint2WithErr pp2 + (cp1, cp1Errs) = canonicalize pp1 + (cp2, cp2Errs) = canonicalize pp2 -- FIXME: automatically raise addVecRes to a CPPoint2 if it turns out to be canonical? -pPointBetweenPPointsWithErr :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> ℝ -> ℝ -> (PPoint2, UlpSum) -pPointBetweenPPointsWithErr startP stopP weight1 weight2 +pPointBetweenPPoints :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> ℝ -> ℝ -> (PPoint2, UlpSum) +pPointBetweenPPoints startP stopP weight1 weight2 | isNothing foundVal = error "tried to generate an ideal point?" | otherwise = (PPoint2 addVecRes, ulpSum) where @@ -697,7 +695,7 @@ projectivePointToPoint2 ppoint | e12Val == 0 = Nothing | otherwise = Just (Point2 (xVal, yVal), cpErrs) where - (CPPoint2 (GVec vals), cpErrs) = canonicalizePPoint2WithErr ppoint + (CPPoint2 (GVec vals), cpErrs) = canonicalize ppoint xVal = negate $ valOf 0 $ getVal [GEZero 1, GEPlus 2] vals yVal = valOf 0 $ getVal [GEZero 1, GEPlus 1] vals e12Val = valOf 0 (getVal [GEPlus 1, GEPlus 2] rawVals) From 8b51cefd6332b3965fd5285726115964da3602f0 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Mon, 31 Oct 2022 21:09:24 +0000 Subject: [PATCH 047/206] rename functions and clean up comments. --- Graphics/Slicer/Math/PGAPrimitives.hs | 92 +++++++++++++-------------- 1 file changed, 46 insertions(+), 46 deletions(-) diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index 391d5a784..570274208 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -168,7 +168,7 @@ class ProjectiveLine2 a where vecOfL :: a -> GVec instance ProjectiveLine2 NPLine2 where - angleBetween2PL l1 l2 = crushErr $ angleBetween l1 l2 + angleBetween2PL l1 l2 = crushErr $ angleBetweenProjectiveLines l1 l2 where crushErr (res, (n1,n2,_,resErr)) = (res, (n1,n2,resErr)) angleCosBetween2PL l1 l2 = angleCosBetweenProjectiveLines l1 l2 @@ -185,7 +185,7 @@ instance ProjectiveLine2 NPLine2 where vecOfL (NPLine2 v) = v instance ProjectiveLine2 PLine2 where - angleBetween2PL l1 l2 = crushErr $ angleBetween l1 l2 + angleBetween2PL l1 l2 = crushErr $ angleBetweenProjectiveLines l1 l2 where crushErr (res, (n1,n2,_,ulpSum)) = (res, (n1,n2,ulpSum)) angleCosBetween2PL l1 l2 = angleCosBetweenProjectiveLines l1 l2 @@ -232,8 +232,8 @@ instance Monoid PLine2Err where -- | Return the sine of the angle between the two lines, along with the error. -- Results in a value that is ~+1 when a line points in the same direction of the other given line, and ~-1 when pointing backwards. -- FIXME: accept input error, and do something with it. -angleBetween :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, ([ErrVal], [ErrVal]), UlpSum)) -angleBetween line1 line2 = (scalarPart likeRes, resErr) +angleBetweenProjectiveLines :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, ([ErrVal], [ErrVal]), UlpSum)) +angleBetweenProjectiveLines line1 line2 = (scalarPart likeRes, resErr) where resErr = (npl1Err, npl2Err, (likeMulErr,likeAddErr), ulpSum) -- FIXME: this returned ULPsum is wrong. actually try to interpret it. @@ -274,14 +274,14 @@ forceProjectiveLineBasis line -- NOTE: A projective line's error varies depending where on that line you are trying to resolve it. -- For complete results, combine this with scaling xIntercept and yIntercept. fuzzinessOfProjectiveLine :: (ProjectiveLine2 a) => (a, PLine2Err) -> UlpSum -fuzzinessOfProjectiveLine (inPLine, inPLineErr) = tUlp <> joinAddTErr <> joinMulTErr <> normalizeTErr <> additionTErr +fuzzinessOfProjectiveLine (line, lineErr) = tUlp <> joinAddTErr <> joinMulTErr <> normalizeTErr <> additionTErr where - (PLine2Err additionErr normalizeErr _ _ tUlp (joinMulErr, joinAddErr)) = inPLineErr <> normalizeErrRaw + (PLine2Err additionErr normalizeErr _ _ tUlp (joinMulErr, joinAddErr)) = lineErr <> normalizeErrRaw additionTErr = eValOf mempty (getVal [GEZero 1] additionErr) normalizeTErr = eValOf mempty (getVal [GEZero 1] normalizeErr) joinMulTErr = eValOf mempty (getVal [GEZero 1] joinMulErr) joinAddTErr = eValOf mempty (getVal [GEZero 1] joinAddErr) - (_,normalizeErrRaw) = normalizeL inPLine + (_,normalizeErrRaw) = normalizeL line -- | Find out where two lines intersect, returning a projective point, and the error quotents. -- Note: This should only be used when you can guarantee the input lines are not collinear, or parallel. @@ -291,10 +291,10 @@ intersectionOfProjectiveLines line1 line2 = (res,(line1Err, line2Err, resErr)) (res, (line1Err, line2Err, resUnlikeErrs)) = meetOfProjectiveLines line1 line2 resErr = PPoint2Err resUnlikeErrs mempty mempty mempty mempty iAngleErr iAngleUnlikeErr -- Since the angle of intersection has an effect on how well this point was resolved, save it with the point. - (iAngleErr,(_,_,iAngleUnlikeErr,_)) = angleBetween line1 line2 + (iAngleErr,(_,_,iAngleUnlikeErr,_)) = angleBetweenProjectiveLines line1 line2 -- | A typed meet function. the meeting of two lines is a point. --- Kept separate from pLineIntersection for verification reasons. +-- Kept separate from intersectionOfProjectiveLines for verification reasons. meetOfProjectiveLines :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PPoint2, (PLine2Err, PLine2Err, ([ErrVal], [ErrVal]))) meetOfProjectiveLines line1 line2 = (PPoint2 res, (npl1Err, @@ -361,7 +361,7 @@ translateProjectiveLine line d = (PLine2 res, normErr <> PLine2Err resErrs mempt -- | when given a PLine, and two points guaranteed to be on it, return the maximum distance between a given projective point known to be on the PLine and the 'real' line. -- FIXME: accept a error on the projectivePoint, and return an error estimate. pLineErrAtPPoint :: (ProjectiveLine2 a, ProjectivePoint2 b) => (a, PLine2Err) -> b -> UlpSum -pLineErrAtPPoint (inPLine, inPLineErr) errPoint +pLineErrAtPPoint (line, lineErr) errPoint -- Both intercepts are real. This line is not parallel or collinear to X or Y axises, and does not pass through the origin. | xInterceptIsRight && yInterceptIsRight = tFuzz <> xInterceptFuzz <> yInterceptFuzz -- Only the xIntercept is real. This line is parallel to the Y axis. @@ -386,8 +386,8 @@ pLineErrAtPPoint (inPLine, inPLineErr) errPoint tFuzz = fuzzinessOfL (nPLine, nPLineErr) -- FIXME: collect this error, and take it into account. (Point2 (xPos,yPos),_) = pToEP errPoint - nPLineErr = nPLineErrRaw <> inPLineErr - (nPLine, nPLineErrRaw) = normalizeL inPLine + nPLineErr = nPLineErrRaw <> lineErr + (nPLine, nPLineErrRaw) = normalizeL line -- | Find the point that a given line crosses the X axis. xIntercept :: (ProjectiveLine2 a) => (a, PLine2Err) -> Maybe (Either a ℝ, UlpSum) @@ -402,7 +402,7 @@ xIntercept (line, lineErr) | isNothing rawT = Just (Right 0, mempty) | otherwise = error "totality failure: we should never get here." where - -- Negate is required, because the result is inverted. + -- negate is required, because the result is inverted. xDivRes = negate $ valOf 0 rawT / valOf 0 rawX xDivErr = rawXErr <> rawTErr <> UlpSum (abs $ realToFrac $ doubleUlp xDivRes) rawTErr = eValOf mempty (getVal [GEZero 1] lAddErr) @@ -426,23 +426,23 @@ yIntercept (line, lineErr) | isNothing rawY = Nothing -- Use Y and T to calculate our answer. | isJust rawT = Just $ (Right yDivRes, yDivErr) - -- This line is (anti)colnear with the Y axis. + -- This line is (anti)colinear with the Y axis. | isNothing rawX = Just (Left line, mempty) - -- we have an X and a Y? this line passes through the origin. + -- We have an X and a Y, but no T component? This line passes through the origin. | isNothing rawT = Just (Right 0, mempty) - | otherwise = error "totality failure: we should never get here" + | otherwise = error "totality failure: we should never get here." where -- negate is required, because the result is inverted. yDivRes = negate $ valOf 0 rawT / valOf 0 rawY yDivErr = rawYErr <> rawTErr <> UlpSum (abs $ realToFrac $ doubleUlp yDivRes) rawTErr = eValOf mempty (getVal [GEZero 1] lAddErr) - <> eValOf mempty (getVal [GEZero 1] lNormalizeErr) - <> eValOf mempty (getVal [GEZero 1] lJoinAddErr) - <> eValOf mempty (getVal [GEZero 1] lJoinMulErr) + <> eValOf mempty (getVal [GEZero 1] lNormalizeErr) + <> eValOf mempty (getVal [GEZero 1] lJoinAddErr) + <> eValOf mempty (getVal [GEZero 1] lJoinMulErr) rawYErr = eValOf mempty (getVal [GEPlus 2] lAddErr) - <> eValOf mempty (getVal [GEPlus 2] lNormalizeErr) - <> eValOf mempty (getVal [GEPlus 2] lJoinAddErr) - <> eValOf mempty (getVal [GEPlus 2] lJoinMulErr) + <> eValOf mempty (getVal [GEPlus 2] lNormalizeErr) + <> eValOf mempty (getVal [GEPlus 2] lJoinAddErr) + <> eValOf mempty (getVal [GEPlus 2] lJoinMulErr) (PLine2Err lAddErr lNormalizeErr _ _ _ (lJoinMulErr, lJoinAddErr)) = lineErr rawT = getVal [GEZero 1] pLineVals rawX = getVal [GEPlus 1] pLineVals @@ -456,16 +456,16 @@ yIntercept (line, lineErr) -- | Find the cosine of the angle between the two lines, along with the error. -- Results in a value that is ~+1 when the first line points to the "left" of the second given line, and ~-1 when pointing "right". --- FIXME: iPointErr is not +/- radians. +-- FIXME: the sum of iPointErrVals is not +/- radians. -- FIXME: lots of places for precision related error here, that are not recorded or reported. -- FIXME: does not accept input imprecision. angleCosBetweenProjectiveLines :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, UlpSum)) angleCosBetweenProjectiveLines line1 line2 | isNothing canonicalizedIntersection = (0, mempty) - | otherwise = (angle, (npl1Err, npl2Err, sumPPointErrs iPointErr)) + | otherwise = (angle, (npl1Err, npl2Err, sumPPointErrs iPointErrVals)) where angle = valOf 0 $ getVal [GEZero 1, GEPlus 1, GEPlus 2] $ (\(GVec a) -> a) $ lvec2 ∧ (motor • iPointVec • antiMotor) - (CPPoint2 iPointVec, (npl1Err, npl2Err, PPoint2Err _ iPointErr _ _ _ _ _)) = fromJust canonicalizedIntersection + (CPPoint2 iPointVec, (npl1Err, npl2Err, PPoint2Err _ iPointErrVals _ _ _ _ _)) = fromJust canonicalizedIntersection motor = addVecPairWithoutErr (lvec1 • gaI) (GVec [GVal 1 (singleton G0)]) antiMotor = addVecPairWithoutErr (lvec1 • gaI) (GVec [GVal (-1) (singleton G0)]) canonicalizedIntersection = canonicalizedIntersectionOf2PL line1 line2 @@ -474,7 +474,7 @@ angleCosBetweenProjectiveLines line1 line2 lvec1 = vecOfL $ forceBasisOfL line1 lvec2 = vecOfL $ forceBasisOfL line2 --- | get the Canonicalized intersection of two lines. +-- | Get the Canonicalized intersection of two lines. -- NOTE: Returns Nothing when the PLines are (anti)parallel. canonicalizedIntersectionOfProjectiveLines :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Maybe (CPPoint2, (PLine2Err, PLine2Err, PPoint2Err)) canonicalizedIntersectionOfProjectiveLines l1 l2 @@ -482,8 +482,8 @@ canonicalizedIntersectionOfProjectiveLines l1 l2 | otherwise = Just (cpp1, (l1Err, l2Err, pp1Err <> cpp1Err)) where (cpp1, cpp1Err) = canonicalize pp1 - (pp1, (l1Err,l2Err,pp1Err)) = intersect2PL l1 l2 foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(GVec vals) -> vals) $ vecOfP pp1 + (pp1, (l1Err, l2Err, pp1Err)) = intersect2PL l1 l2 -------------------------------- --- Projective Point Support --- @@ -558,19 +558,19 @@ class (Show a) => ProjectivePoint2 a where vecOfP :: a -> GVec instance ProjectivePoint2 PPoint2 where - canonicalize p = canonicalizePPoint2 p + canonicalize p = canonicalizeProjectivePoint p consLikeP (PPoint2 _) = PPoint2 distance2PP p1 p2 = crushErr $ distanceBetweenProjectivePoints p1 p2 where crushErr (a,(_,_,_,b)) = (a,b) forceBasisOfP a = forceProjectivePointBasis a fuzzinessOfP a = pPointFuzziness a - idealNormOfP a = idealNormPPoint2 a - interpolate2PP p1 p2 = pPointBetweenPPoints p1 p2 - join2PP a b = crushErr $ join2ProjectivePoints a b + idealNormOfP a = idealNormOfProjectivePoint a + interpolate2PP p1 p2 = projectivePointBetweenProjectivePoints p1 p2 + join2PP a b = crushErr $ joinOfProjectivePoints a b where crushErr (res, (_,_,resErr)) = (res, resErr) - pToEP p = crushErr $ fromMaybe (error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point.") $ projectivePointToPoint2 p + pToEP p = crushErr $ fromMaybe (error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point.") $ projectivePointToEuclidianPoint p where crushErr (res, PPoint2Err _ cp1Errs _ _ _ _ _) = (res, sumErrVals cp1Errs) vecOfP (PPoint2 a) = a @@ -583,12 +583,12 @@ instance ProjectivePoint2 CPPoint2 where crushErr (a,(_,_,_,b)) = (a,b) forceBasisOfP p = forceProjectivePointBasis p fuzzinessOfP a = pPointFuzziness a - idealNormOfP p = idealNormPPoint2 p - interpolate2PP p1 p2 = pPointBetweenPPoints p1 p2 - join2PP a b = crushErr $ join2ProjectivePoints a b + idealNormOfP p = idealNormOfProjectivePoint p + interpolate2PP p1 p2 = projectivePointBetweenProjectivePoints p1 p2 + join2PP a b = crushErr $ joinOfProjectivePoints a b where crushErr (res, (_,_,resErr)) = (res, resErr) - pToEP p = crushErr $ fromMaybe (error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point.") $ projectivePointToPoint2 p + pToEP p = crushErr $ fromMaybe (error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point.") $ projectivePointToEuclidianPoint p where crushErr (res, PPoint2Err _ cp1Errs _ _ _ _ _) = (res, sumErrVals cp1Errs) vecOfP (CPPoint2 v) = v @@ -596,8 +596,8 @@ instance ProjectivePoint2 CPPoint2 where -- | canonicalize a euclidian point. -- Note: Normalization of euclidian points in PGA is really just canonicalization. -- Note: For precision, we go through some work to not bother dividing the GP1,GP2 component with itsself, and just substitute in the answer, as exactly 1. -canonicalizePPoint2 :: (ProjectivePoint2 a) => a -> (CPPoint2, PPoint2Err) -canonicalizePPoint2 point +canonicalizeProjectivePoint :: (ProjectivePoint2 a) => a -> (CPPoint2, PPoint2Err) +canonicalizeProjectivePoint point | isNothing foundVal = error $ "tried to canonicalize an ideal point: " <> show point <> "\n" -- Handle the ID case. | valOf 1 foundVal == 1 = (CPPoint2 $ GVec rawVals, mempty) @@ -643,8 +643,8 @@ forceProjectivePointBasis point vec@(GVec vals) = vecOfP point -- | find the idealized norm of a projective point (ideal or not). -idealNormPPoint2 :: (ProjectivePoint2 a) => a -> (ℝ, UlpSum) -idealNormPPoint2 ppoint +idealNormOfProjectivePoint :: (ProjectivePoint2 a) => a -> (ℝ, UlpSum) +idealNormOfProjectivePoint ppoint | preRes == 0 = (0, mempty) | otherwise = (res, ulpTotal) where @@ -663,8 +663,8 @@ idealNormPPoint2 ppoint (GVec rawVals) = vecOfP ppoint -- | a typed join function. join two points, returning a line. -join2ProjectivePoints :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> (PLine2, (PPoint2Err, PPoint2Err, PLine2Err)) -join2ProjectivePoints pp1 pp2 = (PLine2 res, +joinOfProjectivePoints :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> (PLine2, (PPoint2Err, PPoint2Err, PLine2Err)) +joinOfProjectivePoints pp1 pp2 = (PLine2 res, (cp1Errs, cp2Errs, PLine2Err mempty mempty mempty mempty mempty resUlp)) where (res,resUlp) = pv1 ∨+ pv2 @@ -674,8 +674,8 @@ join2ProjectivePoints pp1 pp2 = (PLine2 res, (cp2, cp2Errs) = canonicalize pp2 -- FIXME: automatically raise addVecRes to a CPPoint2 if it turns out to be canonical? -pPointBetweenPPoints :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> ℝ -> ℝ -> (PPoint2, UlpSum) -pPointBetweenPPoints startP stopP weight1 weight2 +projectivePointBetweenProjectivePoints :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> ℝ -> ℝ -> (PPoint2, UlpSum) +projectivePointBetweenProjectivePoints startP stopP weight1 weight2 | isNothing foundVal = error "tried to generate an ideal point?" | otherwise = (PPoint2 addVecRes, ulpSum) where @@ -690,8 +690,8 @@ pPointBetweenPPoints startP stopP weight1 weight2 (stopP', _) = canonicalize stopP -- | Maybe create a euclidian point from a projective point. Will fail if the projective point is ideal. -projectivePointToPoint2 :: (ProjectivePoint2 a) => a -> Maybe (Point2, PPoint2Err) -projectivePointToPoint2 ppoint +projectivePointToEuclidianPoint :: (ProjectivePoint2 a) => a -> Maybe (Point2, PPoint2Err) +projectivePointToEuclidianPoint ppoint | e12Val == 0 = Nothing | otherwise = Just (Point2 (xVal, yVal), cpErrs) where From 6fd59a9780f4c14fc5b18c21d04459380995d4b8 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Mon, 31 Oct 2022 23:19:23 +0000 Subject: [PATCH 048/206] make projectivePointBetweenProjectivePoints return a saner error component. --- Graphics/Slicer/Math/PGA.hs | 4 ++-- Graphics/Slicer/Math/PGAPrimitives.hs | 27 ++++++++++++++------------- 2 files changed, 16 insertions(+), 15 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index b77b4d05a..ae845f7cc 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -389,12 +389,12 @@ onSegment ls i startUlp endUlp = (midDistance, UlpSum midDistanceErr) = distance2PP mid i (endDistance, UlpSum endDistanceErr) = distance2PP end i start = eToPPoint2 $ startPoint ls - (mid, UlpSum midErr) = interpolate2PP start end 0.5 0.5 + (mid, _) = interpolate2PP start end 0.5 0.5 end = eToPPoint2 $ endPoint ls lengthOfSegment = distance (startPoint ls) (endPoint ls) startFudgeFactor, midFudgeFactor, endFudgeFactor :: ℝ startFudgeFactor = realToFrac $ realToFrac startUlp + startDistanceErr - midFudgeFactor = realToFrac $ abs (realToFrac $ doubleUlp lengthOfSegment) + midDistanceErr + midErr + midFudgeFactor = realToFrac $ abs (realToFrac $ doubleUlp lengthOfSegment) + midDistanceErr endFudgeFactor = realToFrac $ realToFrac endUlp + endDistanceErr -- | Combine consecutive line segments. expects line segments with their end points connecting, EG, a contour generated by makeContours. diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index 570274208..490a108f5 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -552,7 +552,7 @@ class (Show a) => ProjectivePoint2 a where forceBasisOfP :: a -> a fuzzinessOfP :: (a, PPoint2Err) -> UlpSum idealNormOfP :: a -> (ℝ, UlpSum) - interpolate2PP :: (ProjectivePoint2 b) => a -> b -> ℝ -> ℝ -> (PPoint2, UlpSum) + interpolate2PP :: (ProjectivePoint2 b) => a -> b -> ℝ -> ℝ -> (PPoint2, (PPoint2Err, PPoint2Err, PPoint2Err)) join2PP :: (ProjectivePoint2 b) => a -> b -> (PLine2, PLine2Err) pToEP :: a -> (Point2, UlpSum) vecOfP :: a -> GVec @@ -674,20 +674,21 @@ joinOfProjectivePoints pp1 pp2 = (PLine2 res, (cp2, cp2Errs) = canonicalize pp2 -- FIXME: automatically raise addVecRes to a CPPoint2 if it turns out to be canonical? -projectivePointBetweenProjectivePoints :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> ℝ -> ℝ -> (PPoint2, UlpSum) -projectivePointBetweenProjectivePoints startP stopP weight1 weight2 +projectivePointBetweenProjectivePoints :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> ℝ -> ℝ -> (PPoint2, (PPoint2Err, PPoint2Err, PPoint2Err)) +projectivePointBetweenProjectivePoints startPoint stopPoint weight1 weight2 | isNothing foundVal = error "tried to generate an ideal point?" - | otherwise = (PPoint2 addVecRes, ulpSum) + | otherwise = (res, resErr) where - ulpSum = sumErrVals addVecResErr <> sumErrVals weighedStartErr <> sumErrVals weighedStopErr - foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(GVec vals) -> vals) addVecRes - (addVecRes, addVecResErr) = addVecPairWithErr weighedStart weighedStop + res = PPoint2 rawRes + resErr = (startPointErr, stopPointErr, PPoint2Err mempty mempty rawResErr weighedStartErr weighedStopErr mempty mempty) + foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(GVec vals) -> vals) rawRes + (rawRes, rawResErr) = addVecPairWithErr weighedStart weighedStop (weighedStart, weighedStartErr) = mulScalarVecWithErr weight1 rawStartPoint (weighedStop, weighedStopErr) = mulScalarVecWithErr weight2 rawStopPoint - rawStartPoint = vecOfP startP' - rawStopPoint = vecOfP stopP' - (startP', _) = canonicalize startP - (stopP', _) = canonicalize stopP + rawStartPoint = vecOfP cStartPoint + rawStopPoint = vecOfP cStopPoint + (cStartPoint, startPointErr) = canonicalize startPoint + (cStopPoint, stopPointErr) = canonicalize stopPoint -- | Maybe create a euclidian point from a projective point. Will fail if the projective point is ideal. projectivePointToEuclidianPoint :: (ProjectivePoint2 a) => a -> Maybe (Point2, PPoint2Err) @@ -707,8 +708,8 @@ projectivePointToEuclidianPoint ppoint sumPPointErrs :: [ErrVal] -> UlpSum sumPPointErrs errs = eValOf mempty (getVal [GEZero 1, GEPlus 1] errs) - <> eValOf mempty (getVal [GEZero 1, GEPlus 2] errs) - <> eValOf mempty (getVal [GEPlus 1, GEPlus 2] errs) + <> eValOf mempty (getVal [GEZero 1, GEPlus 2] errs) + <> eValOf mempty (getVal [GEPlus 1, GEPlus 2] errs) -- | determine the amount of error in resolving a projective point. -- FIXME: this 1000 is completely made up BS. From 16fa8b31163df3de71ddaad5a87d5db210319347 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Mon, 31 Oct 2022 23:39:01 +0000 Subject: [PATCH 049/206] slightly better name --- Graphics/Slicer/Math/PGAPrimitives.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index 490a108f5..620724592 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -680,15 +680,15 @@ projectivePointBetweenProjectivePoints startPoint stopPoint weight1 weight2 | otherwise = (res, resErr) where res = PPoint2 rawRes - resErr = (startPointErr, stopPointErr, PPoint2Err mempty mempty rawResErr weighedStartErr weighedStopErr mempty mempty) + resErr = (cStartPointErr, cStopPointErr, PPoint2Err mempty mempty rawResErr weighedStartErr weighedStopErr mempty mempty) foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(GVec vals) -> vals) rawRes (rawRes, rawResErr) = addVecPairWithErr weighedStart weighedStop (weighedStart, weighedStartErr) = mulScalarVecWithErr weight1 rawStartPoint (weighedStop, weighedStopErr) = mulScalarVecWithErr weight2 rawStopPoint rawStartPoint = vecOfP cStartPoint rawStopPoint = vecOfP cStopPoint - (cStartPoint, startPointErr) = canonicalize startPoint - (cStopPoint, stopPointErr) = canonicalize stopPoint + (cStartPoint, cStartPointErr) = canonicalize startPoint + (cStopPoint, cStopPointErr) = canonicalize stopPoint -- | Maybe create a euclidian point from a projective point. Will fail if the projective point is ideal. projectivePointToEuclidianPoint :: (ProjectivePoint2 a) => a -> Maybe (Point2, PPoint2Err) From da2d801d58f401b2d7990eff81296706611acf9e Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Tue, 1 Nov 2022 20:39:13 +0000 Subject: [PATCH 050/206] change the definition of distanceBetweenProjectivePoints to handle the Eq case, and accept and use input error quotents. --- Graphics/Slicer/Math/Intersections.hs | 6 +- Graphics/Slicer/Math/Lossy.hs | 4 +- Graphics/Slicer/Math/PGA.hs | 52 ++++++++--------- Graphics/Slicer/Math/PGAPrimitives.hs | 59 ++++++++++++-------- Graphics/Slicer/Math/Skeleton/Cells.hs | 4 +- Graphics/Slicer/Math/Skeleton/Concave.hs | 18 +++--- Graphics/Slicer/Math/Skeleton/Definitions.hs | 2 +- tests/Math/PGA.hs | 32 +++++------ 8 files changed, 94 insertions(+), 83 deletions(-) diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index 8f9e0f949..aceecebfa 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -36,7 +36,7 @@ import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, mapWithNeighb import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum)) -import Graphics.Slicer.Math.PGA (CPPoint2, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), Intersection(HitEndPoint, HitStartPoint, NoIntersection), PLine2, intersectsWith, distanceBetweenPLinesWithErr, outputIntersectsLineSeg, plinesIntersectIn, pToEP) +import Graphics.Slicer.Math.PGA (CPPoint2, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), Intersection(HitEndPoint, HitStartPoint, NoIntersection), PLine2, PPoint2Err, intersectsWith, distanceBetweenPLinesWithErr, outputIntersectsLineSeg, plinesIntersectIn, pToEP) import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle)) @@ -181,7 +181,7 @@ intersectionOf pl1 pl2 = saneIntersection $ plinesIntersectIn pl1 pl2 saneIntersection (IntersectsIn p _) = p -- | Get the intersection point of two lines. -intersectionBetween :: PLine2 -> PLine2 -> Maybe (Either PLine2 CPPoint2) +intersectionBetween :: PLine2 -> PLine2 -> Maybe (Either PLine2 (CPPoint2, PPoint2Err)) intersectionBetween pl1 pl2 = saneIntersection $ plinesIntersectIn pl1 pl2 where (foundDistance, UlpSum foundErr) = distanceBetweenPLinesWithErr pl1 pl2 @@ -193,7 +193,7 @@ intersectionBetween pl1 pl2 = saneIntersection $ plinesIntersectIn pl1 pl2 saneIntersection PAntiParallel = if foundDistance < realToFrac foundErr then Just $ Left pl1 else Nothing - saneIntersection (IntersectsIn p _) = Just $ Right p + saneIntersection (IntersectsIn p (_,_,_,pErr)) = Just $ Right (p,pErr) -- | check if two lines cannot intersect. noIntersection :: PLine2 -> PLine2 -> Bool diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index 446d047f1..e52a50d67 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -39,7 +39,7 @@ module Graphics.Slicer.Math.Lossy ( translatePLine2 ) where -import Prelude (($), fst) +import Prelude (($), fst, mempty) -- The numeric type in HSlice. import Graphics.Slicer.Definitions (ℝ) @@ -58,7 +58,7 @@ canonicalizePPoint2 :: PPoint2 -> CPPoint2 canonicalizePPoint2 point = fst $ canonicalize point distanceBetweenPPoints :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> ℝ -distanceBetweenPPoints point1 point2 = fst $ distance2PP point1 point2 +distanceBetweenPPoints point1 point2 = fst $ distance2PP (point1, mempty) (point2, mempty) distanceBetweenPLines :: (ProjectiveLine2 a) => a -> a -> ℝ distanceBetweenPLines nPLine1 nPLine2 = fst $ distanceBetweenPLinesWithErr nPLine1 nPLine2 diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index ae845f7cc..0f74480f3 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -103,7 +103,7 @@ data PIntersection = | PAntiCollinear | PParallel | PAntiParallel - | IntersectsIn !CPPoint2 !(UlpSum, UlpSum, UlpSum, UlpSum, UlpSum, UlpSum) + | IntersectsIn !CPPoint2 !(PLine2Err, PLine2Err, UlpSum, PPoint2Err) deriving (Show, Eq) -- | Determine the intersection point of two projective lines, if applicable. Otherwise, classify the relationship between the two line segments. @@ -117,13 +117,12 @@ plinesIntersectIn pl1 pl2 else PAntiCollinear | sameDirection pl1 pl2 = PParallel | oppositeDirection pl1 pl2 = PAntiParallel - | otherwise = IntersectsIn res (mempty, mempty, mempty, mempty, iaErr, mempty) + | otherwise = IntersectsIn res (npl1Err, npl2Err, idnErr, resErr) where (idealNorm, idnErr) = idealNormOfP intersectPoint - (_, (_,_,iaErr)) = angleBetween2PL pl1 pl2 -- FIXME: how much do the potential normalization errors have an effect on the resultant angle? (intersectPoint, _) = intersect2PL pl1 pl2 - (res, _) = fromJust canonicalizedIntersection + (res, (npl1Err, npl2Err, resErr)) = fromJust canonicalizedIntersection canonicalizedIntersection = canonicalizedIntersectionOf2PL pl1 pl2 -- | Check if the second line's direction is on the 'left' side of the first line, assuming they intersect. If they don't intersect, return Nothing. @@ -312,12 +311,12 @@ pLineIntersectsLineSeg (pl1, UlpSum pl1Err) (l1, UlpSum l1Err) ulpScale | hasIntersection && valOf 0 foundVal == 0 = error "intersection, but cannot cannonicalize." | hasIntersection && startDistance <= ulpStartSum = Left $ HitStartPoint l1 | hasIntersection && endDistance <= ulpEndSum = Left $ HitEndPoint l1 - | hasIntersection = Right $ IntersectsIn rawIntersection (UlpSum $ realToFrac ulpStartSum, UlpSum $ realToFrac ulpEndSum, UlpSum pl1Err, mempty, mempty, mempty) + | hasIntersection = Right $ IntersectsIn rawIntersection (mempty, mempty, mempty, mempty) | hasRawIntersection = Left $ NoIntersection rawIntersection (UlpSum $ realToFrac ulpStartSum, UlpSum $ realToFrac ulpEndSum, mempty, mempty) | otherwise = Left $ NoIntersection ((\(PPoint2 v) -> CPPoint2 v) rawIntersect) (mempty, mempty, mempty, mempty) where - (startDistance, UlpSum startDistanceErr) = distance2PP rawIntersection start - (endDistance, UlpSum endDistanceErr) = distance2PP rawIntersection end + (startDistance, UlpSum startDistanceErr) = distance2PP (rawIntersection, rawIntersectionErr) (start,mempty) + (endDistance, UlpSum endDistanceErr) = distance2PP (rawIntersection, rawIntersectionErr) (end,mempty) start = eToPPoint2 $ startPoint l1 end = eToPPoint2 $ endPoint l1 ulpStartSum, ulpEndSum :: ℝ @@ -327,12 +326,12 @@ pLineIntersectsLineSeg (pl1, UlpSum pl1Err) (l1, UlpSum l1Err) ulpScale -- Note: we do not use rawIntersectionErr here. ulpTotal = l1Err dumpULPs = "pl1Err: " <> show pl1Err <> "\npl2Err: " <> show pl2Err <> "\nl1Err: " <> show l1Err <> "\nrawIntersectErr: " <> show rawIntersectErr <> "\n" - hasIntersection = hasRawIntersection && onSegment l1 rawIntersection ulpStartSum ulpEndSum + hasIntersection = hasRawIntersection && onSegment l1 (rawIntersection, rawIntersectionErr) ulpStartSum ulpEndSum hasRawIntersection = valOf 0 foundVal /= 0 foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(PPoint2 (GVec vals)) -> vals) rawIntersect - -- FIXME: shouldn't we be doing something with this error? - (rawIntersection, _) = canonicalize rawIntersect - (rawIntersect, rawIntersectErr) = intersect2PL pl1 pl2 + rawIntersectionErr = rawIntersectErr <> cRawIntersectErr + (rawIntersection, cRawIntersectErr) = canonicalize rawIntersect + (rawIntersect, (_,_,rawIntersectErr)) = intersect2PL pl1 pl2 (pl2, pl2Err) = eToPL l1 -- | Check if/where two line segments intersect. @@ -349,7 +348,7 @@ lineSegIntersectsLineSeg (l1, UlpSum l1Err) (l2, UlpSum ulpL2) | hasIntersection && end1Distance <= ulpEndSum1 = Left $ HitEndPoint l1 | hasIntersection && start2Distance <= ulpStartSum2 = Left $ HitStartPoint l2 | hasIntersection && end2Distance <= ulpEndSum2 = Left $ HitEndPoint l2 - | hasIntersection = Right $ IntersectsIn rawIntersection (UlpSum $ realToFrac ulpStartSum1, UlpSum $ realToFrac ulpEndSum1, UlpSum $ realToFrac ulpStartSum2, UlpSum $ realToFrac ulpEndSum2, UlpSum ulpTotal, mempty) + | hasIntersection = Right $ IntersectsIn rawIntersection (mempty, mempty, mempty, mempty) | hasRawIntersection = Left $ NoIntersection rawIntersection (UlpSum $ realToFrac ulpStartSum1, UlpSum $ realToFrac ulpEndSum1, UlpSum $ realToFrac ulpStartSum2, UlpSum $ realToFrac ulpEndSum2) | otherwise = Left $ NoIntersection ((\(PPoint2 p) -> CPPoint2 p) rawIntersect) (mempty, mempty, mempty, mempty) where @@ -358,10 +357,10 @@ lineSegIntersectsLineSeg (l1, UlpSum l1Err) (l2, UlpSum ulpL2) ulpStartSum2 = realToFrac $ ulpTotal+start2DistanceErr ulpEndSum1 = realToFrac $ ulpTotal ulpEndSum2 = realToFrac $ ulpTotal - (start1Distance, UlpSum start1DistanceErr) = distance2PP rawIntersection start1 - (start2Distance, UlpSum start2DistanceErr) = distance2PP rawIntersection start2 - (end1Distance, UlpSum end1DistanceErr) = distance2PP rawIntersection end1 - (end2Distance, UlpSum end2DistanceErr) = distance2PP rawIntersection end2 + (start1Distance, UlpSum start1DistanceErr) = distance2PP (rawIntersection, rawIntersectionErr) (start1, mempty) + (start2Distance, UlpSum start2DistanceErr) = distance2PP (rawIntersection, rawIntersectionErr) (start2, mempty) + (end1Distance, UlpSum end1DistanceErr) = distance2PP (rawIntersection, rawIntersectionErr) (end1, mempty) + (end2Distance, UlpSum end2DistanceErr) = distance2PP (rawIntersection, rawIntersectionErr) (end2, mempty) start1 = eToPPoint2 $ startPoint l1 end1 = eToPPoint2 $ endPoint l1 start2 = eToPPoint2 $ startPoint l2 @@ -370,26 +369,27 @@ lineSegIntersectsLineSeg (l1, UlpSum l1Err) (l2, UlpSum ulpL2) (pl2, pl2Err) = eToPL l2 -- | the sum of all ULPs. used to expand the hitcircle of an endpoint. ulpTotal = l1Err + ulpL2 - dumpULPs = "pl1Err: " <> show pl1Err <> "\npl2Err: " <> show pl2Err <> "\nl1Err: " <> show l1Err <> "\nrawIntersectErr: " <> show rawIntersectErr <> "\n" - hasIntersection = hasRawIntersection && onSegment l1 rawIntersection ulpStartSum1 ulpEndSum1 && onSegment l2 rawIntersection ulpStartSum2 ulpEndSum2 + dumpULPs = "pl1Err: " <> show pl1Err <> "\npl2Err: " <> show pl2Err <> "\nl1Err: " <> show l1Err <> "\nrawIntersectionErr: " <> show rawIntersectionErr <> "\n" + hasIntersection = hasRawIntersection && onSegment l1 (rawIntersection,rawIntersectionErr) ulpStartSum1 ulpEndSum1 && onSegment l2 (rawIntersection,rawIntersectionErr) ulpStartSum2 ulpEndSum2 hasRawIntersection = valOf 0 foundVal /= 0 foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(PPoint2 (GVec vals)) -> vals) rawIntersect -- FIXME: remove the canonicalization from this function, moving it to the callers. - (rawIntersection, _) = canonicalize rawIntersect - (rawIntersect, rawIntersectErr) = intersect2PL pl1 pl2 + rawIntersectionErr = rawIntersectErrRaw <> cRawIntersectErr + (rawIntersection, cRawIntersectErr) = canonicalize rawIntersect + (rawIntersect, (_,_,rawIntersectErrRaw)) = intersect2PL pl1 pl2 -- | Given the result of intersectionPoint, find out whether this intersection point is on the given segment, or not. -onSegment :: LineSeg -> CPPoint2 -> ℝ -> ℝ -> Bool -onSegment ls i startUlp endUlp = +onSegment :: LineSeg -> (CPPoint2, PPoint2Err) -> ℝ -> ℝ -> Bool +onSegment ls (i, iErr) startUlp endUlp = (startDistance <= startFudgeFactor) || (midDistance <= (lengthOfSegment/2) + midFudgeFactor) || (endDistance <= endFudgeFactor) where - (startDistance, UlpSum startDistanceErr) = distance2PP start i - (midDistance, UlpSum midDistanceErr) = distance2PP mid i - (endDistance, UlpSum endDistanceErr) = distance2PP end i + (startDistance, UlpSum startDistanceErr) = distance2PP (start, mempty) (i,iErr) + (midDistance, UlpSum midDistanceErr) = distance2PP (mid,midErr) (i,iErr) + (endDistance, UlpSum endDistanceErr) = distance2PP (end, mempty) (i,iErr) start = eToPPoint2 $ startPoint ls - (mid, _) = interpolate2PP start end 0.5 0.5 + (mid, (_, _, midErr)) = interpolate2PP start end 0.5 0.5 end = eToPPoint2 $ endPoint ls lengthOfSegment = distance (startPoint ls) (endPoint ls) startFudgeFactor, midFudgeFactor, endFudgeFactor :: ℝ diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index 620724592..97d6b1afa 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -319,6 +319,7 @@ normalizeProjectiveLine line = (res, resErr) vec = vecOfL line -- | Find the norm of a given Projective Line. +-- FIXME: shold we be placing this error in the PLine2Err? it doesn't effect resolving the line... normOfProjectiveLine :: (ProjectiveLine2 a) => a -> (ℝ, PLine2Err) normOfProjectiveLine line = (res, resErr) where @@ -548,7 +549,7 @@ class Arcable a where class (Show a) => ProjectivePoint2 a where canonicalize :: a -> (CPPoint2, PPoint2Err) consLikeP :: a -> (GVec -> a) - distance2PP :: (ProjectivePoint2 b) => a -> b -> (ℝ, UlpSum) + distance2PP :: (ProjectivePoint2 b) => (a, PPoint2Err) -> (b, PPoint2Err) -> (ℝ, UlpSum) forceBasisOfP :: a -> a fuzzinessOfP :: (a, PPoint2Err) -> UlpSum idealNormOfP :: a -> (ℝ, UlpSum) @@ -619,16 +620,24 @@ canonicalizeProjectivePoint point (GVec rawVals) = vecOfP point foundVal = getVal [GEPlus 1, GEPlus 2] rawVals -distanceBetweenProjectivePoints :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> (ℝ, (PPoint2Err, PPoint2Err, PLine2Err, UlpSum)) -distanceBetweenProjectivePoints point1 point2 = (res, (cPoint1Err, cPoint2Err, resErr <> newPLineErr, ulpTotal)) +-- | Find the distance between two projective points, and the error component of the result. +distanceBetweenProjectivePoints :: (ProjectivePoint2 a, ProjectivePoint2 b) => (a, PPoint2Err) -> (b, PPoint2Err) -> (ℝ, (PPoint2Err, PPoint2Err, PLine2Err, UlpSum)) +distanceBetweenProjectivePoints (point1, point1Err) (point2, point2Err) + | cPoint1 == cPoint2 = (0, (cPoint1Err, cPoint2Err, mempty, mempty)) + | otherwise = (res, resErr) where - ulpTotal = pLineErrAtPPoint (newPLine, newPLineErr) cPoint1 - (res, resErr) = normOfL newPLine - (newPLine, newPLineErr) = join2PP cPoint1 cPoint2 + resErr = (cPoint1Err, cPoint2Err, newPLineErr, ulpSum) + -- FIXME: missing the component for normErr? + ulpSum = fuzzinessOfP (cPoint1, point1Err <> cPoint1Err) <> fuzzinessOfP (cPoint2, point2Err <> cPoint2Err) <> fuzzinessOfL (newPLine, newPLineErr) + -- FIXME: should it be fuzzinessOfL's job to determine how error in normErr effects ... line resolution? + newPLineErr = newPLineErrRaw <> normErr + -- FIXME: how does the error in newPLine effect the found norm here? + (res, normErr) = normOfL newPLine + (newPLine, newPLineErrRaw) = join2PP cPoint1 cPoint2 (cPoint1, cPoint1Err) = canonicalize point1 (cPoint2, cPoint2Err) = canonicalize point2 --- | runtime basis coersion. ensure all of the '0' components exist on a Projective Point. +-- | Ensure all of the '0' components exist on a Projective Point. This is to ensure like, unlike, and reductive work properly. forceProjectivePointBasis :: (ProjectivePoint2 a) => a -> a forceProjectivePointBasis point | gnums == Just [fromList [GEZero 1, GEPlus 1], @@ -644,7 +653,7 @@ forceProjectivePointBasis point -- | find the idealized norm of a projective point (ideal or not). idealNormOfProjectivePoint :: (ProjectivePoint2 a) => a -> (ℝ, UlpSum) -idealNormOfProjectivePoint ppoint +idealNormOfProjectivePoint point | preRes == 0 = (0, mempty) | otherwise = (res, ulpTotal) where @@ -658,20 +667,21 @@ idealNormOfProjectivePoint ppoint (x,y) | e12Val == 0 = ( negate $ valOf 0 $ getVal [GEZero 1, GEPlus 2] rawVals , valOf 0 $ getVal [GEZero 1, GEPlus 1] rawVals) - | otherwise = (\(Point2 (x1,y1),_) -> (x1,y1)) $ pToEP ppoint + | otherwise = (\(Point2 (x1,y1),_) -> (x1,y1)) $ pToEP point e12Val = valOf 0 (getVal [GEPlus 1, GEPlus 2] rawVals) - (GVec rawVals) = vecOfP ppoint + (GVec rawVals) = vecOfP point -- | a typed join function. join two points, returning a line. joinOfProjectivePoints :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> (PLine2, (PPoint2Err, PPoint2Err, PLine2Err)) -joinOfProjectivePoints pp1 pp2 = (PLine2 res, - (cp1Errs, cp2Errs, PLine2Err mempty mempty mempty mempty mempty resUlp)) +joinOfProjectivePoints point1 point2 = (PLine2 res, + (cPoint1Err, cPoint2Err, PLine2Err mempty mempty mempty mempty mempty resUlp)) where - (res,resUlp) = pv1 ∨+ pv2 - pv1 = vecOfP $ forceBasisOfP cp1 - pv2 = vecOfP $ forceBasisOfP cp2 - (cp1, cp1Errs) = canonicalize pp1 - (cp2, cp2Errs) = canonicalize pp2 + -- FIXME: how does error in canonicalization effect the PLine generated here? + (res, resUlp) = pv1 ∨+ pv2 + pv1 = vecOfP $ forceBasisOfP cPoint1 + pv2 = vecOfP $ forceBasisOfP cPoint2 + (cPoint1, cPoint1Err) = canonicalize point1 + (cPoint2, cPoint2Err) = canonicalize point2 -- FIXME: automatically raise addVecRes to a CPPoint2 if it turns out to be canonical? projectivePointBetweenProjectivePoints :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> ℝ -> ℝ -> (PPoint2, (PPoint2Err, PPoint2Err, PPoint2Err)) @@ -692,15 +702,16 @@ projectivePointBetweenProjectivePoints startPoint stopPoint weight1 weight2 -- | Maybe create a euclidian point from a projective point. Will fail if the projective point is ideal. projectivePointToEuclidianPoint :: (ProjectivePoint2 a) => a -> Maybe (Point2, PPoint2Err) -projectivePointToEuclidianPoint ppoint +projectivePointToEuclidianPoint point | e12Val == 0 = Nothing - | otherwise = Just (Point2 (xVal, yVal), cpErrs) + | otherwise = Just (res, resErr) where - (CPPoint2 (GVec vals), cpErrs) = canonicalize ppoint + res = Point2 (xVal, yVal) xVal = negate $ valOf 0 $ getVal [GEZero 1, GEPlus 2] vals yVal = valOf 0 $ getVal [GEZero 1, GEPlus 1] vals + (CPPoint2 (GVec vals), resErr) = canonicalize point e12Val = valOf 0 (getVal [GEPlus 1, GEPlus 2] rawVals) - (GVec rawVals) = vecOfP ppoint + (GVec rawVals) = vecOfP point ------------------------------------------ --- Projective Point Error Calculation --- @@ -714,7 +725,7 @@ sumPPointErrs errs = eValOf mempty (getVal [GEZero 1, GEPlus 1] errs) -- | determine the amount of error in resolving a projective point. -- FIXME: this 1000 is completely made up BS. pPointFuzziness :: (ProjectivePoint2 a) => (a, PPoint2Err) -> UlpSum -pPointFuzziness (inPPoint, inErr) = UlpSum $ sumTotal * realToFrac (1+(1000*(abs angleIn + realToFrac (ulpVal $ sumPPointErrs angleUnlikeAddErr <> sumPPointErrs angleUnlikeMulErr)))) +pPointFuzziness (point, pointErr) = UlpSum $ sumTotal * realToFrac (1+(1000*(abs angleIn + realToFrac (ulpVal $ sumPPointErrs angleUnlikeAddErr <> sumPPointErrs angleUnlikeMulErr)))) where sumTotal = ulpVal $ sumPPointErrs pJoinAddErr <> sumPPointErrs pJoinMulErr @@ -722,5 +733,5 @@ pPointFuzziness (inPPoint, inErr) = UlpSum $ sumTotal * realToFrac (1+(1000*(abs <> sumPPointErrs pAddErr <> sumPPointErrs pIn1MulErr <> sumPPointErrs pIn2MulErr - (PPoint2Err (pJoinAddErr, pJoinMulErr) pCanonicalizeErr pAddErr pIn1MulErr pIn2MulErr angleIn (angleUnlikeAddErr,angleUnlikeMulErr)) = cpErr <> inErr - (_, cpErr) = canonicalize inPPoint + (PPoint2Err (pJoinAddErr, pJoinMulErr) pCanonicalizeErr pAddErr pIn1MulErr pIn2MulErr angleIn (angleUnlikeAddErr,angleUnlikeMulErr)) = cPointErr <> pointErr + (_, cPointErr) = canonicalize point diff --git a/Graphics/Slicer/Math/Skeleton/Cells.hs b/Graphics/Slicer/Math/Skeleton/Cells.hs index 675bc1b5e..fde60ea93 100644 --- a/Graphics/Slicer/Math/Skeleton/Cells.hs +++ b/Graphics/Slicer/Math/Skeleton/Cells.hs @@ -26,7 +26,7 @@ -- a contour into cells. module Graphics.Slicer.Math.Skeleton.Cells (UnsupportedReason(INodeCrossesDivide), findDivisions, findFirstCellOfContour, findNextCell, getNodeTreeOfCell, nodeTreesDoNotOverlap, addNodeTreesAlongDivide, nodeTreesFromDivision, startOfDivide, endOfDivide, findRemainder, createCellFromStraightWalls, gatherLineSegsPreceedingDivide, startBeforeEnd) where -import Prelude (Bool(False), Eq, Ordering(LT, GT, EQ), Show, elem, filter, null, otherwise, ($), (<$>), (==), error, (<>), show, (&&), compare, concat, (/=), (||), (<), (<=), fst, snd, (*), realToFrac) +import Prelude (Bool(False), Eq, Ordering(LT, GT, EQ), Show, elem, filter, null, otherwise, ($), (<$>), (==), error, (<>), show, (&&), compare, concat, (/=), (||), (<), (<=), fst, snd, (*), mempty, realToFrac) import Data.Either(Either(Left, Right)) @@ -192,7 +192,7 @@ findNextCell (RemainingContour (Slist [(Slist lineSegs _, divides)] _) ) = case elemIndex (fst $ fst div1) contourSegs `compare` elemIndex (fst $ fst div2) contourSegs of LT -> LT GT -> GT - EQ -> fst (distance2PP (startPPoint $ fst $ fst div1) (toPPoint2 $ snd $ fst div1)) `compare` fst (distance2PP (startPPoint $ fst $ fst div2) (toPPoint2 $ snd $ fst div2)) + EQ -> fst (distance2PP (startPPoint $ fst $ fst div1, mempty) (toPPoint2 $ snd $ fst div1, mempty)) `compare` fst (distance2PP (startPPoint $ fst $ fst div2, mempty) (toPPoint2 $ snd $ fst div2, mempty)) where toPPoint2 :: Either Point2 CPPoint2 -> CPPoint2 toPPoint2 (Left point2) = eToCPPoint2 point2 diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index a313754c1..2c291bb99 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -28,7 +28,7 @@ module Graphics.Slicer.Math.Skeleton.Concave (skeletonOfConcaveRegion, findINodes, getOutsideArc, makeENode, makeENodes, averageNodes, eNodesOfOutsideContour, towardIntersection) where -import Prelude (Eq, Show, Bool(True, False), Either(Left, Right), String, Ord, Ordering(GT,LT), notElem, otherwise, ($), (>), (<), (<$>), (==), (/=), (>=), error, (&&), fst, and, (<>), show, not, max, concat, compare, uncurry, null, (||), min, snd, filter, zip, any, (*), (+), Int, (.), (<=), (-), realToFrac) +import Prelude (Eq, Show, Bool(True, False), Either(Left, Right), String, Ord, Ordering(GT,LT), notElem, otherwise, ($), (>), (<), (<$>), (==), (/=), (>=), error, (&&), fst, and, (<>), show, not, max, concat, compare, uncurry, null, (||), min, snd, filter, zip, any, (*), (+), Int, (.), (<=), (-), mempty, realToFrac) import Prelude as PL (head, last, tail, init) @@ -179,8 +179,8 @@ averageNodes n1 n2 | n2Distance < getRounded n2Err = error $ "intersection is AT the point of n2!\n" <> dumpInput | otherwise = makeINode (sortedPair n1 n2) $ Just $ getOutsideArc (pPointOf n1) (normalizePLine2 $ outOf n1) (pPointOf n2) (normalizePLine2 $ outOf n2) where - (n1Distance, UlpSum n1Err) = distance2PP (intersectionOf (outOf n1) (outOf n2)) (canonicalizePPoint2 $ pPointOf n1) - (n2Distance, UlpSum n2Err) = distance2PP (intersectionOf (outOf n1) (outOf n2)) (canonicalizePPoint2 $ pPointOf n2) + (n1Distance, UlpSum n1Err) = distance2PP (intersectionOf (outOf n1) (outOf n2), mempty) (canonicalize $ pPointOf n1) + (n2Distance, UlpSum n2Err) = distance2PP (intersectionOf (outOf n1) (outOf n2), mempty) (canonicalize $ pPointOf n2) dumpInput = "Node1: " <> show n1 <> "\nNode2: " <> show n2 <> "\nNode1Out: " <> show (outOf n1) @@ -212,8 +212,8 @@ getOutsideArc ppoint1 npline1 ppoint2 npline2 l1TowardPoint = towardIntersection ppoint1 pline1 intersectionPoint l2TowardPoint = towardIntersection ppoint2 pline2 intersectionPoint --- Determine if the line segment formed by the two given points starts with the first point, or the second. --- Note that due to numeric uncertainty, we cannot rely on Eq here, and must check the sign of the angle. +-- | Determine if the line segment formed by the two given points starts with the first point, or the second. +-- Note: Due to numeric uncertainty, we cannot rely on Eq here, and must check the sign of the angle. -- FIXME: shouldn't we be given an error component in our inputs? towardIntersection :: (ProjectivePoint2 a) => a -> PLine2 -> CPPoint2 -> Bool towardIntersection pp1 pl1 pp2 @@ -221,7 +221,7 @@ towardIntersection pp1 pl1 pp2 | otherwise = angleFound > realToFrac (ulpVal angleErr) where (angleFound, (_,_, angleErr)) = angleBetween2PL newPLine pl1 - (d, UlpSum dErr) = distance2PP (fst $ canonicalize pp1) pp2 + (d, UlpSum dErr) = distance2PP (canonicalize pp1) (pp2, mempty) newPLine = join2CPPoint2 (fst $ canonicalize pp1) pp2 -- | Make a first generation node. @@ -675,7 +675,7 @@ skeletonOfNodes connectedLoop inSegSets iNodes = [] -> error "one line, no points.. makes no sense." (x:_) -> [and pointsCloseEnough && foundDistance < realToFrac foundErr] where - (foundDistance, UlpSum foundErr) = distancePPointToPLineWithErr ((\(CPPoint2 v) -> PPoint2 v) x) a + (foundDistance, UlpSum foundErr) = distancePPointToPLineWithErr ((\(CPPoint2 v,_) -> PPoint2 v) x) a (_:_) -> error $ "detected multiple lines?\n" <> show lineIntersections <> "\n" @@ -868,5 +868,5 @@ skeletonOfNodes connectedLoop inSegSets iNodes = && (dist2 >= realToFrac dist2Err) | otherwise = error $ "cannot intersect a node with no output:\nNode1: " <> show node1 <> "\nNode2: " <> show node2 <> "\nnodes: " <> show iNodes <> "\n" where - (dist1, UlpSum dist1Err) = distance2PP (intersectionOf (outOf node1) (outOf node2)) (canonicalizePPoint2 $ pPointOf node1) - (dist2, UlpSum dist2Err) = distance2PP (intersectionOf (outOf node1) (outOf node2)) (canonicalizePPoint2 $ pPointOf node2) + (dist1, UlpSum dist1Err) = distance2PP (canonicalize $ intersectionOf (outOf node1) (outOf node2)) (canonicalize $ pPointOf node1) + (dist2, UlpSum dist2Err) = distance2PP (canonicalize $ intersectionOf (outOf node1) (outOf node2)) (canonicalize $ pPointOf node2) diff --git a/Graphics/Slicer/Math/Skeleton/Definitions.hs b/Graphics/Slicer/Math/Skeleton/Definitions.hs index 32b6ac0ab..7ad932e81 100644 --- a/Graphics/Slicer/Math/Skeleton/Definitions.hs +++ b/Graphics/Slicer/Math/Skeleton/Definitions.hs @@ -122,7 +122,7 @@ instance Pointable INode where where distanceWithinErr a b = res < realToFrac err where - (res, UlpSum err) = distance2PP (fst $ canonicalize a) (fst $ canonicalize b) + (res, UlpSum err) = distance2PP (canonicalize a) (canonicalize b) allPLines = if hasArc iNode then slist $ nub $ (outOf iNode, errOfOut iNode) : firstPLine : secondPLine : rawPLines else slist $ nub $ firstPLine : secondPLine : rawPLines diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index d67f21a55..348e16739 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -489,7 +489,7 @@ pgaSpec = do it "two projective points on different sides of a line show as being on different sides of a line" $ property prop_OtherSideOfAxis --- ensure that the bisector of a quad crosses the point across the quad from the bisector. +-- | Ensure that the bisector of a quad crosses the point across the quad from the bisector. prop_QuadBisectorCrosses :: Positive ℝ -> Positive ℝ -> Positive ℝ -> Positive ℝ -> Bool prop_QuadBisectorCrosses rawX1 rawY1 rawX2 rawY2 | isEndPoint intersect1 && isStartPoint intersect2 && isEndPoint intersect3 && isEndPoint intersect4 = True @@ -624,8 +624,8 @@ prop_LineSegIntersectionStableAtOrigin d1 x1 y1 rawX2 rawY2 res1 = intersectsWithErr (Right (pLineThroughOriginNotX1Y1NotOther,mempty)) (Left (x1y1LineSegToOrigin,mempty)) res2 = intersectsWithErr (Right (pLineThroughOriginNotX1Y1NotOther,mempty)) (Left (lineSegFromOrigin,mempty)) distanceStart = case res2 of - (Left (NoIntersection iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP iPoint (eToCPPoint2 $ Point2 (0,0))) <> "\nUlpSum:" <> show ulpSum <> "\n" - (Right (IntersectsIn iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP iPoint (eToCPPoint2 $ Point2 (0,0))) <> "\nUlpSum:" <> show ulpSum <> "\n" + (Left (NoIntersection iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP (iPoint,mempty) (makePPoint2 0 0, mempty)) <> "\nUlpSum:" <> show ulpSum <> "\n" + (Right (IntersectsIn iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP (iPoint,mempty) (makePPoint2 0 0, mempty)) <> "\nUlpSum:" <> show ulpSum <> "\n" _ -> "" (pLineThroughOriginNotX1Y1NotOther,_) = randomPLineThroughOrigin x2 y2 x1y1LineSegToOrigin = randomX1Y1LineSegToOrigin d1 @@ -670,12 +670,12 @@ prop_LineSegIntersectionStableAtX1Y1Point pointD rawD1 x1 y1 rawX2 rawY2 res1 = intersectsWithErr (Right (pLineThroughPointNotX1Y1NotOther,mempty)) (Left (x1y1LineSegToPoint,mempty)) res2 = intersectsWithErr (Right (pLineThroughPointNotX1Y1NotOther,mempty)) (Left (lineSegFromPointNotX1Y1,mempty)) distanceStart = case res2 of - (Left (NoIntersection iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP iPoint (eToCPPoint2 $ Point2 (d2,d2))) <> "\nUlpSum:" <> show ulpSum <> "\n" - (Right (IntersectsIn iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP iPoint (eToCPPoint2 $ Point2 (d2,d2))) <> "\nUlpSum:" <> show ulpSum <> "\n" + (Left (NoIntersection iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP (iPoint, mempty) (makePPoint2 d2 d2, mempty)) <> "\nUlpSum:" <> show ulpSum <> "\n" + (Right (IntersectsIn iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP (iPoint, mempty) (makePPoint2 d2 d2, mempty)) <> "\nUlpSum:" <> show ulpSum <> "\n" _ -> "" distanceEnd = case res1 of - (Left (NoIntersection iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP iPoint (eToCPPoint2 $ Point2 (d2,d2))) <> "\nUlpSum:" <> show ulpSum <> "\n" - (Right (IntersectsIn iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP iPoint (eToCPPoint2 $ Point2 (d2,d2))) <> "\nUlpSum:" <> show ulpSum <> "\n" + (Left (NoIntersection iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP (iPoint, mempty) (makePPoint2 d2 d2, mempty)) <> "\nUlpSum:" <> show ulpSum <> "\n" + (Right (IntersectsIn iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP (iPoint, mempty) (makePPoint2 d2 d2, mempty)) <> "\nUlpSum:" <> show ulpSum <> "\n" _ -> "" (pLineThroughPointNotX1Y1NotOther,_) = randomPLineThroughPoint x2 y2 d2 x1y1LineSegToPoint = randomX1Y1LineSegToPoint d1 d2 @@ -1187,7 +1187,7 @@ prop_PPointWithinErrRange x y | res > realToFrac (resErr) = error $ "res too big: " <> show res | otherwise = (p1 /= p2) || (res == 0 || error "the same, but distance?") where - (res, UlpSum resErr) = distance2PP p1 p2 + (res, UlpSum resErr) = distance2PP (p1,mempty) (p2,mempty) p1 = makePPoint2 x y p2 = makePPoint2 x y @@ -1366,8 +1366,8 @@ prop_PLinesIntersectAtOrigin rawX y rawX2 rawY2 <> show intersectionErr <> "\n" where originPPoint2 = makePPoint2 0 0 - (foundDistance, UlpSum distanceErr) = distance2PP originPPoint2 intersectionPPoint2 - (intersectionPPoint2, intersectionErr) = intersect2PL randomPLine1 randomPLine2 + (foundDistance, UlpSum distanceErr) = distance2PP (originPPoint2, mempty) (intersectionPPoint2, intersectionErr) + (intersectionPPoint2, (_,_,intersectionErr)) = intersect2PL randomPLine1 randomPLine2 (randomPLine1, _) = randomPLineThroughOrigin x y (randomPLine2, _) = randomPLineThroughOrigin x2 y2 (_, canonicalizationErr) = canonicalize intersectionPPoint2 @@ -1394,8 +1394,8 @@ prop_PLinesIntersectAtPoint rawX y rawX2 rawY2 targetX targetY <> show intersectionErr <> "\n" where (targetPPoint2) = makePPoint2 (coerce targetX) (coerce targetY) - (foundDistance, UlpSum distanceErr) = distance2PP targetPPoint2 intersectionPPoint2 - (intersectionPPoint2, intersectionErr) = intersect2PL randomPLine1 randomPLine2 + (foundDistance, UlpSum distanceErr) = distance2PP (targetPPoint2, mempty) (intersectionPPoint2, intersectionErr) + (intersectionPPoint2, (_,_, intersectionErr)) = intersect2PL randomPLine1 randomPLine2 (randomPLine1, _) = randomPLineWithErr x y targetX targetY (randomPLine2, _) = randomPLineWithErr x2 y2 targetX targetY (_, canonicalizationErr) = canonicalize intersectionPPoint2 @@ -1426,11 +1426,11 @@ prop_PLineIntersectsAtXAxis x y rawX2 y2 m <> show intersectionErr <> "\n" where errSum = ulpVal $ axisIntersectionErr <> distanceErr - (foundDistance, distanceErr) = distance2PP axisIntersectionPoint intersectionPPoint2 + (foundDistance, distanceErr) = distance2PP (axisIntersectionPoint, mempty) (intersectionPPoint2, intersectionErr) axisIntersectionErr = snd $ fromJust axisIntersection axisIntersectionPoint = eToPPoint2 $ Point2 ((fromRight (error "not right?") $ fst $ fromJust axisIntersection), 0) axisIntersection = xIntercept (randomPLine1, pline1Err) - (intersectionPPoint2, intersectionErr) = intersect2PL randomPLine1 axisPLine + (intersectionPPoint2, (_,_,intersectionErr)) = intersect2PL randomPLine1 axisPLine (randomPLine1, pline1Err) = randomPL x y rawX2 (coerce y2) -- Error in this line should be in directions that should not matter. (axisPLine, _) = eToPL $ makeLineSeg (Point2 (0,0)) (Point2 (coerce m,0)) @@ -1455,11 +1455,11 @@ prop_PLineIntersectsAtYAxis x y x2 rawY2 m <> show intersectionErr <> "\n" where errSum = ulpVal $ axisIntersectionErr <> distanceErr - (foundDistance, distanceErr) = distance2PP axisIntersectionPoint intersectionPPoint2 + (foundDistance, distanceErr) = distance2PP (axisIntersectionPoint,mempty) (intersectionPPoint2, intersectionErr) axisIntersectionErr = snd $ fromJust axisIntersection axisIntersectionPoint = eToPPoint2 $ Point2 (0,(fromRight (error "not right?") $ fst $ fromJust axisIntersection)) axisIntersection = yIntercept (randomPLine1, pline1Err) - (intersectionPPoint2, intersectionErr) = intersect2PL randomPLine1 axisPLine + (intersectionPPoint2, (_,_,intersectionErr)) = intersect2PL randomPLine1 axisPLine (randomPLine1, pline1Err) = randomPL (coerce x) y (coerce x2) (coerce y2) -- Error in this line should be in directions that should not matter. (axisPLine, _) = eToPL $ makeLineSeg (Point2 (0,0)) (Point2 (0,coerce m)) From c3319f9d50453b78fbfc1d9c564f004e2e159007 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Tue, 1 Nov 2022 21:01:25 +0000 Subject: [PATCH 051/206] make join2PP return canonicalize results of its input points. --- Graphics/Slicer/Math/PGA.hs | 2 +- Graphics/Slicer/Math/PGAPrimitives.hs | 12 ++++-------- Graphics/Slicer/Math/Skeleton/Cells.hs | 2 +- tests/Math/PGA.hs | 2 +- 4 files changed, 7 insertions(+), 11 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 0f74480f3..ae7be379b 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -458,7 +458,7 @@ reverseGVec (GVec vals) = GVec $ foldl' addValWithoutErr [] eToPL :: LineSeg -> (PLine2, PLine2Err) eToPL l1 = (res, resErr) where - (res, resErr) = join2PP (eToPPoint2 $ startPoint l1) (eToPPoint2 $ endPoint l1) + (res, (_,_,resErr)) = join2PP (eToPPoint2 $ startPoint l1) (eToPPoint2 $ endPoint l1) -- | Get the sum of the error involved in storing the values in a given PLine2. ulpOfPLine2 :: (ProjectiveLine2 a) => a -> UlpSum diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index 97d6b1afa..5ef67d35f 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -554,7 +554,7 @@ class (Show a) => ProjectivePoint2 a where fuzzinessOfP :: (a, PPoint2Err) -> UlpSum idealNormOfP :: a -> (ℝ, UlpSum) interpolate2PP :: (ProjectivePoint2 b) => a -> b -> ℝ -> ℝ -> (PPoint2, (PPoint2Err, PPoint2Err, PPoint2Err)) - join2PP :: (ProjectivePoint2 b) => a -> b -> (PLine2, PLine2Err) + join2PP :: (ProjectivePoint2 b) => a -> b -> (PLine2, (PPoint2Err, PPoint2Err, PLine2Err)) pToEP :: a -> (Point2, UlpSum) vecOfP :: a -> GVec @@ -568,9 +568,7 @@ instance ProjectivePoint2 PPoint2 where fuzzinessOfP a = pPointFuzziness a idealNormOfP a = idealNormOfProjectivePoint a interpolate2PP p1 p2 = projectivePointBetweenProjectivePoints p1 p2 - join2PP a b = crushErr $ joinOfProjectivePoints a b - where - crushErr (res, (_,_,resErr)) = (res, resErr) + join2PP a b = joinOfProjectivePoints a b pToEP p = crushErr $ fromMaybe (error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point.") $ projectivePointToEuclidianPoint p where crushErr (res, PPoint2Err _ cp1Errs _ _ _ _ _) = (res, sumErrVals cp1Errs) @@ -586,9 +584,7 @@ instance ProjectivePoint2 CPPoint2 where fuzzinessOfP a = pPointFuzziness a idealNormOfP p = idealNormOfProjectivePoint p interpolate2PP p1 p2 = projectivePointBetweenProjectivePoints p1 p2 - join2PP a b = crushErr $ joinOfProjectivePoints a b - where - crushErr (res, (_,_,resErr)) = (res, resErr) + join2PP a b = joinOfProjectivePoints a b pToEP p = crushErr $ fromMaybe (error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point.") $ projectivePointToEuclidianPoint p where crushErr (res, PPoint2Err _ cp1Errs _ _ _ _ _) = (res, sumErrVals cp1Errs) @@ -633,7 +629,7 @@ distanceBetweenProjectivePoints (point1, point1Err) (point2, point2Err) newPLineErr = newPLineErrRaw <> normErr -- FIXME: how does the error in newPLine effect the found norm here? (res, normErr) = normOfL newPLine - (newPLine, newPLineErrRaw) = join2PP cPoint1 cPoint2 + (newPLine, (_,_,newPLineErrRaw)) = join2PP point1 point2 (cPoint1, cPoint1Err) = canonicalize point1 (cPoint2, cPoint2Err) = canonicalize point2 diff --git a/Graphics/Slicer/Math/Skeleton/Cells.hs b/Graphics/Slicer/Math/Skeleton/Cells.hs index fde60ea93..fc63834a1 100644 --- a/Graphics/Slicer/Math/Skeleton/Cells.hs +++ b/Graphics/Slicer/Math/Skeleton/Cells.hs @@ -369,7 +369,7 @@ addNodeTreesAlongDivide nodeTree1 nodeTree2 division = mergeNodeTrees (adjustedN case nub $ insOf $ lastINodeOf iNodeGens of [] -> error "unpossible." [_] -> NodeTree eNodes $ INodeSet $ init gens - (_:_) -> NodeTree eNodes $ INodeSet $ init gens <> one [makeINode (nub $ insOf $ lastINodeOf iNodeGens) (Just $ join2PP (finalPointOfNodeTree nodeTree) myCrossover)] + (_:_) -> NodeTree eNodes $ INodeSet $ init gens <> one [makeINode (nub $ insOf $ lastINodeOf iNodeGens) (Just $ (\(res, (_,_,resErr)) -> (res, resErr)) $ join2PP (finalPointOfNodeTree nodeTree) myCrossover)] -- | find the last resolvable point in a NodeTree finalPointOfNodeTree (NodeTree _ iNodeGens) | canPoint (lastINodeOf iNodeGens) = pPointOf $ lastINodeOf iNodeGens diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index 348e16739..5055eec94 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -1264,7 +1264,7 @@ prop_PLineWithinErrRange2 x1 y1 rawX2 rawY2 (distance2, distance2Err) = distancePPointToPLineWithErr pPoint2 pLine1 pPoint1 = makePPoint2 x1 y1 pPoint2 = makePPoint2 x2 y2 - (pLine1, pLine1Err) = join2PP pPoint1 pPoint2 + (pLine1, (_,_,pLine1Err)) = join2PP pPoint1 pPoint2 ulpTotal1, ulpTotal2 :: UlpSum ulpTotal1 = distance1Err <> pLineErrAtPPoint (pLine1, pLine1Err) pPoint1 ulpTotal2 = distance2Err <> pLineErrAtPPoint (pLine1, pLine1Err) pPoint2 From 37dcca51053c43e0f10f80865d8555fbb718d078 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Tue, 1 Nov 2022 21:17:22 +0000 Subject: [PATCH 052/206] stop crushing the error component out of pToEP. return a PPoint2Err instead of a UlpSum. --- Graphics/Slicer/Math/PGAPrimitives.hs | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index 5ef67d35f..71ab2baf4 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -555,7 +555,7 @@ class (Show a) => ProjectivePoint2 a where idealNormOfP :: a -> (ℝ, UlpSum) interpolate2PP :: (ProjectivePoint2 b) => a -> b -> ℝ -> ℝ -> (PPoint2, (PPoint2Err, PPoint2Err, PPoint2Err)) join2PP :: (ProjectivePoint2 b) => a -> b -> (PLine2, (PPoint2Err, PPoint2Err, PLine2Err)) - pToEP :: a -> (Point2, UlpSum) + pToEP :: a -> (Point2, PPoint2Err) vecOfP :: a -> GVec instance ProjectivePoint2 PPoint2 where @@ -569,9 +569,7 @@ instance ProjectivePoint2 PPoint2 where idealNormOfP a = idealNormOfProjectivePoint a interpolate2PP p1 p2 = projectivePointBetweenProjectivePoints p1 p2 join2PP a b = joinOfProjectivePoints a b - pToEP p = crushErr $ fromMaybe (error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point.") $ projectivePointToEuclidianPoint p - where - crushErr (res, PPoint2Err _ cp1Errs _ _ _ _ _) = (res, sumErrVals cp1Errs) + pToEP p = fromMaybe (error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point.") $ projectivePointToEuclidianPoint p vecOfP (PPoint2 a) = a instance ProjectivePoint2 CPPoint2 where @@ -585,9 +583,7 @@ instance ProjectivePoint2 CPPoint2 where idealNormOfP p = idealNormOfProjectivePoint p interpolate2PP p1 p2 = projectivePointBetweenProjectivePoints p1 p2 join2PP a b = joinOfProjectivePoints a b - pToEP p = crushErr $ fromMaybe (error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point.") $ projectivePointToEuclidianPoint p - where - crushErr (res, PPoint2Err _ cp1Errs _ _ _ _ _) = (res, sumErrVals cp1Errs) + pToEP p = fromMaybe (error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point.") $ projectivePointToEuclidianPoint p vecOfP (CPPoint2 v) = v -- | canonicalize a euclidian point. @@ -629,7 +625,7 @@ distanceBetweenProjectivePoints (point1, point1Err) (point2, point2Err) newPLineErr = newPLineErrRaw <> normErr -- FIXME: how does the error in newPLine effect the found norm here? (res, normErr) = normOfL newPLine - (newPLine, (_,_,newPLineErrRaw)) = join2PP point1 point2 + (newPLine, (_, _, newPLineErrRaw)) = join2PP cPoint1 cPoint2 (cPoint1, cPoint1Err) = canonicalize point1 (cPoint2, cPoint2Err) = canonicalize point2 From 33ff78e3b3f0b848176807a8a3da306fde5e1a58 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Tue, 1 Nov 2022 21:55:15 +0000 Subject: [PATCH 053/206] make distance2PP return canonicalization error, if needed. --- Graphics/Slicer/Math/PGA.hs | 18 +++++++++--------- Graphics/Slicer/Math/PGAPrimitives.hs | 6 +++--- Graphics/Slicer/Math/Skeleton/Concave.hs | 12 ++++++------ Graphics/Slicer/Math/Skeleton/Definitions.hs | 2 +- tests/Math/PGA.hs | 10 +++++----- 5 files changed, 24 insertions(+), 24 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index ae7be379b..0f35aef1d 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -315,8 +315,8 @@ pLineIntersectsLineSeg (pl1, UlpSum pl1Err) (l1, UlpSum l1Err) ulpScale | hasRawIntersection = Left $ NoIntersection rawIntersection (UlpSum $ realToFrac ulpStartSum, UlpSum $ realToFrac ulpEndSum, mempty, mempty) | otherwise = Left $ NoIntersection ((\(PPoint2 v) -> CPPoint2 v) rawIntersect) (mempty, mempty, mempty, mempty) where - (startDistance, UlpSum startDistanceErr) = distance2PP (rawIntersection, rawIntersectionErr) (start,mempty) - (endDistance, UlpSum endDistanceErr) = distance2PP (rawIntersection, rawIntersectionErr) (end,mempty) + (startDistance, (_,_,UlpSum startDistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (start,mempty) + (endDistance, (_,_,UlpSum endDistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (end,mempty) start = eToPPoint2 $ startPoint l1 end = eToPPoint2 $ endPoint l1 ulpStartSum, ulpEndSum :: ℝ @@ -357,10 +357,10 @@ lineSegIntersectsLineSeg (l1, UlpSum l1Err) (l2, UlpSum ulpL2) ulpStartSum2 = realToFrac $ ulpTotal+start2DistanceErr ulpEndSum1 = realToFrac $ ulpTotal ulpEndSum2 = realToFrac $ ulpTotal - (start1Distance, UlpSum start1DistanceErr) = distance2PP (rawIntersection, rawIntersectionErr) (start1, mempty) - (start2Distance, UlpSum start2DistanceErr) = distance2PP (rawIntersection, rawIntersectionErr) (start2, mempty) - (end1Distance, UlpSum end1DistanceErr) = distance2PP (rawIntersection, rawIntersectionErr) (end1, mempty) - (end2Distance, UlpSum end2DistanceErr) = distance2PP (rawIntersection, rawIntersectionErr) (end2, mempty) + (start1Distance, (_,_,UlpSum start1DistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (start1, mempty) + (start2Distance, (_,_,UlpSum start2DistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (start2, mempty) + (end1Distance, (_,_,UlpSum end1DistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (end1, mempty) + (end2Distance, (_,_,UlpSum end2DistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (end2, mempty) start1 = eToPPoint2 $ startPoint l1 end1 = eToPPoint2 $ endPoint l1 start2 = eToPPoint2 $ startPoint l2 @@ -385,9 +385,9 @@ onSegment ls (i, iErr) startUlp endUlp = || (midDistance <= (lengthOfSegment/2) + midFudgeFactor) || (endDistance <= endFudgeFactor) where - (startDistance, UlpSum startDistanceErr) = distance2PP (start, mempty) (i,iErr) - (midDistance, UlpSum midDistanceErr) = distance2PP (mid,midErr) (i,iErr) - (endDistance, UlpSum endDistanceErr) = distance2PP (end, mempty) (i,iErr) + (startDistance, (_,_,UlpSum startDistanceErr)) = distance2PP (start, mempty) (i, iErr) + (midDistance, (_,_,UlpSum midDistanceErr)) = distance2PP (mid, midErr) (i, iErr) + (endDistance, (_,_,UlpSum endDistanceErr)) = distance2PP (end, mempty) (i, iErr) start = eToPPoint2 $ startPoint ls (mid, (_, _, midErr)) = interpolate2PP start end 0.5 0.5 end = eToPPoint2 $ endPoint ls diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index 71ab2baf4..bceb0717f 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -549,7 +549,7 @@ class Arcable a where class (Show a) => ProjectivePoint2 a where canonicalize :: a -> (CPPoint2, PPoint2Err) consLikeP :: a -> (GVec -> a) - distance2PP :: (ProjectivePoint2 b) => (a, PPoint2Err) -> (b, PPoint2Err) -> (ℝ, UlpSum) + distance2PP :: (ProjectivePoint2 b) => (a, PPoint2Err) -> (b, PPoint2Err) -> (ℝ, (PPoint2Err, PPoint2Err, UlpSum)) forceBasisOfP :: a -> a fuzzinessOfP :: (a, PPoint2Err) -> UlpSum idealNormOfP :: a -> (ℝ, UlpSum) @@ -563,7 +563,7 @@ instance ProjectivePoint2 PPoint2 where consLikeP (PPoint2 _) = PPoint2 distance2PP p1 p2 = crushErr $ distanceBetweenProjectivePoints p1 p2 where - crushErr (a,(_,_,_,b)) = (a,b) + crushErr (res,(c1, c2, _, resErr)) = (res, (c1, c2, resErr)) forceBasisOfP a = forceProjectivePointBasis a fuzzinessOfP a = pPointFuzziness a idealNormOfP a = idealNormOfProjectivePoint a @@ -577,7 +577,7 @@ instance ProjectivePoint2 CPPoint2 where consLikeP (CPPoint2 _) = CPPoint2 distance2PP p1 p2 = crushErr $ distanceBetweenProjectivePoints p1 p2 where - crushErr (a,(_,_,_,b)) = (a,b) + crushErr (res, (c1, c2, _, resErr)) = (res, (c1, c2, resErr)) forceBasisOfP p = forceProjectivePointBasis p fuzzinessOfP a = pPointFuzziness a idealNormOfP p = idealNormOfProjectivePoint p diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index 2c291bb99..1b698ad13 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -179,8 +179,8 @@ averageNodes n1 n2 | n2Distance < getRounded n2Err = error $ "intersection is AT the point of n2!\n" <> dumpInput | otherwise = makeINode (sortedPair n1 n2) $ Just $ getOutsideArc (pPointOf n1) (normalizePLine2 $ outOf n1) (pPointOf n2) (normalizePLine2 $ outOf n2) where - (n1Distance, UlpSum n1Err) = distance2PP (intersectionOf (outOf n1) (outOf n2), mempty) (canonicalize $ pPointOf n1) - (n2Distance, UlpSum n2Err) = distance2PP (intersectionOf (outOf n1) (outOf n2), mempty) (canonicalize $ pPointOf n2) + (n1Distance, (_,_,UlpSum n1Err)) = distance2PP (intersectionOf (outOf n1) (outOf n2), mempty) (canonicalize $ pPointOf n1) + (n2Distance, (_,_,UlpSum n2Err)) = distance2PP (intersectionOf (outOf n1) (outOf n2), mempty) (canonicalize $ pPointOf n2) dumpInput = "Node1: " <> show n1 <> "\nNode2: " <> show n2 <> "\nNode1Out: " <> show (outOf n1) @@ -221,7 +221,7 @@ towardIntersection pp1 pl1 pp2 | otherwise = angleFound > realToFrac (ulpVal angleErr) where (angleFound, (_,_, angleErr)) = angleBetween2PL newPLine pl1 - (d, UlpSum dErr) = distance2PP (canonicalize pp1) (pp2, mempty) + (d, (_,_,UlpSum dErr)) = distance2PP (canonicalize pp1) (pp2, mempty) newPLine = join2CPPoint2 (fst $ canonicalize pp1) pp2 -- | Make a first generation node. @@ -667,7 +667,7 @@ skeletonOfNodes connectedLoop inSegSets iNodes = where pairCloseEnough a b = res < realToFrac errRes where - (res, UlpSum errRes) = distance2PP a b + (res, (_,_,UlpSum errRes)) = distance2PP a b linesCloseEnough = case lineIntersections of [] -> [] @@ -868,5 +868,5 @@ skeletonOfNodes connectedLoop inSegSets iNodes = && (dist2 >= realToFrac dist2Err) | otherwise = error $ "cannot intersect a node with no output:\nNode1: " <> show node1 <> "\nNode2: " <> show node2 <> "\nnodes: " <> show iNodes <> "\n" where - (dist1, UlpSum dist1Err) = distance2PP (canonicalize $ intersectionOf (outOf node1) (outOf node2)) (canonicalize $ pPointOf node1) - (dist2, UlpSum dist2Err) = distance2PP (canonicalize $ intersectionOf (outOf node1) (outOf node2)) (canonicalize $ pPointOf node2) + (dist1, (_,_,UlpSum dist1Err)) = distance2PP (canonicalize $ intersectionOf (outOf node1) (outOf node2)) (canonicalize $ pPointOf node1) + (dist2, (_,_,UlpSum dist2Err)) = distance2PP (canonicalize $ intersectionOf (outOf node1) (outOf node2)) (canonicalize $ pPointOf node2) diff --git a/Graphics/Slicer/Math/Skeleton/Definitions.hs b/Graphics/Slicer/Math/Skeleton/Definitions.hs index 7ad932e81..566026f91 100644 --- a/Graphics/Slicer/Math/Skeleton/Definitions.hs +++ b/Graphics/Slicer/Math/Skeleton/Definitions.hs @@ -122,7 +122,7 @@ instance Pointable INode where where distanceWithinErr a b = res < realToFrac err where - (res, UlpSum err) = distance2PP (canonicalize a) (canonicalize b) + (res, (_,_,UlpSum err)) = distance2PP (canonicalize a) (canonicalize b) allPLines = if hasArc iNode then slist $ nub $ (outOf iNode, errOfOut iNode) : firstPLine : secondPLine : rawPLines else slist $ nub $ firstPLine : secondPLine : rawPLines diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index 5055eec94..4f821da5a 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -1187,7 +1187,7 @@ prop_PPointWithinErrRange x y | res > realToFrac (resErr) = error $ "res too big: " <> show res | otherwise = (p1 /= p2) || (res == 0 || error "the same, but distance?") where - (res, UlpSum resErr) = distance2PP (p1,mempty) (p2,mempty) + (res, (_,_,UlpSum resErr)) = distance2PP (p1,mempty) (p2,mempty) p1 = makePPoint2 x y p2 = makePPoint2 x y @@ -1366,7 +1366,7 @@ prop_PLinesIntersectAtOrigin rawX y rawX2 rawY2 <> show intersectionErr <> "\n" where originPPoint2 = makePPoint2 0 0 - (foundDistance, UlpSum distanceErr) = distance2PP (originPPoint2, mempty) (intersectionPPoint2, intersectionErr) + (foundDistance, (_,_,UlpSum distanceErr)) = distance2PP (originPPoint2, mempty) (intersectionPPoint2, intersectionErr) (intersectionPPoint2, (_,_,intersectionErr)) = intersect2PL randomPLine1 randomPLine2 (randomPLine1, _) = randomPLineThroughOrigin x y (randomPLine2, _) = randomPLineThroughOrigin x2 y2 @@ -1394,7 +1394,7 @@ prop_PLinesIntersectAtPoint rawX y rawX2 rawY2 targetX targetY <> show intersectionErr <> "\n" where (targetPPoint2) = makePPoint2 (coerce targetX) (coerce targetY) - (foundDistance, UlpSum distanceErr) = distance2PP (targetPPoint2, mempty) (intersectionPPoint2, intersectionErr) + (foundDistance, (_,_,UlpSum distanceErr)) = distance2PP (targetPPoint2, mempty) (intersectionPPoint2, intersectionErr) (intersectionPPoint2, (_,_, intersectionErr)) = intersect2PL randomPLine1 randomPLine2 (randomPLine1, _) = randomPLineWithErr x y targetX targetY (randomPLine2, _) = randomPLineWithErr x2 y2 targetX targetY @@ -1426,7 +1426,7 @@ prop_PLineIntersectsAtXAxis x y rawX2 y2 m <> show intersectionErr <> "\n" where errSum = ulpVal $ axisIntersectionErr <> distanceErr - (foundDistance, distanceErr) = distance2PP (axisIntersectionPoint, mempty) (intersectionPPoint2, intersectionErr) + (foundDistance, (_,_,distanceErr)) = distance2PP (axisIntersectionPoint, mempty) (intersectionPPoint2, intersectionErr) axisIntersectionErr = snd $ fromJust axisIntersection axisIntersectionPoint = eToPPoint2 $ Point2 ((fromRight (error "not right?") $ fst $ fromJust axisIntersection), 0) axisIntersection = xIntercept (randomPLine1, pline1Err) @@ -1455,7 +1455,7 @@ prop_PLineIntersectsAtYAxis x y x2 rawY2 m <> show intersectionErr <> "\n" where errSum = ulpVal $ axisIntersectionErr <> distanceErr - (foundDistance, distanceErr) = distance2PP (axisIntersectionPoint,mempty) (intersectionPPoint2, intersectionErr) + (foundDistance, (_,_,distanceErr)) = distance2PP (axisIntersectionPoint,mempty) (intersectionPPoint2, intersectionErr) axisIntersectionErr = snd $ fromJust axisIntersection axisIntersectionPoint = eToPPoint2 $ Point2 (0,(fromRight (error "not right?") $ fst $ fromJust axisIntersection)) axisIntersection = yIntercept (randomPLine1, pline1Err) From dc2b65ccaa1a98179d7e8f0984f940dd00bc90bf Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Wed, 2 Nov 2022 00:44:30 +0000 Subject: [PATCH 054/206] variable naming and comment changes. --- Graphics/Slicer/Math/PGAPrimitives.hs | 44 ++++++++++++++------------- 1 file changed, 23 insertions(+), 21 deletions(-) diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index bceb0717f..75024438b 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -104,7 +104,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(G0, GEPlus, G (res, (unlikeMulErr, unlikeAddErr)) = dual2DGVec a ⎤+ dual2DGVec b infixl 9 ∨+ --- | get the dual of a vector. for a point, find a line, for a line, a point... +-- | Get the dual of a vector. for a point, find a line, for a line, a point... dual2DGVec :: GVec -> GVec dual2DGVec (GVec vals) = GVec $ foldl' addValWithoutErr [] [ @@ -118,7 +118,7 @@ dual2DGVec (GVec vals) = GVec $ foldl' addValWithoutErr [] , GVal ( valOf 0 $ getVal [GEZero 1, GEPlus 1, GEPlus 2] vals) (singleton G0) ] --- | get the dual of the error component of a vector. for a point, find a line, for a line, a point... +-- | Get the dual of the error component of a vector. for a point, find a line, for a line, a point... dual2DErrs :: [ErrVal] -> [ErrVal] dual2DErrs vals = filter (\(ErrVal a _) -> a /= mempty) [ @@ -201,7 +201,7 @@ instance ProjectiveLine2 PLine2 where translateL l d = translateProjectiveLine l d vecOfL (PLine2 v) = v --- | the two types of error of a projective line. +-- | The types of error of a projective line. data PLine2Err = PLine2Err -- AddErr [ErrVal] @@ -256,7 +256,7 @@ flipProjectiveLine line = (consLikeL line) rawRes ] (GVec vals) = vecOfL line --- | runtime basis coersion. ensure all of the '0' components exist on a Projective Line. +-- | Ensure all of the '0' components exist on a Projective Line. forceProjectiveLineBasis :: (ProjectiveLine2 a) => a -> a forceProjectiveLineBasis line | gnums == Just [singleton (GEZero 1), @@ -359,7 +359,7 @@ translateProjectiveLine line d = (PLine2 res, normErr <> PLine2Err resErrs mempt --- Projective Line Error Calculation --- ----------------------------------------- --- | when given a PLine, and two points guaranteed to be on it, return the maximum distance between a given projective point known to be on the PLine and the 'real' line. +-- | When given a PLine, and two points guaranteed to be on it, return the maximum distance between a given projective point known to be on the PLine and the 'real' line. -- FIXME: accept a error on the projectivePoint, and return an error estimate. pLineErrAtPPoint :: (ProjectiveLine2 a, ProjectivePoint2 b) => (a, PLine2Err) -> b -> UlpSum pLineErrAtPPoint (line, lineErr) errPoint @@ -478,13 +478,13 @@ angleCosBetweenProjectiveLines line1 line2 -- | Get the Canonicalized intersection of two lines. -- NOTE: Returns Nothing when the PLines are (anti)parallel. canonicalizedIntersectionOfProjectiveLines :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Maybe (CPPoint2, (PLine2Err, PLine2Err, PPoint2Err)) -canonicalizedIntersectionOfProjectiveLines l1 l2 +canonicalizedIntersectionOfProjectiveLines line1 line2 | isNothing foundVal = Nothing | otherwise = Just (cpp1, (l1Err, l2Err, pp1Err <> cpp1Err)) where (cpp1, cpp1Err) = canonicalize pp1 foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(GVec vals) -> vals) $ vecOfP pp1 - (pp1, (l1Err, l2Err, pp1Err)) = intersect2PL l1 l2 + (pp1, (l1Err, l2Err, pp1Err)) = intersect2PL line1 line2 -------------------------------- --- Projective Point Support --- @@ -535,10 +535,10 @@ instance Monoid PPoint2Err where class Pointable a where -- | Can this node be resolved into a point in 2d space? canPoint :: a -> Bool - -- | get a projective representation of this point. - pPointOf :: a -> PPoint2 -- | get a euclidian representation of this point. ePointOf :: a -> Point2 + -- | get a projective representation of this point. + pPointOf :: a -> PPoint2 -- | does this node have an output (resulting) pLine? class Arcable a where @@ -564,11 +564,11 @@ instance ProjectivePoint2 PPoint2 where distance2PP p1 p2 = crushErr $ distanceBetweenProjectivePoints p1 p2 where crushErr (res,(c1, c2, _, resErr)) = (res, (c1, c2, resErr)) - forceBasisOfP a = forceProjectivePointBasis a - fuzzinessOfP a = pPointFuzziness a - idealNormOfP a = idealNormOfProjectivePoint a + forceBasisOfP p = forceProjectivePointBasis p + fuzzinessOfP p = pPointFuzziness p + idealNormOfP p = idealNormOfProjectivePoint p interpolate2PP p1 p2 = projectivePointBetweenProjectivePoints p1 p2 - join2PP a b = joinOfProjectivePoints a b + join2PP p1 p2 = joinOfProjectivePoints p1 p2 pToEP p = fromMaybe (error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point.") $ projectivePointToEuclidianPoint p vecOfP (PPoint2 a) = a @@ -579,14 +579,14 @@ instance ProjectivePoint2 CPPoint2 where where crushErr (res, (c1, c2, _, resErr)) = (res, (c1, c2, resErr)) forceBasisOfP p = forceProjectivePointBasis p - fuzzinessOfP a = pPointFuzziness a + fuzzinessOfP p = pPointFuzziness p idealNormOfP p = idealNormOfProjectivePoint p interpolate2PP p1 p2 = projectivePointBetweenProjectivePoints p1 p2 - join2PP a b = joinOfProjectivePoints a b + join2PP p1 p2 = joinOfProjectivePoints p1 p2 pToEP p = fromMaybe (error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point.") $ projectivePointToEuclidianPoint p vecOfP (CPPoint2 v) = v --- | canonicalize a euclidian point. +-- | Canonicalize a euclidian point. -- Note: Normalization of euclidian points in PGA is really just canonicalization. -- Note: For precision, we go through some work to not bother dividing the GP1,GP2 component with itsself, and just substitute in the answer, as exactly 1. canonicalizeProjectivePoint :: (ProjectivePoint2 a) => a -> (CPPoint2, PPoint2Err) @@ -643,7 +643,7 @@ forceProjectivePointBasis point _ -> Nothing vec@(GVec vals) = vecOfP point --- | find the idealized norm of a projective point (ideal or not). +-- | Find the idealized norm of a projective point (ideal or not). idealNormOfProjectivePoint :: (ProjectivePoint2 a) => a -> (ℝ, UlpSum) idealNormOfProjectivePoint point | preRes == 0 = (0, mempty) @@ -663,7 +663,7 @@ idealNormOfProjectivePoint point e12Val = valOf 0 (getVal [GEPlus 1, GEPlus 2] rawVals) (GVec rawVals) = vecOfP point --- | a typed join function. join two points, returning a line. +-- | Join two points, returning the line that connects them. joinOfProjectivePoints :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> (PLine2, (PPoint2Err, PPoint2Err, PLine2Err)) joinOfProjectivePoints point1 point2 = (PLine2 res, (cPoint1Err, cPoint2Err, PLine2Err mempty mempty mempty mempty mempty resUlp)) @@ -675,7 +675,9 @@ joinOfProjectivePoints point1 point2 = (PLine2 res, (cPoint1, cPoint1Err) = canonicalize point1 (cPoint2, cPoint2Err) = canonicalize point2 --- FIXME: automatically raise addVecRes to a CPPoint2 if it turns out to be canonical? +-- | Find a point along the line between the two given points. +-- The position of the found point is determined by the ratio betwenn the two weights supplied. +-- If the weights are equal, the distance will be right between the two points. projectivePointBetweenProjectivePoints :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> ℝ -> ℝ -> (PPoint2, (PPoint2Err, PPoint2Err, PPoint2Err)) projectivePointBetweenProjectivePoints startPoint stopPoint weight1 weight2 | isNothing foundVal = error "tried to generate an ideal point?" @@ -714,8 +716,8 @@ sumPPointErrs errs = eValOf mempty (getVal [GEZero 1, GEPlus 1] errs) <> eValOf mempty (getVal [GEZero 1, GEPlus 2] errs) <> eValOf mempty (getVal [GEPlus 1, GEPlus 2] errs) --- | determine the amount of error in resolving a projective point. --- FIXME: this 1000 is completely made up BS. +-- | Determine the amount of error in resolving a projective point. Returns the radius of a circle aroind the given point within which the 'correct' answer should be. +-- FIXME: This 1000 here is completely made up BS. pPointFuzziness :: (ProjectivePoint2 a) => (a, PPoint2Err) -> UlpSum pPointFuzziness (point, pointErr) = UlpSum $ sumTotal * realToFrac (1+(1000*(abs angleIn + realToFrac (ulpVal $ sumPPointErrs angleUnlikeAddErr <> sumPPointErrs angleUnlikeMulErr)))) where From a40bb556b7a217edae2bbeb80b6726d22082a7b7 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Wed, 2 Nov 2022 12:56:36 +0000 Subject: [PATCH 055/206] comment fixes. --- Graphics/Slicer/Math/PGAPrimitives.hs | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index 75024438b..0d2677b5e 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -319,7 +319,7 @@ normalizeProjectiveLine line = (res, resErr) vec = vecOfL line -- | Find the norm of a given Projective Line. --- FIXME: shold we be placing this error in the PLine2Err? it doesn't effect resolving the line... +-- FIXME: should we be placing this error in the PLine2Err? it doesn't effect resolving the line... normOfProjectiveLine :: (ProjectiveLine2 a) => a -> (ℝ, PLine2Err) normOfProjectiveLine line = (res, resErr) where @@ -359,7 +359,7 @@ translateProjectiveLine line d = (PLine2 res, normErr <> PLine2Err resErrs mempt --- Projective Line Error Calculation --- ----------------------------------------- --- | When given a PLine, and two points guaranteed to be on it, return the maximum distance between a given projective point known to be on the PLine and the 'real' line. +-- | When given a projective line, return the maximum distance between a projective point known to be on the line and the equivalent point on the 'real' line, which is to say, the projective line without floating point error. -- FIXME: accept a error on the projectivePoint, and return an error estimate. pLineErrAtPPoint :: (ProjectiveLine2 a, ProjectivePoint2 b) => (a, PLine2Err) -> b -> UlpSum pLineErrAtPPoint (line, lineErr) errPoint @@ -459,7 +459,6 @@ yIntercept (line, lineErr) -- Results in a value that is ~+1 when the first line points to the "left" of the second given line, and ~-1 when pointing "right". -- FIXME: the sum of iPointErrVals is not +/- radians. -- FIXME: lots of places for precision related error here, that are not recorded or reported. --- FIXME: does not accept input imprecision. angleCosBetweenProjectiveLines :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, UlpSum)) angleCosBetweenProjectiveLines line1 line2 | isNothing canonicalizedIntersection = (0, mempty) @@ -475,8 +474,8 @@ angleCosBetweenProjectiveLines line1 line2 lvec1 = vecOfL $ forceBasisOfL line1 lvec2 = vecOfL $ forceBasisOfL line2 --- | Get the Canonicalized intersection of two lines. --- NOTE: Returns Nothing when the PLines are (anti)parallel. +-- | Get the canonicalized intersection of two lines. +-- NOTE: Returns Nothing when the lines are (anti)parallel. canonicalizedIntersectionOfProjectiveLines :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Maybe (CPPoint2, (PLine2Err, PLine2Err, PPoint2Err)) canonicalizedIntersectionOfProjectiveLines line1 line2 | isNothing foundVal = Nothing @@ -498,7 +497,7 @@ newtype PPoint2 = PPoint2 GVec newtype CPPoint2 = CPPoint2 GVec deriving (Eq, Generic, NFData, Show) --- | the error accumulated when calculating a projective point. +-- | The error accumulated when calculating a projective point. data PPoint2Err = PPoint2Err -- MeetErr. max error amounts while meeting two PLines to find this point. divided into add err, and multiply err. @@ -531,19 +530,22 @@ instance Semigroup PPoint2Err where instance Monoid PPoint2Err where mempty = PPoint2Err mempty mempty mempty mempty mempty mempty mempty --- | typeclass for points and projective points. +-- | Typeclass for nodes that may be able to be resolved into a point. class Pointable a where -- | Can this node be resolved into a point in 2d space? canPoint :: a -> Bool - -- | get a euclidian representation of this point. + -- | Get a euclidian representation of this point. ePointOf :: a -> Point2 - -- | get a projective representation of this point. + -- | Get a projective representation of this point. pPointOf :: a -> PPoint2 -- | does this node have an output (resulting) pLine? class Arcable a where + -- | Return the error quotent of the output arc, if the output arc exists. errOfOut :: a -> PLine2Err + -- | Is there an output arc from this node? hasArc :: a -> Bool + -- | If there is an output arc, return it. outOf :: a -> PLine2 class (Show a) => ProjectivePoint2 a where From 0a28f44e3ecb93c523d5d8daf5a54a63e933e97b Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Wed, 2 Nov 2022 17:31:00 +0000 Subject: [PATCH 056/206] comment changes, and break projectivePointIsIdeal out as a utility function. --- Graphics/Slicer/Math/PGAPrimitives.hs | 23 ++++++++++++++--------- 1 file changed, 14 insertions(+), 9 deletions(-) diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index 0d2677b5e..a75f31f53 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -97,6 +97,8 @@ import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(G0, GEPlus, G -------------------------------- -- | The join operator in 2D PGA, which is implemented as the meet operator operating in the dual space. +-- Implemented in this file, because this operator's implementation differs based on the dimensionality of the space we are working in. +-- `A v+ B` returns the join of A and B (and the error quotents). (∨+) :: GVec -> GVec -> (GVec, ([ErrVal], [ErrVal])) (∨+) a b = (dual2DGVec res ,(dual2DErrs unlikeMulErr, dual2DErrs unlikeAddErr)) @@ -134,12 +136,17 @@ dual2DErrs vals = filter (\(ErrVal a _) -> a /= mempty) -- | Perform basis coersion. -- Ensure that all of the required '0' components exist. Required before using basis sensitive raw operators directly. +-- TL;DR: before you can use like, unlike, or reductive operators, you have to guarantee all of the basis vectors for your appropriate type are present, even if they are set to 0. forceBasis :: [Set GNum] -> GVec -> GVec forceBasis numsets (GVec vals) = GVec $ forceVal vals <$> sort numsets where forceVal :: [GVal] -> Set GNum -> GVal forceVal has needs = GVal (valOf 0 $ getVal (elems needs) has) needs +-- | Determine if a point is an ideal point. +projectivePointIsIdeal :: (ProjectivePoint2 a) => a -> Bool +projectivePointIsIdeal point = isNothing $ getVal [GEPlus 1, GEPlus 2] $ (\(GVec vals) -> vals) $ vecOfP point + ------------------------------- --- Projective Line Support --- ------------------------------- @@ -231,7 +238,6 @@ instance Monoid PLine2Err where -- | Return the sine of the angle between the two lines, along with the error. -- Results in a value that is ~+1 when a line points in the same direction of the other given line, and ~-1 when pointing backwards. --- FIXME: accept input error, and do something with it. angleBetweenProjectiveLines :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, ([ErrVal], [ErrVal]), UlpSum)) angleBetweenProjectiveLines line1 line2 = (scalarPart likeRes, resErr) where @@ -478,11 +484,11 @@ angleCosBetweenProjectiveLines line1 line2 -- NOTE: Returns Nothing when the lines are (anti)parallel. canonicalizedIntersectionOfProjectiveLines :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Maybe (CPPoint2, (PLine2Err, PLine2Err, PPoint2Err)) canonicalizedIntersectionOfProjectiveLines line1 line2 - | isNothing foundVal = Nothing + -- | Check whether the result of our intersection returns an ideal point. if it does, it means the two lines are (anti)parallel, and we should fail. + | projectivePointIsIdeal pp1 = Nothing | otherwise = Just (cpp1, (l1Err, l2Err, pp1Err <> cpp1Err)) where (cpp1, cpp1Err) = canonicalize pp1 - foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(GVec vals) -> vals) $ vecOfP pp1 (pp1, (l1Err, l2Err, pp1Err)) = intersect2PL line1 line2 -------------------------------- @@ -593,8 +599,8 @@ instance ProjectivePoint2 CPPoint2 where -- Note: For precision, we go through some work to not bother dividing the GP1,GP2 component with itsself, and just substitute in the answer, as exactly 1. canonicalizeProjectivePoint :: (ProjectivePoint2 a) => a -> (CPPoint2, PPoint2Err) canonicalizeProjectivePoint point - | isNothing foundVal = error $ "tried to canonicalize an ideal point: " <> show point <> "\n" - -- Handle the ID case. + | projectivePointIsIdeal point = error $ "tried to canonicalize an ideal point: " <> show point <> "\n" + -- | Handle the ID case. The passed in point is canonicalized already. | valOf 1 foundVal == 1 = (CPPoint2 $ GVec rawVals, mempty) | otherwise = (res, PPoint2Err mempty scaledErrs mempty mempty mempty mempty mempty) where @@ -608,11 +614,11 @@ canonicalizeProjectivePoint point else [GVal (valOf 0 $ getVal [GEZero 1, GEPlus 2] scaledVals) (fromList [GEZero 1, GEPlus 2])] ) <> [GVal 1 (fromList [GEPlus 1, GEPlus 2])] + (GVec scaledVals, scaledErrs) = divVecScalarWithErr newVec $ valOf 1 foundVal newVec = GVec [GVal (valOf 0 $ getVal [GEZero 1, GEPlus 1] rawVals) (fromList [GEZero 1, GEPlus 1]) ,GVal (valOf 0 $ getVal [GEZero 1, GEPlus 2] rawVals) (fromList [GEZero 1, GEPlus 2])] - (GVec scaledVals, scaledErrs) = divVecScalarWithErr newVec $ valOf 1 foundVal - (GVec rawVals) = vecOfP point foundVal = getVal [GEPlus 1, GEPlus 2] rawVals + (GVec rawVals) = vecOfP point -- | Find the distance between two projective points, and the error component of the result. distanceBetweenProjectivePoints :: (ProjectivePoint2 a, ProjectivePoint2 b) => (a, PPoint2Err) -> (b, PPoint2Err) -> (ℝ, (PPoint2Err, PPoint2Err, PLine2Err, UlpSum)) @@ -682,12 +688,11 @@ joinOfProjectivePoints point1 point2 = (PLine2 res, -- If the weights are equal, the distance will be right between the two points. projectivePointBetweenProjectivePoints :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> ℝ -> ℝ -> (PPoint2, (PPoint2Err, PPoint2Err, PPoint2Err)) projectivePointBetweenProjectivePoints startPoint stopPoint weight1 weight2 - | isNothing foundVal = error "tried to generate an ideal point?" + | projectivePointIsIdeal res = error "tried to generate an ideal point?" | otherwise = (res, resErr) where res = PPoint2 rawRes resErr = (cStartPointErr, cStopPointErr, PPoint2Err mempty mempty rawResErr weighedStartErr weighedStopErr mempty mempty) - foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(GVec vals) -> vals) rawRes (rawRes, rawResErr) = addVecPairWithErr weighedStart weighedStop (weighedStart, weighedStartErr) = mulScalarVecWithErr weight1 rawStartPoint (weighedStop, weighedStopErr) = mulScalarVecWithErr weight2 rawStopPoint From 8e133ec332e19a4f3df1a50a4d3592f93c4f5f89 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Wed, 2 Nov 2022 22:31:38 +0000 Subject: [PATCH 057/206] move distanceBetweenPLinesWithErr into PGRPrimitives, naming it distanceBetweenProjectiveLines. --- Graphics/Slicer/Math/Intersections.hs | 4 ++-- Graphics/Slicer/Math/Lossy.hs | 4 ++-- Graphics/Slicer/Math/PGA.hs | 18 +++--------------- Graphics/Slicer/Math/PGAPrimitives.hs | 20 ++++++++++++++++++++ 4 files changed, 27 insertions(+), 19 deletions(-) diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index aceecebfa..dcb972780 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -36,7 +36,7 @@ import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, mapWithNeighb import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum)) -import Graphics.Slicer.Math.PGA (CPPoint2, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), Intersection(HitEndPoint, HitStartPoint, NoIntersection), PLine2, PPoint2Err, intersectsWith, distanceBetweenPLinesWithErr, outputIntersectsLineSeg, plinesIntersectIn, pToEP) +import Graphics.Slicer.Math.PGA (CPPoint2, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), Intersection(HitEndPoint, HitStartPoint, NoIntersection), PLine2, PPoint2Err, intersectsWith, distance2PL, outputIntersectsLineSeg, plinesIntersectIn, pToEP) import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle)) @@ -184,7 +184,7 @@ intersectionOf pl1 pl2 = saneIntersection $ plinesIntersectIn pl1 pl2 intersectionBetween :: PLine2 -> PLine2 -> Maybe (Either PLine2 (CPPoint2, PPoint2Err)) intersectionBetween pl1 pl2 = saneIntersection $ plinesIntersectIn pl1 pl2 where - (foundDistance, UlpSum foundErr) = distanceBetweenPLinesWithErr pl1 pl2 + (foundDistance, (_,_,UlpSum foundErr)) = distance2PL pl1 pl2 saneIntersection PAntiCollinear = Just $ Left pl1 saneIntersection PCollinear = Just $ Left pl1 saneIntersection PParallel = if foundDistance < realToFrac foundErr diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index e52a50d67..71b9359c8 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -48,7 +48,7 @@ import Graphics.Slicer.Math.Definitions (LineSeg, Point2, makeLineSeg) import Graphics.Slicer.Math.Arcs (getFirstArcWithErr, getInsideArcWithErr) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PPoint2, ProjectiveLine2, ProjectivePoint2, angleBetween2PL, canonicalize, distance2PP, distanceBetweenPLinesWithErr, distancePPointToPLineWithErr, eToPL, eToPPoint2, interpolate2PP, join2PP, normalizeL, pPointOnPerpWithErr, pToEP, translateL) +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PPoint2, ProjectiveLine2, ProjectivePoint2, angleBetween2PL, canonicalize, distance2PP, distance2PL, distancePPointToPLineWithErr, eToPL, eToPPoint2, interpolate2PP, join2PP, normalizeL, pPointOnPerpWithErr, pToEP, translateL) angleBetween :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> ℝ angleBetween pLine1 pLine2 = fst $ angleBetween2PL pLine1 pLine2 @@ -61,7 +61,7 @@ distanceBetweenPPoints :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> distanceBetweenPPoints point1 point2 = fst $ distance2PP (point1, mempty) (point2, mempty) distanceBetweenPLines :: (ProjectiveLine2 a) => a -> a -> ℝ -distanceBetweenPLines nPLine1 nPLine2 = fst $ distanceBetweenPLinesWithErr nPLine1 nPLine2 +distanceBetweenPLines nPLine1 nPLine2 = fst $ distance2PL nPLine1 nPLine2 -- | Find the unsigned distance between a point and a line. distancePPointToPLine :: (ProjectivePoint2 a, ProjectiveLine2 b) => a -> b -> ℝ diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 0f35aef1d..be720d1dd 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -39,8 +39,8 @@ module Graphics.Slicer.Math.PGA( angleBetween2PL, canonicalize, combineConsecutiveLineSegs, + distance2PL, distance2PP, - distanceBetweenPLinesWithErr, distancePPointToPLineWithErr, eToPPoint2, eToPL, @@ -85,11 +85,11 @@ import Graphics.Slicer.Definitions (ℝ) import Graphics.Slicer.Math.Definitions (Point2(Point2), LineSeg(LineSeg), addPoints, startPoint, endPoint, distance) -import Graphics.Slicer.Math.GeometricAlgebra (GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎣+), (⎤+), (⨅), (⨅+), (•), addValWithoutErr, addVecPairWithoutErr, getVal, mulScalarVecWithErr, sumErrVals, ulpVal, valOf) +import Graphics.Slicer.Math.GeometricAlgebra (GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎤+), (⨅), (⨅+), (•), addValWithoutErr, addVecPairWithoutErr, getVal, mulScalarVecWithErr, sumErrVals, ulpVal, valOf) import Graphics.Slicer.Math.Line (combineLineSegs) -import Graphics.Slicer.Math.PGAPrimitives(Arcable(errOfOut, hasArc, outOf), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(angleBetween2PL, angleCosBetween2PL, flipL, forceBasisOfL, intersect2PL, normalizeL, normOfL, translateL, vecOfL), ProjectivePoint2(canonicalize, distance2PP, forceBasisOfP, idealNormOfP, interpolate2PP, join2PP, pToEP, vecOfP), canonicalizedIntersectionOf2PL, xIntercept, yIntercept) +import Graphics.Slicer.Math.PGAPrimitives(Arcable(errOfOut, hasArc, outOf), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(angleBetween2PL, angleCosBetween2PL, distance2PL, flipL, forceBasisOfL, intersect2PL, normalizeL, normOfL, translateL, vecOfL), ProjectivePoint2(canonicalize, distance2PP, forceBasisOfP, idealNormOfP, interpolate2PP, join2PP, pToEP, vecOfP), canonicalizedIntersectionOf2PL, xIntercept, yIntercept) -- Our 2D plane coresponds to a Clifford algebra of 2,0,1. @@ -172,18 +172,6 @@ pPointsOnSameSideOfPLine point1 point2 line pv2 = vecOfP $ forceBasisOfP point2 lv1 = vecOfL $ forceBasisOfL line --- | Find the unsigned distance between two parallel or antiparallel projective lines. -distanceBetweenPLinesWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, UlpSum) -distanceBetweenPLinesWithErr line1 line2 = (ideal, resUlpSum) - where - (ideal, idealUlpSum) = idealNormOfP $ PPoint2 likeRes - resUlpSum = idealUlpSum <> sumErrVals likeMulErr <> sumErrVals likeAddErr - (likeRes, (likeMulErr, likeAddErr)) = p1 ⎣+ p2 - p1 = vecOfL $ forceBasisOfL npl1 - p2 = vecOfL $ forceBasisOfL npl2 - (npl1, _) = normalizeL line1 - (npl2, _) = normalizeL line2 - -- | A checker, to ensure two Projective Lines are going the same direction, and are parallel. -- FIXME: precision on inputs? sameDirection :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Bool diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index a75f31f53..a58c711af 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -44,6 +44,7 @@ module Graphics.Slicer.Math.PGAPrimitives angleBetween2PL, angleCosBetween2PL, canonicalizedIntersectionOf2PL, + distance2PL, flipL, forceBasisOfL, fuzzinessOfL, @@ -164,6 +165,7 @@ class ProjectiveLine2 a where angleCosBetween2PL :: (ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, UlpSum)) canonicalizedIntersectionOf2PL :: (ProjectiveLine2 b) => a -> b -> Maybe (CPPoint2, (PLine2Err, PLine2Err, PPoint2Err)) consLikeL :: a -> (GVec -> a) + distance2PL :: (ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, UlpSum)) flipL :: a -> a forceBasisOfL :: a -> a fuzzinessOfL :: (a, PLine2Err) -> UlpSum @@ -181,6 +183,9 @@ instance ProjectiveLine2 NPLine2 where angleCosBetween2PL l1 l2 = angleCosBetweenProjectiveLines l1 l2 canonicalizedIntersectionOf2PL l1 l2 = canonicalizedIntersectionOfProjectiveLines l1 l2 consLikeL _ = NPLine2 + distance2PL l1 l2 = crushErr $ distanceBetweenProjectiveLines l1 l2 + where + crushErr (res, (n1,n2,_,resErr)) = (res, (n1,n2,resErr)) flipL l = flipProjectiveLine l forceBasisOfL l = forceProjectiveLineBasis l fuzzinessOfL l = fuzzinessOfProjectiveLine l @@ -198,6 +203,9 @@ instance ProjectiveLine2 PLine2 where angleCosBetween2PL l1 l2 = angleCosBetweenProjectiveLines l1 l2 canonicalizedIntersectionOf2PL l1 l2 = canonicalizedIntersectionOfProjectiveLines l1 l2 consLikeL _ = PLine2 + distance2PL l1 l2 = crushErr $ distanceBetweenProjectiveLines l1 l2 + where + crushErr (res, (n1,n2,_,resErr)) = (res, (n1,n2,resErr)) flipL l = flipProjectiveLine l forceBasisOfL l = forceProjectiveLineBasis l fuzzinessOfL l = fuzzinessOfProjectiveLine l @@ -250,6 +258,18 @@ angleBetweenProjectiveLines line1 line2 = (scalarPart likeRes, resErr) (npl1, npl1Err) = normalizeL line1 (npl2, npl2Err) = normalizeL line2 +--- | Find the distance between two parallel or antiparallel projective lines. +distanceBetweenProjectiveLines :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, ([ErrVal], [ErrVal]), UlpSum)) +distanceBetweenProjectiveLines line1 line2 = (res, resErr) + where + (res, idealErr) = idealNormOfP $ PPoint2 like + resErr = (pv1Err, pv2Err, likeErr, idealErr) + (like, likeErr) = p1 ⎣+ p2 + p1 = vecOfL $ forceBasisOfL npl1 + p2 = vecOfL $ forceBasisOfL npl2 + (npl1, pv1Err) = normalizeL line1 + (npl2, pv2Err) = normalizeL line2 + -- | Reverse a line. same line, but pointed in the other direction. flipProjectiveLine :: (ProjectiveLine2 a) => a -> a flipProjectiveLine line = (consLikeL line) rawRes From 900b7e1f3ad647da4b285923698768435fafc95b Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Thu, 3 Nov 2022 11:37:23 +0000 Subject: [PATCH 058/206] add input error into plinesIntersectIn. --- Graphics/Slicer/Machine/Contour.hs | 12 ++-- Graphics/Slicer/Math/Intersections.hs | 14 ++--- Graphics/Slicer/Math/PGA.hs | 62 ++++++++++---------- Graphics/Slicer/Math/Skeleton/Cells.hs | 8 +-- Graphics/Slicer/Math/Skeleton/Definitions.hs | 4 +- Graphics/Slicer/Math/Skeleton/Motorcycles.hs | 14 ++--- 6 files changed, 58 insertions(+), 56 deletions(-) diff --git a/Graphics/Slicer/Machine/Contour.hs b/Graphics/Slicer/Machine/Contour.hs index 1ec76ef66..a596d0fb8 100644 --- a/Graphics/Slicer/Machine/Contour.hs +++ b/Graphics/Slicer/Machine/Contour.hs @@ -19,7 +19,7 @@ module Graphics.Slicer.Machine.Contour (cleanContour, shrinkContour, expandContour) where -import Prelude (($), otherwise, Eq, (<>), show, error, (==), (&&), Bool(True, False), Show) +import Prelude (($), fst, otherwise, Eq, (<>), show, error, (==), (&&), Bool(True, False), Show) import Data.List (null, foldl') @@ -35,9 +35,9 @@ import Graphics.Slicer.Math.Intersections (noIntersection) import Graphics.Slicer.Math.Line (combineLineSegs) -import Graphics.Slicer.Math.Lossy (eToPLine2, pToEPoint2, translatePLine2) +import Graphics.Slicer.Math.Lossy (eToPLine2, pToEPoint2) -import Graphics.Slicer.Math.PGA (combineConsecutiveLineSegs, PIntersection(IntersectsIn), plinesIntersectIn) +import Graphics.Slicer.Math.PGA (combineConsecutiveLineSegs, PIntersection(IntersectsIn), ProjectiveLine2(translateL), plinesIntersectIn) import Graphics.Slicer.Definitions(ℝ) @@ -92,16 +92,16 @@ modifyContour pathWidth contour direction [l1,l2] -> [l1,l2] (firstSeg:moreSegs) -> case unsnoc moreSegs of Nothing -> error "impossible." - (Just (middleSegs,lastSeg)) -> if noIntersection (inwardAdjust lastSeg) (inwardAdjust firstSeg) + (Just (middleSegs,lastSeg)) -> if noIntersection (fst $ inwardAdjust lastSeg) (fst $ inwardAdjust firstSeg) then middleSegs <> maybeToList (combineLineSegs lastSeg firstSeg) else inSegs concatDegenerates :: [LineSeg] -> LineSeg -> [LineSeg] concatDegenerates inSegs oneSeg = case unsnoc inSegs of Nothing -> [oneSeg] - (Just (middleSegs,lastSeg)) -> middleSegs <> if noIntersection (inwardAdjust lastSeg) (inwardAdjust oneSeg) + (Just (middleSegs,lastSeg)) -> middleSegs <> if noIntersection (fst $ inwardAdjust lastSeg) (fst $ inwardAdjust oneSeg) then maybeToList (combineLineSegs lastSeg oneSeg) else [lastSeg,oneSeg] - inwardAdjust l1 = translatePLine2 (eToPLine2 l1) (if direction == Inward then pathWidth else (-pathWidth)) + inwardAdjust l1 = translateL (eToPLine2 l1) (if direction == Inward then pathWidth else (-pathWidth)) findLineSeg :: LineSeg -> LineSeg -> LineSeg -> Maybe LineSeg findLineSeg previousln ln nextln -- The ideal case. diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index dcb972780..d52523c21 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -20,7 +20,7 @@ module Graphics.Slicer.Math.Intersections (getMotorcycleSegSetIntersections, getMotorcycleContourIntersections, contourIntersectionCount, getPLine2Intersections, intersectionOf, intersectionBetween, noIntersection, isCollinear, isAntiCollinear, isParallel, isAntiParallel) where -import Prelude (Bool, Either(Left,Right), error, otherwise, show, (&&), (<>), ($), (<$>), (/=), (.), zip, Int, (<), (*), (||), (==), fst, length, odd, realToFrac) +import Prelude (Bool, Either(Left,Right), error, otherwise, show, (&&), (<>), ($), (<$>), (/=), (.), zip, Int, (<), (*), (||), (==), fst, length, mempty, odd, realToFrac) import Data.Maybe( Maybe(Just,Nothing), catMaybes, isJust, fromJust) @@ -172,7 +172,7 @@ filterIntersections l1 l2 l3 = error -- | Get the intersection point of two lines we know have an intersection point. intersectionOf :: PLine2 -> PLine2 -> CPPoint2 -intersectionOf pl1 pl2 = saneIntersection $ plinesIntersectIn pl1 pl2 +intersectionOf pl1 pl2 = saneIntersection $ plinesIntersectIn (pl1,mempty) (pl2,mempty) where saneIntersection PAntiCollinear = error $ "cannot get the intersection of anti-collinear lines.\npl1: " <> show pl1 <> "\npl2: " <> show pl2 <> "\n" saneIntersection PCollinear = error $ "cannot get the intersection of collinear lines.\npl1: " <> show pl1 <> "\npl2: " <> show pl2 <> "\n" @@ -182,7 +182,7 @@ intersectionOf pl1 pl2 = saneIntersection $ plinesIntersectIn pl1 pl2 -- | Get the intersection point of two lines. intersectionBetween :: PLine2 -> PLine2 -> Maybe (Either PLine2 (CPPoint2, PPoint2Err)) -intersectionBetween pl1 pl2 = saneIntersection $ plinesIntersectIn pl1 pl2 +intersectionBetween pl1 pl2 = saneIntersection $ plinesIntersectIn (pl1,mempty) (pl2,mempty) where (foundDistance, (_,_,UlpSum foundErr)) = distance2PL pl1 pl2 saneIntersection PAntiCollinear = Just $ Left pl1 @@ -201,16 +201,16 @@ noIntersection pline1 pline2 = isCollinear pline1 pline2 || isParallel pline1 pl -- | check if two lines are really the same line. isCollinear :: PLine2 -> PLine2 -> Bool -isCollinear pline1 pline2 = plinesIntersectIn pline1 pline2 == PCollinear +isCollinear pline1 pline2 = plinesIntersectIn (pline1,mempty) (pline2,mempty) == PCollinear -- | check if two lines are really the same line. isAntiCollinear :: PLine2 -> PLine2 -> Bool -isAntiCollinear pline1 pline2 = plinesIntersectIn pline1 pline2 == PAntiCollinear +isAntiCollinear pline1 pline2 = plinesIntersectIn (pline1,mempty) (pline2,mempty) == PAntiCollinear -- | check if two lines are parallel. isParallel :: PLine2 -> PLine2 -> Bool -isParallel pline1 pline2 = plinesIntersectIn pline1 pline2 == PParallel +isParallel pline1 pline2 = plinesIntersectIn (pline1,mempty) (pline2,mempty) == PParallel -- | check if two lines are anti-parallel. isAntiParallel :: PLine2 -> PLine2 -> Bool -isAntiParallel pline1 pline2 = plinesIntersectIn pline1 pline2 == PAntiParallel +isAntiParallel pline1 pline2 = plinesIntersectIn (pline1,mempty) (pline2,mempty) == PAntiParallel diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index be720d1dd..38338382a 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -34,33 +34,35 @@ module Graphics.Slicer.Math.PGA( Pointable(canPoint, pPointOf, ePointOf), PPoint2(PPoint2), PPoint2Err, - ProjectiveLine2, - ProjectivePoint2, - angleBetween2PL, - canonicalize, + ProjectiveLine2( + angleBetween2PL, + distance2PL, + flipL, + intersect2PL, + normalizeL, + translateL, + vecOfL + ), + ProjectivePoint2( + canonicalize, + distance2PP, + interpolate2PP, + join2PP, + pToEP + ), combineConsecutiveLineSegs, - distance2PL, - distance2PP, distancePPointToPLineWithErr, - eToPPoint2, eToPL, - flipL, - interpolate2PP, - intersect2PL, + eToPPoint2, intersectsWith, intersectsWithErr, - join2PP, makePPoint2, - normalizeL, outputIntersectsLineSeg, pLineIsLeft, pPointOnPerpWithErr, pPointsOnSameSideOfPLine, - pToEP, plinesIntersectIn, - translateL, translateRotatePPoint2, - vecOfL ) where import Prelude (Bool, Eq((==),(/=)), Monoid(mempty), Semigroup((<>)), Show(show), ($), (*), (-), (>=), (&&), (<$>), otherwise, signum, snd, (>), (<=), (+), negate, (/), (||), (<), abs, error, sin, cos, realToFrac, fst, sum, (.)) @@ -107,8 +109,8 @@ data PIntersection = deriving (Show, Eq) -- | Determine the intersection point of two projective lines, if applicable. Otherwise, classify the relationship between the two line segments. -plinesIntersectIn :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> PIntersection -plinesIntersectIn pl1 pl2 +plinesIntersectIn :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a,PLine2Err) -> (b,PLine2Err) -> PIntersection +plinesIntersectIn (pl1, pl1Err) (pl2, pl2Err) | isNothing canonicalizedIntersection || (idealNorm <= realToFrac (ulpVal idnErr) && (sameDirection pl1 pl2 || @@ -247,7 +249,7 @@ ulpMultiplier = 570 -- FIXME: take UlpSums here. intersectsWith :: SegOrPLine2 -> SegOrPLine2 -> Either Intersection PIntersection intersectsWith (Left l1) (Left l2) = lineSegIntersectsLineSeg (l1, ulpOfLineSeg l1) (l2, ulpOfLineSeg l2) -intersectsWith (Right pl1) (Right pl2) = Right $ plinesIntersectIn pl1 pl2 +intersectsWith (Right pl1) (Right pl2) = Right $ plinesIntersectIn (pl1, mempty) (pl2, mempty) intersectsWith (Left l1) (Right pl1) = pLineIntersectsLineSeg (pl1, ulpOfPLine2 pl1) (l1, ulpOfLineSeg l1) 0 intersectsWith (Right pl1) (Left l1) = pLineIntersectsLineSeg (pl1, ulpOfPLine2 pl1) (l1, ulpOfLineSeg l1) 0 @@ -255,7 +257,7 @@ intersectsWith (Right pl1) (Left l1) = pLineIntersectsLineSeg (pl1, ul outputIntersectsLineSeg :: (Show a, Arcable a) => a -> LineSeg -> Either Intersection PIntersection outputIntersectsLineSeg source l1 -- handle the case where a segment that is an input to the node is checked against. - | isNothing canonicalizedIntersection = Right $ plinesIntersectIn pl1 pl2 + | isNothing canonicalizedIntersection = Right $ plinesIntersectIn (pl1, pl1Err) (pl2, pl2Err) | otherwise = pLineIntersectsLineSeg (pl1, pl1Ulp) (l1, pl2Ulp) 1 where pl2Ulp = snd (fromMaybe (Right 0,mempty) $ xIntercept (pl2,pl2Err)) <> snd (fromMaybe (Right 0,mempty) $ yIntercept (pl2,pl2Err)) @@ -269,12 +271,12 @@ outputIntersectsLineSeg source l1 canonicalizedIntersection = canonicalizedIntersectionOf2PL pl1 pl2 -- | A type alias, for cases where either input is acceptable. -type SegOrPLine2WithErr = Either (LineSeg, UlpSum) (PLine2,UlpSum) +type SegOrPLine2WithErr = Either (LineSeg, UlpSum) (PLine2, UlpSum) -- entry point usable for all intersection needs, complete with passed in error values. intersectsWithErr :: SegOrPLine2WithErr -> SegOrPLine2WithErr -> Either Intersection PIntersection intersectsWithErr (Left l1) (Left l2) = lineSegIntersectsLineSeg l1 l2 -intersectsWithErr (Right (pl1,_)) (Right (pl2,_)) = Right $ plinesIntersectIn pl1 pl2 +intersectsWithErr (Right (pl1,_)) (Right (pl2,_)) = Right $ plinesIntersectIn (pl1,mempty) (pl2,mempty) intersectsWithErr (Left l1@(rawL1,_)) (Right pl1@(rawPL1, _)) = pLineIntersectsLineSeg pl1 l1 ulpScale where ulpScale :: ℝ @@ -291,10 +293,10 @@ intersectsWithErr (Right pl1@(rawPL1, _)) (Left l1@(rawL1,_)) = pLineIntersectsL -- | Check if/where a line segment and a PLine intersect. pLineIntersectsLineSeg :: (PLine2, UlpSum) -> (LineSeg, UlpSum) -> ℝ -> Either Intersection PIntersection pLineIntersectsLineSeg (pl1, UlpSum pl1Err) (l1, UlpSum l1Err) ulpScale - | plinesIntersectIn pl1 pl2 == PParallel = Right PParallel - | plinesIntersectIn pl1 pl2 == PAntiParallel = Right PAntiParallel - | plinesIntersectIn pl1 pl2 == PCollinear = Right PCollinear - | plinesIntersectIn pl1 pl2 == PAntiCollinear = Right PAntiCollinear + | plinesIntersectIn (pl1,mempty) (pl2,pl2Err) == PParallel = Right PParallel + | plinesIntersectIn (pl1,mempty) (pl2,pl2Err) == PAntiParallel = Right PAntiParallel + | plinesIntersectIn (pl1,mempty) (pl2,pl2Err) == PCollinear = Right PCollinear + | plinesIntersectIn (pl1,mempty) (pl2,pl2Err) == PAntiCollinear = Right PAntiCollinear | hasRawIntersection && distance (startPoint l1) (endPoint l1) < realToFrac (startDistanceErr+endDistanceErr+ulpTotal) = error $ "cannot resolve endpoints of segment: " <> show l1 <> ".\nulpTotal: " <> show ulpTotal <> "\nulpScale: " <> show ulpScale <> "\nrawIntersect" <> show rawIntersect <> dumpULPs | hasIntersection && valOf 0 foundVal == 0 = error "intersection, but cannot cannonicalize." | hasIntersection && startDistance <= ulpStartSum = Left $ HitStartPoint l1 @@ -325,12 +327,12 @@ pLineIntersectsLineSeg (pl1, UlpSum pl1Err) (l1, UlpSum l1Err) ulpScale -- | Check if/where two line segments intersect. lineSegIntersectsLineSeg :: (LineSeg, UlpSum) -> (LineSeg, UlpSum) -> Either Intersection PIntersection lineSegIntersectsLineSeg (l1, UlpSum l1Err) (l2, UlpSum ulpL2) - | plinesIntersectIn pl1 pl2 == PParallel = Right PParallel - | plinesIntersectIn pl1 pl2 == PAntiParallel = Right PAntiParallel + | plinesIntersectIn (pl1,pl1Err) (pl2,pl2Err) == PParallel = Right PParallel + | plinesIntersectIn (pl1,pl1Err) (pl2,pl2Err) == PAntiParallel = Right PAntiParallel | hasRawIntersection && distance (startPoint l1) (endPoint l1) < realToFrac (start1DistanceErr+end1DistanceErr+ulpTotal) = error $ "cannot resolve endpoints of segment: " <> show l1 <> ".\nulpTotal: " <> show ulpTotal <> "\nrawIntersection" <> show rawIntersection <> dumpULPs | hasRawIntersection && distance (startPoint l2) (endPoint l2) < realToFrac (start2DistanceErr+end2DistanceErr+ulpTotal) = error $ "cannot resolve endpoints of segment: " <> show l1 <> ".\nulpTotal: " <> show ulpTotal <> "\nrawIntersection" <> show rawIntersection <> dumpULPs - | hasIntersection && plinesIntersectIn pl1 pl2 == PCollinear = Right PCollinear - | hasIntersection && plinesIntersectIn pl1 pl2 == PAntiCollinear = Right PAntiCollinear + | hasIntersection && plinesIntersectIn (pl1,pl1Err) (pl2,pl2Err) == PCollinear = Right PCollinear + | hasIntersection && plinesIntersectIn (pl1,pl1Err) (pl2,pl2Err) == PAntiCollinear = Right PAntiCollinear -- FIXME: why do we return a start/endpoint here? | hasIntersection && start1Distance <= ulpStartSum1 = Left $ HitStartPoint l1 | hasIntersection && end1Distance <= ulpEndSum1 = Left $ HitEndPoint l1 @@ -411,7 +413,7 @@ combineConsecutiveLineSegs lines = case lines of canCombineLineSegs l1@(LineSeg p1 s1) l2@(LineSeg p2 _) = sameLineSeg && sameMiddlePoint where -- FIXME: this does not take into account the Err introduced by eToPLine2. - sameLineSeg = plinesIntersectIn (fst $ eToPL l1) (fst $ eToPL l2) == PCollinear + sameLineSeg = plinesIntersectIn (eToPL l1) (eToPL l2) == PCollinear sameMiddlePoint = p2 == addPoints p1 s1 ------------------------------------------------ diff --git a/Graphics/Slicer/Math/Skeleton/Cells.hs b/Graphics/Slicer/Math/Skeleton/Cells.hs index fc63834a1..904d79141 100644 --- a/Graphics/Slicer/Math/Skeleton/Cells.hs +++ b/Graphics/Slicer/Math/Skeleton/Cells.hs @@ -58,7 +58,7 @@ import Graphics.Slicer.Math.Intersections (intersectionOf) import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, eToCPPoint2, eToPLine2, pToEPoint2) -import Graphics.Slicer.Math.PGA (Arcable(outOf), CPPoint2(CPPoint2), Pointable(canPoint, ePointOf, pPointOf), PIntersection(PAntiCollinear, IntersectsIn), PPoint2(PPoint2), angleBetween2PL, distance2PP, eToPPoint2, plinesIntersectIn) +import Graphics.Slicer.Math.PGA (Arcable(outOf, errOfOut), CPPoint2(CPPoint2), Pointable(canPoint, ePointOf, pPointOf), PIntersection(PAntiCollinear, IntersectsIn), PPoint2(PPoint2), angleBetween2PL, distance2PP, eToPL, eToPPoint2, plinesIntersectIn) import Graphics.Slicer.Math.PGAPrimitives (join2PP) @@ -130,7 +130,7 @@ findDivisions contour crashTree = case motorcyclesIn crashTree of cMotorcyclePoint = canonicalizePPoint2 $ pPointOf myMotorcycle cNodePoint = canonicalizePPoint2 $ pPointOf oneNode motorcycleENodeDistance = distanceBetweenPPoints cMotorcyclePoint cNodePoint - motorcycleLineSegDistance = distanceBetweenPPoints cMotorcyclePoint $ justIntersectsIn $ plinesIntersectIn (outOf myMotorcycle) (eToPLine2 $ fst $ motorcycleIntersectsAt myContour myMotorcycle) + motorcycleLineSegDistance = distanceBetweenPPoints cMotorcyclePoint $ justIntersectsIn $ plinesIntersectIn (outOf myMotorcycle, errOfOut myMotorcycle) (eToPL $ fst $ motorcycleIntersectsAt myContour myMotorcycle) (_:_) -> error "more than one opposing exterior node. cannot yet handle this situation." where justIntersectsIn :: PIntersection -> CPPoint2 @@ -140,7 +140,7 @@ findDivisions contour crashTree = case motorcyclesIn crashTree of eNodesInPath = opposingNodes myContour myMotorcycle where opposingNodes :: Contour -> Motorcycle -> [ENode] - opposingNodes c m = filter (\eNode -> plinesIntersectIn (outOf eNode) (outOf m) == PAntiCollinear) $ eNodesOfOutsideContour c + opposingNodes c m = filter (\eNode -> plinesIntersectIn (outOf eNode, errOfOut eNode) (outOf m, errOfOut m) == PAntiCollinear) $ eNodesOfOutsideContour c -- | Find a single Cell of the given contour. always finds the cell on the 'open end' of the contour. findFirstCellOfContour :: Contour -> [CellDivide] -> Maybe (Cell, Maybe [RemainingContour]) @@ -407,7 +407,7 @@ nodeTreesDoNotOverlap nodeTree1 nodeTree2 cellDivide@(CellDivide motorcycles1 _) -- | Check that the outputs of the NodeTrees collide at the same point at the division between the two cells the NodeTrees correspond to. lastOutsIntersect :: NodeTree -> NodeTree -> CellDivide -> Bool lastOutsIntersect nt1 nt2 (CellDivide motorcycles _) = case motorcycles of - (DividingMotorcycles m (Slist _ 0)) -> plinesIntersectIn (fst $ finalPLine nt1) (outOf m) == plinesIntersectIn (fst $ finalPLine nt2) (outOf m) + (DividingMotorcycles m (Slist _ 0)) -> plinesIntersectIn (finalPLine nt1) (outOf m, errOfOut m) == plinesIntersectIn (finalPLine nt2) (outOf m, errOfOut m) (DividingMotorcycles _ (Slist _ _)) -> error "cannot yet check outpoint intersections of more than one motorcycle." -- | Given a nodeTree and it's closing division, return all of the ENodes where the point of the node is on the opposite side of the division. diff --git a/Graphics/Slicer/Math/Skeleton/Definitions.hs b/Graphics/Slicer/Math/Skeleton/Definitions.hs index 566026f91..865ccd5c2 100644 --- a/Graphics/Slicer/Math/Skeleton/Definitions.hs +++ b/Graphics/Slicer/Math/Skeleton/Definitions.hs @@ -99,7 +99,7 @@ instance Pointable INode where allPLines = if hasArc iNode then cons (outOf iNode, errOfOut iNode) $ cons firstPLine $ cons secondPLine morePLines else cons firstPLine $ cons secondPLine morePLines - hasIntersectingPairs (Slist pLines _) = any (\(pl1, pl2) -> saneIntersect $ plinesIntersectIn (fst pl1) (fst pl2)) $ getPairs pLines + hasIntersectingPairs (Slist pLines _) = any (\(pl1, pl2) -> saneIntersect $ plinesIntersectIn pl1 pl2) $ getPairs pLines where saneIntersect (IntersectsIn _ _) = True saneIntersect _ = False @@ -126,7 +126,7 @@ instance Pointable INode where allPLines = if hasArc iNode then slist $ nub $ (outOf iNode, errOfOut iNode) : firstPLine : secondPLine : rawPLines else slist $ nub $ firstPLine : secondPLine : rawPLines - intersectionsOfPairs (Slist pLines _) = catMaybes $ (\(pl1, pl2) -> saneIntersect $ plinesIntersectIn (fst pl1) (fst pl2)) <$> getPairs pLines + intersectionsOfPairs (Slist pLines _) = catMaybes $ (\(pl1, pl2) -> saneIntersect $ plinesIntersectIn pl1 pl2) <$> getPairs pLines where saneIntersect (IntersectsIn a _) = Just $ (\(CPPoint2 v) -> PPoint2 v) a saneIntersect _ = Nothing diff --git a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs index 9a750b895..0938a865e 100644 --- a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs +++ b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs @@ -48,9 +48,9 @@ import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, mapWithNeighb import Graphics.Slicer.Math.Intersections (getMotorcycleSegSetIntersections, getMotorcycleContourIntersections, intersectionOf, isAntiCollinear, noIntersection) -import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, pPointBetweenPPoints, distanceBetweenPPoints, eToCPPoint2, eToPLine2, normalizePLine2, pLineFromEndpoints, pToEPoint2, translatePLine2) +import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, pPointBetweenPPoints, distanceBetweenPPoints, eToCPPoint2, eToPLine2, normalizePLine2, pLineFromEndpoints, pToEPoint2) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), PPoint2, Arcable(outOf), Pointable(canPoint, ePointOf, pPointOf), flipL, pLineIsLeft, pPointsOnSameSideOfPLine, PIntersection(IntersectsIn,PAntiCollinear), plinesIntersectIn, angleBetween2PL, outputIntersectsLineSeg) +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), PPoint2, Arcable(errOfOut, outOf), Pointable(canPoint, ePointOf, pPointOf), ProjectiveLine2(flipL, translateL), eToPL, pLineIsLeft, pPointsOnSameSideOfPLine, PIntersection(IntersectsIn,PAntiCollinear), plinesIntersectIn, angleBetween2PL, outputIntersectsLineSeg) import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle), ENode(ENode), getFirstLineSeg, linePairs, CellDivide(CellDivide), DividingMotorcycles(DividingMotorcycles), MotorcycleIntersection(WithLineSeg, WithENode, WithMotorcycle)) @@ -90,11 +90,11 @@ motorcycleDivisor motorcycle target = pPointBetweenPPoints (canonicalizePPoint2 (WithMotorcycle motorcycle2) -> canonicalizePPoint2 $ pPointOf motorcycle2 tSpeedOf :: MotorcycleIntersection -> ℝ tSpeedOf myTarget = case myTarget of - (WithLineSeg lineSeg) -> distanceBetweenPPoints (justIntersectsIn $ plinesIntersectIn (translatePLine2 (eToPLine2 lineSeg) 1) (outOf motorcycle)) (justIntersectsIn $ plinesIntersectIn (eToPLine2 lineSeg) (outOf motorcycle)) - (WithENode eNode) -> distanceBetweenPPoints (canonicalizePPoint2 $ pPointOf eNode) (justIntersectsIn $ plinesIntersectIn (translatePLine2 (eToPLine2 $ getFirstLineSeg eNode) 1) (outOf eNode)) + (WithLineSeg lineSeg) -> distanceBetweenPPoints (justIntersectsIn $ plinesIntersectIn (translateL (eToPLine2 lineSeg) 1) (outOf motorcycle, errOfOut motorcycle)) (justIntersectsIn $ plinesIntersectIn (eToPL lineSeg) (outOf motorcycle, errOfOut motorcycle)) + (WithENode eNode) -> distanceBetweenPPoints (canonicalizePPoint2 $ pPointOf eNode) (justIntersectsIn $ plinesIntersectIn (translateL (eToPLine2 $ getFirstLineSeg eNode) 1) (outOf eNode, errOfOut eNode)) (WithMotorcycle motorcycle2) -> mSpeedOf motorcycle2 mSpeedOf :: Motorcycle -> ℝ - mSpeedOf myMotorcycle@(Motorcycle (seg1,_) _ _) = distanceBetweenPPoints (canonicalizePPoint2 $ pPointOf myMotorcycle) (justIntersectsIn $ plinesIntersectIn (translatePLine2 (eToPLine2 seg1) 1) (outOf myMotorcycle)) + mSpeedOf myMotorcycle@(Motorcycle (seg1,_) _ _) = distanceBetweenPPoints (canonicalizePPoint2 $ pPointOf myMotorcycle) (justIntersectsIn $ plinesIntersectIn (translateL (eToPLine2 seg1) 1) (outOf myMotorcycle, errOfOut myMotorcycle)) justIntersectsIn :: PIntersection -> CPPoint2 justIntersectsIn res = case res of (IntersectsIn p _) -> p @@ -193,7 +193,7 @@ motorcycleFromPoints p1 p2 p3 = getOutsideArc (pLineFromEndpoints p1 p2) (pLineF $ "not collinear, but not intersecting?\n" <> "PLine1: " <> show pline1 <> "\n" <> "PLine2: " <> show pline2 <> "\n" - <> "result: " <> show (plinesIntersectIn pline1 pline2) <> "\n" + <> "result: " <> show (plinesIntersectIn (pline1,mempty) (pline2,mempty)) <> "\n" | otherwise = (flipL $ PLine2 newPLine, PLine2Err newPLineErrVals mempty mempty mempty mempty mempty) where (newPLine, newPLineErrVals) = addVecPairWithErr flippedNPV1 npv2 @@ -317,7 +317,7 @@ intersectionSameSide pointOnSide node (Motorcycle _ path _) -- | Check if the output of two motorcycles are anti-collinear with each other. motorcyclesAreAntiCollinear :: Motorcycle -> Motorcycle -> Bool -motorcyclesAreAntiCollinear motorcycle1 motorcycle2 = plinesIntersectIn (outOf motorcycle1) (outOf motorcycle2) == PAntiCollinear +motorcyclesAreAntiCollinear motorcycle1 motorcycle2 = plinesIntersectIn (outOf motorcycle1, errOfOut motorcycle1) (outOf motorcycle2, errOfOut motorcycle2) == PAntiCollinear -- | Return the total set of motorcycles in the given CellDivide motorcyclesInDivision :: CellDivide -> [Motorcycle] From 65f1595a1bcdb2f05ce36bf3b8f7a38fb1660a1c Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Thu, 3 Nov 2022 13:04:44 +0000 Subject: [PATCH 059/206] introduce outAndErrOf, and use it to make code a bit more readable. --- Graphics/Slicer/Math/PGA.hs | 4 ++-- Graphics/Slicer/Math/PGAPrimitives.hs | 3 +++ Graphics/Slicer/Math/Skeleton/Cells.hs | 8 ++++---- Graphics/Slicer/Math/Skeleton/Concave.hs | 10 ++++------ Graphics/Slicer/Math/Skeleton/Definitions.hs | 17 +++++++++++------ Graphics/Slicer/Math/Skeleton/Motorcycles.hs | 10 +++++----- 6 files changed, 29 insertions(+), 23 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 38338382a..db69fd0bb 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -24,7 +24,7 @@ -- | The purpose of this file is to hold projective geometric algebraic arithmatic. It defines a 2D PGA with mixed linear components. module Graphics.Slicer.Math.PGA( - Arcable(errOfOut, hasArc, outOf), + Arcable(errOfOut, hasArc, outAndErrOf, outOf), CPPoint2(CPPoint2), Intersection(HitStartPoint, HitEndPoint, NoIntersection), NPLine2(NPLine2), @@ -91,7 +91,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (GNum(G0, GEPlus, GEZero), GVal(GVa import Graphics.Slicer.Math.Line (combineLineSegs) -import Graphics.Slicer.Math.PGAPrimitives(Arcable(errOfOut, hasArc, outOf), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(angleBetween2PL, angleCosBetween2PL, distance2PL, flipL, forceBasisOfL, intersect2PL, normalizeL, normOfL, translateL, vecOfL), ProjectivePoint2(canonicalize, distance2PP, forceBasisOfP, idealNormOfP, interpolate2PP, join2PP, pToEP, vecOfP), canonicalizedIntersectionOf2PL, xIntercept, yIntercept) +import Graphics.Slicer.Math.PGAPrimitives(Arcable(errOfOut, hasArc, outAndErrOf, outOf), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(angleBetween2PL, angleCosBetween2PL, distance2PL, flipL, forceBasisOfL, intersect2PL, normalizeL, normOfL, translateL, vecOfL), ProjectivePoint2(canonicalize, distance2PP, forceBasisOfP, idealNormOfP, interpolate2PP, join2PP, pToEP, vecOfP), canonicalizedIntersectionOf2PL, xIntercept, yIntercept) -- Our 2D plane coresponds to a Clifford algebra of 2,0,1. diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index a58c711af..827e7c2f8 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -27,6 +27,7 @@ module Graphics.Slicer.Math.PGAPrimitives Arcable( errOfOut, hasArc, + outAndErrOf, outOf ), CPPoint2(CPPoint2), @@ -571,6 +572,8 @@ class Arcable a where errOfOut :: a -> PLine2Err -- | Is there an output arc from this node? hasArc :: a -> Bool + -- | If there is an output arc, return it, along with the error quotent. + outAndErrOf :: a -> (PLine2, PLine2Err) -- | If there is an output arc, return it. outOf :: a -> PLine2 diff --git a/Graphics/Slicer/Math/Skeleton/Cells.hs b/Graphics/Slicer/Math/Skeleton/Cells.hs index 904d79141..7e2b9fbc7 100644 --- a/Graphics/Slicer/Math/Skeleton/Cells.hs +++ b/Graphics/Slicer/Math/Skeleton/Cells.hs @@ -58,7 +58,7 @@ import Graphics.Slicer.Math.Intersections (intersectionOf) import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, eToCPPoint2, eToPLine2, pToEPoint2) -import Graphics.Slicer.Math.PGA (Arcable(outOf, errOfOut), CPPoint2(CPPoint2), Pointable(canPoint, ePointOf, pPointOf), PIntersection(PAntiCollinear, IntersectsIn), PPoint2(PPoint2), angleBetween2PL, distance2PP, eToPL, eToPPoint2, plinesIntersectIn) +import Graphics.Slicer.Math.PGA (Arcable(outAndErrOf, outOf), CPPoint2(CPPoint2), Pointable(canPoint, ePointOf, pPointOf), PIntersection(PAntiCollinear, IntersectsIn), PPoint2(PPoint2), angleBetween2PL, distance2PP, eToPL, eToPPoint2, plinesIntersectIn) import Graphics.Slicer.Math.PGAPrimitives (join2PP) @@ -130,7 +130,7 @@ findDivisions contour crashTree = case motorcyclesIn crashTree of cMotorcyclePoint = canonicalizePPoint2 $ pPointOf myMotorcycle cNodePoint = canonicalizePPoint2 $ pPointOf oneNode motorcycleENodeDistance = distanceBetweenPPoints cMotorcyclePoint cNodePoint - motorcycleLineSegDistance = distanceBetweenPPoints cMotorcyclePoint $ justIntersectsIn $ plinesIntersectIn (outOf myMotorcycle, errOfOut myMotorcycle) (eToPL $ fst $ motorcycleIntersectsAt myContour myMotorcycle) + motorcycleLineSegDistance = distanceBetweenPPoints cMotorcyclePoint $ justIntersectsIn $ plinesIntersectIn (outAndErrOf myMotorcycle) (eToPL $ fst $ motorcycleIntersectsAt myContour myMotorcycle) (_:_) -> error "more than one opposing exterior node. cannot yet handle this situation." where justIntersectsIn :: PIntersection -> CPPoint2 @@ -140,7 +140,7 @@ findDivisions contour crashTree = case motorcyclesIn crashTree of eNodesInPath = opposingNodes myContour myMotorcycle where opposingNodes :: Contour -> Motorcycle -> [ENode] - opposingNodes c m = filter (\eNode -> plinesIntersectIn (outOf eNode, errOfOut eNode) (outOf m, errOfOut m) == PAntiCollinear) $ eNodesOfOutsideContour c + opposingNodes c m = filter (\eNode -> plinesIntersectIn (outAndErrOf eNode) (outAndErrOf m) == PAntiCollinear) $ eNodesOfOutsideContour c -- | Find a single Cell of the given contour. always finds the cell on the 'open end' of the contour. findFirstCellOfContour :: Contour -> [CellDivide] -> Maybe (Cell, Maybe [RemainingContour]) @@ -407,7 +407,7 @@ nodeTreesDoNotOverlap nodeTree1 nodeTree2 cellDivide@(CellDivide motorcycles1 _) -- | Check that the outputs of the NodeTrees collide at the same point at the division between the two cells the NodeTrees correspond to. lastOutsIntersect :: NodeTree -> NodeTree -> CellDivide -> Bool lastOutsIntersect nt1 nt2 (CellDivide motorcycles _) = case motorcycles of - (DividingMotorcycles m (Slist _ 0)) -> plinesIntersectIn (finalPLine nt1) (outOf m, errOfOut m) == plinesIntersectIn (finalPLine nt2) (outOf m, errOfOut m) + (DividingMotorcycles m (Slist _ 0)) -> plinesIntersectIn (finalPLine nt1) (outAndErrOf m) == plinesIntersectIn (finalPLine nt2) (outAndErrOf m) (DividingMotorcycles _ (Slist _ _)) -> error "cannot yet check outpoint intersections of more than one motorcycle." -- | Given a nodeTree and it's closing division, return all of the ENodes where the point of the node is on the opposite side of the division. diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index 1b698ad13..79148f74c 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -62,7 +62,7 @@ import Graphics.Slicer.Math.Intersections (intersectionOf, intersectionBetween, import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, distancePPointToPLine, eToPLine2, join2CPPoint2, normalizePLine2) -import Graphics.Slicer.Math.PGA (Arcable(errOfOut, hasArc, outOf), Pointable(canPoint, pPointOf), PLine2(PLine2), PLine2Err, ProjectivePoint2, CPPoint2(CPPoint2), PPoint2(PPoint2), canonicalize, distance2PP, flipL, pLineIsLeft, angleBetween2PL, distancePPointToPLineWithErr, NPLine2(NPLine2)) +import Graphics.Slicer.Math.PGA (Arcable(errOfOut, hasArc, outAndErrOf, outOf), Pointable(canPoint, pPointOf), PLine2(PLine2), PLine2Err, ProjectivePoint2, CPPoint2(CPPoint2), PPoint2(PPoint2), canonicalize, distance2PP, flipL, pLineIsLeft, angleBetween2PL, distancePPointToPLineWithErr, NPLine2(NPLine2)) import Graphics.Slicer.Math.Skeleton.Definitions (ENode(ENode), ENodeSet(ENodeSet), INode(INode), INodeSet(INodeSet), NodeTree(NodeTree), concavePLines, getFirstLineSeg, getLastLineSeg, finalOutOf, firstInOf, getPairs, indexPLinesTo, insOf, lastINodeOf, linePairs, makeINode, sortedPLinesWithErr, isLoop) @@ -190,7 +190,7 @@ averageNodes n1 n2 -- | Take a pair of arcables, and return their outOfs, in a sorted order. sortedPair :: (Arcable a, Arcable b) => a -> b -> [(PLine2, PLine2Err)] -sortedPair n1 n2 = sortedPLinesWithErr [(outOf n1,errOfOut n1), (outOf n2,errOfOut n2)] +sortedPair n1 n2 = sortedPLinesWithErr [outAndErrOf n1, outAndErrOf n2] -- | Get a PLine along the angle bisector of the intersection of the two given line segments, pointing in the 'obtuse' direction. -- Note: we normalize our output lines. @@ -281,7 +281,7 @@ findENodesInOrder eNodeSet@(ENodeSet (Slist [(_,_)] _)) generations = findENodes where maybePLineOut :: INode -> [(PLine2,PLine2Err)] maybePLineOut myINode = if hasArc myINode - then [(outOf myINode, errOfOut myINode)] + then [outAndErrOf myINode] else [] -- for a generation with only one inode, retrieve that inode. onlyINodeIn :: [INode] -> INode @@ -599,7 +599,7 @@ skeletonOfNodes connectedLoop inSegSets iNodes = else -- Construct an INode with two identical inputs, and return it. -- FIXME: shouldn't we be able to return an empty set, instead? - Right $ INodeSet $ one [INode (outOf eNode, errOfOut eNode) (outOf eNode, errOfOut eNode) (slist []) Nothing] + Right $ INodeSet $ one [INode (outAndErrOf eNode) (outAndErrOf eNode) (slist []) Nothing] [iNode] -> handleTwoNodes eNode iNode (_:_) -> handleThreeOrMoreNodes [eNode1,eNode2] -> case iNodes of @@ -622,7 +622,6 @@ skeletonOfNodes connectedLoop inSegSets iNodes = | otherwise = errorLen2 where errorLen2 = Left $ PartialNodes (INodeSet $ one iNodes) $ "NOMATCH - length 2?\n" <> show node1 <> "\n" <> show node2 <> "\n" <> show contourLooped <> "\n" <> show eNodes <> "\n" <> show iNodes <> "\n" - outAndErrOf a = (outOf a, errOfOut a) -- Handle the the case of 3 or more nodes. handleThreeOrMoreNodes @@ -633,7 +632,6 @@ skeletonOfNodes connectedLoop inSegSets iNodes = | otherwise = errorLen3 where inodesOf (INodeSet set) = set - outAndErrOf a = (outOf a, errOfOut a) errorLen3 = error $ "shortestPairDistance: " <> show shortestPairDistance <> "\n" <> "ePairDistance: " <> show shortestEPairDistance <> "\n" diff --git a/Graphics/Slicer/Math/Skeleton/Definitions.hs b/Graphics/Slicer/Math/Skeleton/Definitions.hs index 865ccd5c2..df06e30e3 100644 --- a/Graphics/Slicer/Math/Skeleton/Definitions.hs +++ b/Graphics/Slicer/Math/Skeleton/Definitions.hs @@ -55,7 +55,7 @@ import Graphics.Slicer.Math.Definitions (Contour, LineSeg(LineSeg), Point2, mapW import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum), addVecPair) -import Graphics.Slicer.Math.PGA (plinesIntersectIn, PIntersection(IntersectsIn), flipL, PLine2(PLine2), PLine2Err, pLineIsLeft, distance2PP, Pointable(canPoint, pPointOf, ePointOf), Arcable(errOfOut, hasArc, outOf), CPPoint2(CPPoint2), PPoint2(PPoint2), canonicalize, eToPL, eToPPoint2, pToEP, vecOfL) +import Graphics.Slicer.Math.PGA (plinesIntersectIn, PIntersection(IntersectsIn), flipL, PLine2(PLine2), PLine2Err, pLineIsLeft, distance2PP, Pointable(canPoint, pPointOf, ePointOf), Arcable(errOfOut, hasArc, outAndErrOf, outOf), CPPoint2(CPPoint2), PPoint2(PPoint2), canonicalize, eToPL, eToPPoint2, pToEP, vecOfL) -- | A point where two lines segments that are part of a contour intersect, emmiting an arc toward the interior of a contour. -- FIXME: a source should have a different UlpSum for it's point and it's output. @@ -67,6 +67,7 @@ data ENode = ENode { _inPoints :: !(Point2, Point2, Point2), _arcOut :: !PLine2, instance Arcable ENode where -- an ENode always has an arc. hasArc _ = True + outAndErrOf (ENode _ outArc outErr) = (outArc, outErr) outOf (ENode _ outArc _) = outArc errOfOut (ENode _ _ outErr) = outErr @@ -85,6 +86,9 @@ data INode = INode { _firstInArc :: !(PLine2, PLine2Err), _secondInArc :: !(PLin instance Arcable INode where -- an INode might just end here. hasArc (INode _ _ _ outArc) = isJust outArc + outAndErrOf (INode _ _ _ outArc) = case outArc of + (Just (rawOutArc,rawOutErr)) -> (rawOutArc, rawOutErr) + Nothing -> error "tried to get an outArc that has no output arc." outOf (INode _ _ _ outArc) = case outArc of (Just (rawOutArc,_)) -> rawOutArc Nothing -> error "tried to get an outArc that has no output arc." @@ -97,7 +101,7 @@ instance Pointable INode where canPoint iNode@(INode firstPLine secondPLine morePLines _) = len allPLines > 1 && hasIntersectingPairs allPLines where allPLines = if hasArc iNode - then cons (outOf iNode, errOfOut iNode) $ cons firstPLine $ cons secondPLine morePLines + then cons (outAndErrOf iNode) $ cons firstPLine $ cons secondPLine morePLines else cons firstPLine $ cons secondPLine morePLines hasIntersectingPairs (Slist pLines _) = any (\(pl1, pl2) -> saneIntersect $ plinesIntersectIn pl1 pl2) $ getPairs pLines where @@ -124,7 +128,7 @@ instance Pointable INode where where (res, (_,_,UlpSum err)) = distance2PP (canonicalize a) (canonicalize b) allPLines = if hasArc iNode - then slist $ nub $ (outOf iNode, errOfOut iNode) : firstPLine : secondPLine : rawPLines + then slist $ nub $ (outAndErrOf iNode) : firstPLine : secondPLine : rawPLines else slist $ nub $ firstPLine : secondPLine : rawPLines intersectionsOfPairs (Slist pLines _) = catMaybes $ (\(pl1, pl2) -> saneIntersect $ plinesIntersectIn pl1 pl2) <$> getPairs pLines where @@ -151,6 +155,7 @@ data Motorcycle = Motorcycle { _inCSegs :: !(LineSeg, LineSeg), _outPline :: !PL instance Arcable Motorcycle where -- A Motorcycle always has an arc, which is it's path. hasArc _ = True + outAndErrOf (Motorcycle _ outArc outErr) = (outArc, outErr) outOf (Motorcycle _ outArc _) = outArc errOfOut (Motorcycle _ _ outErr) = outErr @@ -269,13 +274,13 @@ makeINode pLines maybeOut = case pLines of finalPLine :: NodeTree -> (PLine2, PLine2Err) finalPLine (NodeTree (ENodeSet (Slist [(firstENode,moreENodes)] _)) iNodeSet) | hasNoINodes iNodeSet = if len moreENodes == 0 - then (outOf firstENode, errOfOut firstENode) + then outAndErrOf firstENode else error "cannot have final PLine of NodeTree with more than one ENode, and no generations!\n" - | hasArc (finalINodeOf iNodeSet) = (outOf $ finalINodeOf iNodeSet, errOfOut $ finalINodeOf iNodeSet) + | hasArc (finalINodeOf iNodeSet) = outAndErrOf $ finalINodeOf iNodeSet | otherwise = error "has inodes, has no out, has enodes?" finalPLine (NodeTree _ iNodeSet) | hasNoINodes iNodeSet = error "cannot have final PLine of a NodeTree that is completely empty!" - | hasArc (finalINodeOf iNodeSet) = (outOf $ finalINodeOf iNodeSet, errOfOut $ finalINodeOf iNodeSet) + | hasArc (finalINodeOf iNodeSet) = outAndErrOf $ finalINodeOf iNodeSet | otherwise = error "has inodes, has no out, has no enodes?" -- | get the last output PLine of a NodeTree, if there is one. otherwise, Nothing. diff --git a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs index 0938a865e..2dd4e3731 100644 --- a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs +++ b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs @@ -50,7 +50,7 @@ import Graphics.Slicer.Math.Intersections (getMotorcycleSegSetIntersections, get import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, pPointBetweenPPoints, distanceBetweenPPoints, eToCPPoint2, eToPLine2, normalizePLine2, pLineFromEndpoints, pToEPoint2) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), PPoint2, Arcable(errOfOut, outOf), Pointable(canPoint, ePointOf, pPointOf), ProjectiveLine2(flipL, translateL), eToPL, pLineIsLeft, pPointsOnSameSideOfPLine, PIntersection(IntersectsIn,PAntiCollinear), plinesIntersectIn, angleBetween2PL, outputIntersectsLineSeg) +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), PPoint2, Arcable(outAndErrOf, outOf), Pointable(canPoint, ePointOf, pPointOf), ProjectiveLine2(flipL, translateL), eToPL, pLineIsLeft, pPointsOnSameSideOfPLine, PIntersection(IntersectsIn,PAntiCollinear), plinesIntersectIn, angleBetween2PL, outputIntersectsLineSeg) import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle), ENode(ENode), getFirstLineSeg, linePairs, CellDivide(CellDivide), DividingMotorcycles(DividingMotorcycles), MotorcycleIntersection(WithLineSeg, WithENode, WithMotorcycle)) @@ -90,11 +90,11 @@ motorcycleDivisor motorcycle target = pPointBetweenPPoints (canonicalizePPoint2 (WithMotorcycle motorcycle2) -> canonicalizePPoint2 $ pPointOf motorcycle2 tSpeedOf :: MotorcycleIntersection -> ℝ tSpeedOf myTarget = case myTarget of - (WithLineSeg lineSeg) -> distanceBetweenPPoints (justIntersectsIn $ plinesIntersectIn (translateL (eToPLine2 lineSeg) 1) (outOf motorcycle, errOfOut motorcycle)) (justIntersectsIn $ plinesIntersectIn (eToPL lineSeg) (outOf motorcycle, errOfOut motorcycle)) - (WithENode eNode) -> distanceBetweenPPoints (canonicalizePPoint2 $ pPointOf eNode) (justIntersectsIn $ plinesIntersectIn (translateL (eToPLine2 $ getFirstLineSeg eNode) 1) (outOf eNode, errOfOut eNode)) + (WithLineSeg lineSeg) -> distanceBetweenPPoints (justIntersectsIn $ plinesIntersectIn (translateL (eToPLine2 lineSeg) 1) (outAndErrOf motorcycle)) (justIntersectsIn $ plinesIntersectIn (eToPL lineSeg) (outAndErrOf motorcycle)) + (WithENode eNode) -> distanceBetweenPPoints (canonicalizePPoint2 $ pPointOf eNode) (justIntersectsIn $ plinesIntersectIn (translateL (eToPLine2 $ getFirstLineSeg eNode) 1) (outAndErrOf eNode)) (WithMotorcycle motorcycle2) -> mSpeedOf motorcycle2 mSpeedOf :: Motorcycle -> ℝ - mSpeedOf myMotorcycle@(Motorcycle (seg1,_) _ _) = distanceBetweenPPoints (canonicalizePPoint2 $ pPointOf myMotorcycle) (justIntersectsIn $ plinesIntersectIn (translateL (eToPLine2 seg1) 1) (outOf myMotorcycle, errOfOut myMotorcycle)) + mSpeedOf myMotorcycle@(Motorcycle (seg1,_) _ _) = distanceBetweenPPoints (canonicalizePPoint2 $ pPointOf myMotorcycle) (justIntersectsIn $ plinesIntersectIn (translateL (eToPLine2 seg1) 1) (outAndErrOf myMotorcycle)) justIntersectsIn :: PIntersection -> CPPoint2 justIntersectsIn res = case res of (IntersectsIn p _) -> p @@ -317,7 +317,7 @@ intersectionSameSide pointOnSide node (Motorcycle _ path _) -- | Check if the output of two motorcycles are anti-collinear with each other. motorcyclesAreAntiCollinear :: Motorcycle -> Motorcycle -> Bool -motorcyclesAreAntiCollinear motorcycle1 motorcycle2 = plinesIntersectIn (outOf motorcycle1, errOfOut motorcycle1) (outOf motorcycle2, errOfOut motorcycle2) == PAntiCollinear +motorcyclesAreAntiCollinear motorcycle1 motorcycle2 = plinesIntersectIn (outAndErrOf motorcycle1) (outAndErrOf motorcycle2) == PAntiCollinear -- | Return the total set of motorcycles in the given CellDivide motorcyclesInDivision :: CellDivide -> [Motorcycle] From 226496a1224b524faeab206ff1d4cf70f86d6906 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Fri, 4 Nov 2022 20:23:53 +0000 Subject: [PATCH 060/206] add in code to promote parallel lines to colinear if they are too close together. --- Graphics/Slicer/Math/PGA.hs | 27 ++++++++----- Graphics/Slicer/Math/PGAPrimitives.hs | 42 ++++++++++---------- Graphics/Slicer/Math/Skeleton/Definitions.hs | 8 ++-- 3 files changed, 43 insertions(+), 34 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index db69fd0bb..ef4bbf614 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -91,7 +91,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (GNum(G0, GEPlus, GEZero), GVal(GVa import Graphics.Slicer.Math.Line (combineLineSegs) -import Graphics.Slicer.Math.PGAPrimitives(Arcable(errOfOut, hasArc, outAndErrOf, outOf), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(angleBetween2PL, angleCosBetween2PL, distance2PL, flipL, forceBasisOfL, intersect2PL, normalizeL, normOfL, translateL, vecOfL), ProjectivePoint2(canonicalize, distance2PP, forceBasisOfP, idealNormOfP, interpolate2PP, join2PP, pToEP, vecOfP), canonicalizedIntersectionOf2PL, xIntercept, yIntercept) +import Graphics.Slicer.Math.PGAPrimitives(Arcable(errOfOut, hasArc, outAndErrOf, outOf), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(angleBetween2PL, angleCosBetween2PL, distance2PL, flipL, forceBasisOfL, intersect2PL, normalizeL, normOfL, translateL, vecOfL), ProjectivePoint2(canonicalize, distance2PP, forceBasisOfP, idealNormOfP, interpolate2PP, join2PP, pToEP, vecOfP), canonicalizedIntersectionOf2PL, pLineErrAtPPoint, xIntercept, yIntercept) -- Our 2D plane coresponds to a Clifford algebra of 2,0,1. @@ -117,15 +117,24 @@ plinesIntersectIn (pl1, pl1Err) (pl2, pl2Err) oppositeDirection pl1 pl2)) = if sameDirection pl1 pl2 then PCollinear else PAntiCollinear - | sameDirection pl1 pl2 = PParallel - | oppositeDirection pl1 pl2 = PAntiParallel - | otherwise = IntersectsIn res (npl1Err, npl2Err, idnErr, resErr) + | sameDirection pl1 pl2 = if d < parallelFuzziness + then PCollinear + else PParallel + | oppositeDirection pl1 pl2 = if d < parallelFuzziness + then PAntiCollinear + else PAntiParallel + | otherwise = IntersectsIn res (pl1Err <> npl1Err, pl2Err <> npl2Err, idnErr, resErr) where - (idealNorm, idnErr) = idealNormOfP intersectPoint - -- FIXME: how much do the potential normalization errors have an effect on the resultant angle? - (intersectPoint, _) = intersect2PL pl1 pl2 - (res, (npl1Err, npl2Err, resErr)) = fromJust canonicalizedIntersection - canonicalizedIntersection = canonicalizedIntersectionOf2PL pl1 pl2 + -- | The distance within which we consider (anti)parallel lines to be (anti)colinear. + parallelFuzziness :: ℝ + parallelFuzziness = realToFrac $ ulpVal $ dErr <> pLineErrAtPPoint (npl1, npl1Err <> pl1Err) res <> pLineErrAtPPoint (npl2, npl2Err <> pl2Err) res + -- | When two lines are really close to parallel or antiparallel, we use the distance between the lines to decide whether to promote them to being (anti)colinear. + (d, (_, _, dErr)) = distance2PL npl1 npl2 + (idealNorm, idnErr) = idealNormOfP res + (res, (_, _, resErr)) = fromJust canonicalizedIntersection + canonicalizedIntersection = canonicalizedIntersectionOf2PL npl1 npl2 + (npl1, npl1Err) = normalizeL pl1 + (npl2, npl2Err) = normalizeL pl2 -- | Check if the second line's direction is on the 'left' side of the first line, assuming they intersect. If they don't intersect, return Nothing. pLineIsLeft :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Maybe Bool diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index 827e7c2f8..20d389c88 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -245,6 +245,17 @@ instance Semigroup PLine2Err where instance Monoid PLine2Err where mempty = PLine2Err mempty mempty mempty mempty mempty mempty +-- | Does this node have an output (resulting) pLine? +class Arcable a where + -- | Return the error quotent of the output arc, if the output arc exists. + errOfOut :: a -> PLine2Err + -- | Is there an output arc from this node? + hasArc :: a -> Bool + -- | If there is an output arc, return it, along with it's error quotent. + outAndErrOf :: a -> (PLine2, PLine2Err) + -- | If there is an output arc, return it. + outOf :: a -> PLine2 + -- | Return the sine of the angle between the two lines, along with the error. -- Results in a value that is ~+1 when a line points in the same direction of the other given line, and ~-1 when pointing backwards. angleBetweenProjectiveLines :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, ([ErrVal], [ErrVal]), UlpSum)) @@ -259,17 +270,17 @@ angleBetweenProjectiveLines line1 line2 = (scalarPart likeRes, resErr) (npl1, npl1Err) = normalizeL line1 (npl2, npl2Err) = normalizeL line2 ---- | Find the distance between two parallel or antiparallel projective lines. +-- | Find the distance between two parallel or antiparallel projective lines. distanceBetweenProjectiveLines :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, ([ErrVal], [ErrVal]), UlpSum)) distanceBetweenProjectiveLines line1 line2 = (res, resErr) where (res, idealErr) = idealNormOfP $ PPoint2 like - resErr = (pv1Err, pv2Err, likeErr, idealErr) - (like, likeErr) = p1 ⎣+ p2 - p1 = vecOfL $ forceBasisOfL npl1 - p2 = vecOfL $ forceBasisOfL npl2 - (npl1, pv1Err) = normalizeL line1 - (npl2, pv2Err) = normalizeL line2 + resErr = (npl1Err, npl2Err, likeErr, idealErr) + (like, likeErr) = l1 ⎣+ l2 + l1 = vecOfL $ forceBasisOfL npl1 + l2 = vecOfL $ forceBasisOfL npl2 + (npl1, npl1Err) = normalizeL line1 + (npl2, npl2Err) = normalizeL line2 -- | Reverse a line. same line, but pointed in the other direction. flipProjectiveLine :: (ProjectiveLine2 a) => a -> a @@ -328,9 +339,9 @@ meetOfProjectiveLines line1 line2 = (PPoint2 res, npl2Err, resUnlikeErr)) where - (res, resUnlikeErr) = pv1 ⎤+ pv2 - pv1 = vecOfL $ forceBasisOfL npl1 - pv2 = vecOfL $ forceBasisOfL npl2 + (res, resUnlikeErr) = lv1 ⎤+ lv2 + lv1 = vecOfL $ forceBasisOfL npl1 + lv2 = vecOfL $ forceBasisOfL npl2 (npl1, npl1Err) = normalizeL line1 (npl2, npl2Err) = normalizeL line2 @@ -566,17 +577,6 @@ class Pointable a where -- | Get a projective representation of this point. pPointOf :: a -> PPoint2 --- | does this node have an output (resulting) pLine? -class Arcable a where - -- | Return the error quotent of the output arc, if the output arc exists. - errOfOut :: a -> PLine2Err - -- | Is there an output arc from this node? - hasArc :: a -> Bool - -- | If there is an output arc, return it, along with the error quotent. - outAndErrOf :: a -> (PLine2, PLine2Err) - -- | If there is an output arc, return it. - outOf :: a -> PLine2 - class (Show a) => ProjectivePoint2 a where canonicalize :: a -> (CPPoint2, PPoint2Err) consLikeP :: a -> (GVec -> a) diff --git a/Graphics/Slicer/Math/Skeleton/Definitions.hs b/Graphics/Slicer/Math/Skeleton/Definitions.hs index df06e30e3..19d19e437 100644 --- a/Graphics/Slicer/Math/Skeleton/Definitions.hs +++ b/Graphics/Slicer/Math/Skeleton/Definitions.hs @@ -85,16 +85,16 @@ data INode = INode { _firstInArc :: !(PLine2, PLine2Err), _secondInArc :: !(PLin instance Arcable INode where -- an INode might just end here. + errOfOut (INode _ _ _ outArc) = case outArc of + (Just (_,rawOutArcErr)) -> rawOutArcErr + Nothing -> error "tried to get an outArc that has no output arc." hasArc (INode _ _ _ outArc) = isJust outArc outAndErrOf (INode _ _ _ outArc) = case outArc of - (Just (rawOutArc,rawOutErr)) -> (rawOutArc, rawOutErr) + (Just (rawOutArc, rawOutErr)) -> (rawOutArc, rawOutErr) Nothing -> error "tried to get an outArc that has no output arc." outOf (INode _ _ _ outArc) = case outArc of (Just (rawOutArc,_)) -> rawOutArc Nothing -> error "tried to get an outArc that has no output arc." - errOfOut (INode _ _ _ outArc) = case outArc of - (Just (_,rawOutArcErr)) -> rawOutArcErr - Nothing -> error "tried to get an outArc that has no output arc." instance Pointable INode where -- an INode does not contain a point, we have to attempt to resolve one instead. From 44e906fbf310301e166942a3162848a362c195a2 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Fri, 4 Nov 2022 23:02:01 +0000 Subject: [PATCH 061/206] comment and variable clarity changes. --- Graphics/Slicer/Math/PGAPrimitives.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index 20d389c88..cb2137a25 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -245,7 +245,7 @@ instance Semigroup PLine2Err where instance Monoid PLine2Err where mempty = PLine2Err mempty mempty mempty mempty mempty mempty --- | Does this node have an output (resulting) pLine? +-- | Does this node have an output (resulting) line? class Arcable a where -- | Return the error quotent of the output arc, if the output arc exists. errOfOut :: a -> PLine2Err @@ -264,9 +264,9 @@ angleBetweenProjectiveLines line1 line2 = (scalarPart likeRes, resErr) resErr = (npl1Err, npl2Err, (likeMulErr,likeAddErr), ulpSum) -- FIXME: this returned ULPsum is wrong. actually try to interpret it. ulpSum = sumErrVals likeMulErr <> sumErrVals likeAddErr - (likeRes, (likeMulErr, likeAddErr)) = l1 ⎣+ l2 - l1 = vecOfL $ forceBasisOfL npl1 - l2 = vecOfL $ forceBasisOfL npl2 + (likeRes, (likeMulErr, likeAddErr)) = lv1 ⎣+ lv2 + lv1 = vecOfL $ forceBasisOfL npl1 + lv2 = vecOfL $ forceBasisOfL npl2 (npl1, npl1Err) = normalizeL line1 (npl2, npl2Err) = normalizeL line2 @@ -276,9 +276,9 @@ distanceBetweenProjectiveLines line1 line2 = (res, resErr) where (res, idealErr) = idealNormOfP $ PPoint2 like resErr = (npl1Err, npl2Err, likeErr, idealErr) - (like, likeErr) = l1 ⎣+ l2 - l1 = vecOfL $ forceBasisOfL npl1 - l2 = vecOfL $ forceBasisOfL npl2 + (like, likeErr) = lv1 ⎣+ lv2 + lv1 = vecOfL $ forceBasisOfL npl1 + lv2 = vecOfL $ forceBasisOfL npl2 (npl1, npl1Err) = normalizeL line1 (npl2, npl2Err) = normalizeL line2 From 45d67de73c11b4666ee698667234f97a4389b749 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 5 Nov 2022 00:38:22 +0000 Subject: [PATCH 062/206] make pLineIsLeft accept error quotents. --- Graphics/Slicer/Math/Contour.hs | 10 +++++----- Graphics/Slicer/Math/PGA.hs | 6 +++--- Graphics/Slicer/Math/Skeleton/Concave.hs | 8 ++++---- Graphics/Slicer/Math/Skeleton/Definitions.hs | 12 ++++++------ Graphics/Slicer/Math/Skeleton/Line.hs | 6 +++--- Graphics/Slicer/Math/Skeleton/Motorcycles.hs | 4 ++-- tests/Math/PGA.hs | 12 ++++++------ 7 files changed, 29 insertions(+), 29 deletions(-) diff --git a/Graphics/Slicer/Math/Contour.hs b/Graphics/Slicer/Math/Contour.hs index 36feb1f00..7dbd1de37 100644 --- a/Graphics/Slicer/Math/Contour.hs +++ b/Graphics/Slicer/Math/Contour.hs @@ -26,7 +26,7 @@ module Graphics.Slicer.Math.Contour (followingLineSeg, getContours, makeContourT import Prelude ((==), (&&), (*), (<), Int, (+), otherwise, (.), null, (<$>), ($), Show, filter, (/=), odd, snd, error, (<>), show, fst, Bool(True,False), Eq, Show, compare, maximum, minimum, min, (-), not, realToFrac) -import Data.List(partition, reverse, sortBy) +import Data.List (partition, reverse, sortBy) import Data.List as DL (uncons) @@ -52,7 +52,7 @@ import Graphics.Slicer.Math.Intersections (contourIntersectionCount, noIntersect import Graphics.Slicer.Math.Lossy (join2PPoint2, pPointBetweenPPoints, pToEPoint2) -import Graphics.Slicer.Math.PGA (PPoint2, eToPPoint2, eToPL, pLineIsLeft, pPointOnPerpWithErr) +import Graphics.Slicer.Math.PGA (ProjectivePoint2(join2PP), PPoint2, eToPPoint2, eToPL, pLineIsLeft, pPointOnPerpWithErr) -- Unapologetically ripped from ImplicitCAD. -- Added the ability to look at line segments backwards. @@ -225,14 +225,14 @@ followingLineSeg x = followingLineSegLooped x x -- | Check if the left hand side of the first line segment of a contour is toward the inside of the contour. insideIsLeft :: Contour -> Maybe Bool insideIsLeft contour - | isJust (innerContourPoint contour) = Just $ pLineIsLeft pline1 pLineToInside == Just True + | isJust (innerContourPoint contour) = Just $ pLineIsLeft (pl1, pl1Err) (pl2,pl2Err) == Just True | otherwise = Nothing where (p1, p2) = firstPointPairOfContour contour myMidPoint = pPointBetweenPPoints (eToPPoint2 p1) (eToPPoint2 p2) 0.5 0.5 - pLineToInside = join2PPoint2 myMidPoint innerPoint + (pl2,(_,_, pl2Err)) = join2PP myMidPoint innerPoint innerPoint = fromJust $ innerContourPoint contour - (pline1,_) = eToPL $ makeLineSeg p1 p2 + (pl1, pl1Err) = eToPL $ makeLineSeg p1 p2 -- | Find a point on the interior of a given contour, on the perpendicular bisector of the first line segment, a given distance away from the line segment. innerContourPoint :: Contour -> Maybe PPoint2 diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index ef4bbf614..ffe1a7a8d 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -109,7 +109,7 @@ data PIntersection = deriving (Show, Eq) -- | Determine the intersection point of two projective lines, if applicable. Otherwise, classify the relationship between the two line segments. -plinesIntersectIn :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a,PLine2Err) -> (b,PLine2Err) -> PIntersection +plinesIntersectIn :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> PIntersection plinesIntersectIn (pl1, pl1Err) (pl2, pl2Err) | isNothing canonicalizedIntersection || (idealNorm <= realToFrac (ulpVal idnErr) @@ -137,8 +137,8 @@ plinesIntersectIn (pl1, pl1Err) (pl2, pl2Err) (npl2, npl2Err) = normalizeL pl2 -- | Check if the second line's direction is on the 'left' side of the first line, assuming they intersect. If they don't intersect, return Nothing. -pLineIsLeft :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Maybe Bool -pLineIsLeft pl1 pl2 +pLineIsLeft :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Maybe Bool +pLineIsLeft (pl1, pl1Err) (pl2, pl2Err) | npl1 == npl2 = Nothing | abs res <= 0 = Nothing | otherwise = Just $ res > 0 diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index 79148f74c..cd64be241 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -422,9 +422,9 @@ sortINodesByENodes loop inSegSets inGens@(INodeSet rawGenerations) indexTo iNodes = iNodesBeforePLine iNodes <> iNodesAfterPLine iNodes where iNodesBeforePLine :: [INode] -> [INode] - iNodesBeforePLine = filter (\a -> firstPLine `pLineIsLeft` firstInOf a /= Just False) + iNodesBeforePLine = filter (\a -> (firstPLine, mempty) `pLineIsLeft` (firstInOf a, mempty) /= Just False) -- nodes in the right order, after the divide. - iNodesAfterPLine myINodes = withoutFlippedINodes $ filter (\a -> firstPLine `pLineIsLeft` firstInOf a == Just False) myINodes + iNodesAfterPLine myINodes = withoutFlippedINodes $ filter (\a -> (firstPLine, mempty) `pLineIsLeft` (firstInOf a, mempty) == Just False) myINodes withoutFlippedINodes maybeFlippedINodes = case flippedINodeOf maybeFlippedINodes of Nothing -> maybeFlippedINodes (Just a) -> filter (/= a) maybeFlippedINodes @@ -537,12 +537,12 @@ sortINodesByENodes loop inSegSets inGens@(INodeSet rawGenerations) -- | Sort a generation by the first in PLine. sortGeneration :: [INode] -> [INode] - sortGeneration = sortBy (\a b -> if firstInOf a `pLineIsLeft` firstInOf b == Just False then LT else GT) + sortGeneration = sortBy (\a b -> if (firstInOf a, mempty) `pLineIsLeft` (firstInOf b, mempty) == Just False then LT else GT) -- Find an inode connecting the first and last ENode, if it exists. -- FIXME: this functions, but i don't know why. :) flippedINodeOf :: [INode] -> Maybe INode - flippedINodeOf inodes = case filter (\a -> firstPLine `pLineIsLeft` firstInOf a == Just False) inodes of + flippedINodeOf inodes = case filter (\a -> (firstPLine, mempty) `pLineIsLeft` (firstInOf a, mempty) == Just False) inodes of [] -> Nothing [a] -> -- if there is only one result, it's going to only point to enodes. Just a diff --git a/Graphics/Slicer/Math/Skeleton/Definitions.hs b/Graphics/Slicer/Math/Skeleton/Definitions.hs index 19d19e437..51c70e0f7 100644 --- a/Graphics/Slicer/Math/Skeleton/Definitions.hs +++ b/Graphics/Slicer/Math/Skeleton/Definitions.hs @@ -31,7 +31,7 @@ module Graphics.Slicer.Math.Skeleton.Definitions (RemainingContour(RemainingContour), StraightSkeleton(StraightSkeleton), Spine(Spine), ENode(ENode), INode(INode), ENodeSet(ENodeSet), INodeSet(INodeSet), NodeTree(NodeTree), ancestorsOf, Motorcycle(Motorcycle), Cell(Cell), CellDivide(CellDivide), DividingMotorcycles(DividingMotorcycles), MotorcycleIntersection(WithENode, WithMotorcycle, WithLineSeg), concavePLines, getFirstLineSeg, getLastLineSeg, hasNoINodes, getPairs, linePairs, finalPLine, finalINodeOf, finalOutOf, makeINode, sortedPLines, sortedPLinesWithErr, indexPLinesTo, insOf, lastINodeOf, firstInOf, isLoop, lastInOf) where -import Prelude (Eq, Show, Bool(True, False), Ordering(LT,GT), otherwise, ($), (<$>), (==), (/=), error, (>), (&&), any, fst, and, (||), (<>), show, (<), (*), realToFrac) +import Prelude (Eq, Show, Bool(True, False), Ordering(LT,GT), otherwise, ($), (<$>), (==), (/=), error, (>), (&&), any, fst, and, (||), (<>), show, (<), (*), mempty, realToFrac) import Prelude as PL (head, last) @@ -316,7 +316,7 @@ ancestorsOf (INodeSet generations) -- | Examine two line segments that are part of a Contour, and determine if they are concave toward the interior of the Contour. if they are, construct a PLine2 bisecting them, pointing toward the interior of the Contour. concavePLines :: LineSeg -> LineSeg -> Maybe PLine2 concavePLines seg1 seg2 - | Just True == pLineIsLeft (fst $ eToPL seg1) (fst $ eToPL seg2) = Just $ PLine2 $ addVecPair pv1 pv2 + | Just True == pLineIsLeft (eToPL seg1) (eToPL seg2) = Just $ PLine2 $ addVecPair pv1 pv2 | otherwise = Nothing where (PLine2 pv1,_) = eToPL seg1 @@ -331,18 +331,18 @@ hasNoINodes iNodeSet = case iNodeSet of -- | Sort a set of PLines. yes, this is 'backwards', to match the counterclockwise order of contours. sortedPLines :: [PLine2] -> [PLine2] -sortedPLines = sortBy (\n1 n2 -> if (n1 `pLineIsLeft` n2) == Just True then LT else GT) +sortedPLines = sortBy (\n1 n2 -> if ((n1, mempty) `pLineIsLeft` (n2, mempty)) == Just True then LT else GT) -- | Sort a set of PLines. yes, this is 'backwards', to match the counterclockwise order of contours. sortedPLinesWithErr :: [(PLine2, PLine2Err)] -> [(PLine2, PLine2Err)] -sortedPLinesWithErr = sortBy (\n1 n2 -> if (fst n1 `pLineIsLeft` fst n2) == Just True then LT else GT) +sortedPLinesWithErr = sortBy (\n1 n2 -> if (n1 `pLineIsLeft` n2) == Just True then LT else GT) -- | take a sorted list of PLines, and make sure the list starts with the pline closest to (but not left of) the given PLine. indexPLinesTo :: PLine2 -> [(PLine2, PLine2Err)] -> [(PLine2, PLine2Err)] indexPLinesTo firstPLine pLines = pLinesBeforeIndex firstPLine pLines <> pLinesAfterIndex firstPLine pLines where - pLinesBeforeIndex myFirstPLine = filter (\a -> myFirstPLine `pLineIsLeft` (fst a) /= Just False) - pLinesAfterIndex myFirstPLine = filter (\a -> myFirstPLine `pLineIsLeft` (fst a) == Just False) + pLinesBeforeIndex myFirstPLine = filter (\a -> (myFirstPLine, mempty) `pLineIsLeft` a /= Just False) + pLinesAfterIndex myFirstPLine = filter (\a -> (myFirstPLine, mempty) `pLineIsLeft` a == Just False) -- | find the last PLine of an INode. lastInOf :: INode -> PLine2 diff --git a/Graphics/Slicer/Math/Skeleton/Line.hs b/Graphics/Slicer/Math/Skeleton/Line.hs index afc4af85d..22268ebcf 100644 --- a/Graphics/Slicer/Math/Skeleton/Line.hs +++ b/Graphics/Slicer/Math/Skeleton/Line.hs @@ -22,7 +22,7 @@ -- | Functions for for applying inset line segments to a series of faces, and for adding infill to a face. module Graphics.Slicer.Math.Skeleton.Line (addInset, addInfill) where -import Prelude ((==), concat, otherwise, (<$>), ($), (/=), error, (<>), show, (<>), (/), floor, fromIntegral, (+), (*), (-), (<>), (>), min, Bool(True, False), fst, maybe, snd) +import Prelude ((==), concat, otherwise, (<$>), ($), (/=), error, (<>), show, (<>), (/), floor, fromIntegral, (+), (*), (-), (<>), (>), min, Bool(True, False), fst, maybe, mempty, snd) import Data.List (sortOn, dropWhile, takeWhile, transpose) @@ -44,7 +44,7 @@ import Graphics.Slicer.Math.Skeleton.Face (Face(Face)) import Graphics.Slicer.Math.Lossy (eToNPLine2, eToPLine2, distancePPointToPLine, translatePLine2, pToEPoint2) -import Graphics.Slicer.Math.PGA (PLine2, pLineIsLeft) +import Graphics.Slicer.Math.PGA (PLine2, eToPL, pLineIsLeft) import Graphics.Slicer.Machine.Infill (makeInfill, InfillType) @@ -68,7 +68,7 @@ addLineSegsToFace distance insets face@(Face edge firstArc midArcs@(Slist rawMid ----------------------------------------------------------------------------------------- -- | The direction we need to translate our edge in order for it to be going inward. - translateDir v = case pLineIsLeft (eToPLine2 edge) firstArc of + translateDir v = case pLineIsLeft (eToPL edge) (firstArc, mempty) of (Just True) -> (-v) (Just False) -> v Nothing -> error "cannot happen: edge and firstArc are the same line?" diff --git a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs index 2dd4e3731..f3fdf0465 100644 --- a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs +++ b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs @@ -178,8 +178,8 @@ convexMotorcycles contour = catMaybes $ onlyMotorcycles <$> zip (rotateLeft $ li | otherwise = Just resPLine where resPLine = motorcycleFromPoints p1 p2 p3 - pl1 = pLineFromEndpoints p1 p2 - pl2 = pLineFromEndpoints p2 p3 + pl1 = eToPL $ makeLineSeg p1 p2 + pl2 = eToPL $ makeLineSeg p2 p3 -- | generate the un-normalized PLine2 of a motorcycle created by the three points given. motorcycleFromPoints :: Point2 -> Point2 -> Point2 -> (PLine2, PLine2Err) diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index 4f821da5a..3b6613b07 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -59,7 +59,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(GEZero, GEPlu import Graphics.Slicer.Math.Lossy (angleBetween, canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenPLines, distancePPointToPLine, eToCPPoint2, eToPLine2, getFirstArc, join2PPoint2, normalizePLine2, pPointOnPerp) -- Our 2D Projective Geometric Algebra library. -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PLine2Err(PLine2Err), canonicalize, distance2PP, distancePPointToPLineWithErr, eToPL, eToPPoint2, interpolate2PP, intersect2PL, translateL, translateRotatePPoint2, angleBetween2PL, flipL, join2PP, makePPoint2, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, distancePPointToPLineWithErr, pPointOnPerpWithErr, outOf, pPointOf, outputIntersectsLineSeg) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PLine2Err(PLine2Err), canonicalize, distance2PP, distancePPointToPLineWithErr, eToPL, eToPPoint2, interpolate2PP, intersect2PL, translateL, translateRotatePPoint2, angleBetween2PL, flipL, join2PP, makePPoint2, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, distancePPointToPLineWithErr, errOfOut, pPointOnPerpWithErr, outOf, pPointOf, outputIntersectsLineSeg) -- The primitives of our PGA only library, and error estimation code. @@ -914,11 +914,11 @@ prop_TriangleNoDivides centerX centerY rawRadians rawDists = findDivisions trian <> show firstSeg <> "\n" <> show firstPoints <> "\n" <> show (insideIsLeft triangle) <> "\n" - <> show (pLineIsLeft pLine (PLine2 pLineToInside)) <> "\n" + <> show (pLineIsLeft pLine (PLine2 pLineToInside, mempty)) <> "\n" maybeInnerPoint = innerContourPoint triangle triangle = randomTriangle centerX centerY rawRadians rawDists firstSeg = firstLineSegOfContour triangle - pLine = eToPLine2 firstSeg + pLine = eToPL firstSeg firstPoints = firstPointPairOfContour triangle (p1, p2) = firstPointPairOfContour triangle (myMidPoint,_) = interpolate2PP (eToPPoint2 p1) (eToPPoint2 p2) 0.5 0.5 @@ -1310,12 +1310,12 @@ prop_PPointOnPerpWithinErrRange x1 y1 rawX2 rawY2 rawD prop_obtuseBisectorOnBiggerSide_makeENode :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> Positive ℝ -> Radian ℝ -> Bool -> Expectation prop_obtuseBisectorOnBiggerSide_makeENode x y d1 rawR1 d2 rawR2 testFirstLine | testFirstLine = pLineIsLeft bisector pl1 --> Just True - | otherwise = pLineIsLeft pl2 bisector --> Just True + | otherwise = pLineIsLeft (pl2, mempty) bisector --> Just True where - pl1 = eToPLine2 $ getFirstLineSeg eNode + pl1 = eToPL $ getFirstLineSeg eNode pl2 = flipL $ eToPLine2 $ getLastLineSeg eNode eNode = randomENode x y d1 rawR1 d2 rawR2 - bisector = flipL $ outOf eNode + bisector = (flipL $ outOf eNode, errOfOut eNode) prop_obtuseBisectorOnBiggerSide_makeINode :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> Positive ℝ -> Radian ℝ -> Bool -> Bool -> Expectation prop_obtuseBisectorOnBiggerSide_makeINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 = (angleFound > realToFrac (1-(ulpVal angleErr)), angleFound < realToFrac (-1 + (ulpVal angleErr) :: Rounded 'TowardInf ℝ)) --> (True, False) From f7e422d21ac257f0286f3eeb39b04a55a0b20472 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 5 Nov 2022 14:55:40 +0000 Subject: [PATCH 063/206] use the angleFuzz returned by angleCosNetween2PL. --- Graphics/Slicer/Math/PGA.hs | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index ffe1a7a8d..73e554b84 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -138,13 +138,15 @@ plinesIntersectIn (pl1, pl1Err) (pl2, pl2Err) -- | Check if the second line's direction is on the 'left' side of the first line, assuming they intersect. If they don't intersect, return Nothing. pLineIsLeft :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Maybe Bool -pLineIsLeft (pl1, pl1Err) (pl2, pl2Err) - | npl1 == npl2 = Nothing - | abs res <= 0 = Nothing - | otherwise = Just $ res > 0 +pLineIsLeft (pl1, _) (pl2, _) +-- FIXME: Is there a way we can use Eq on a and b if they are the same type, rather than normalizing them first? + | npl1 == npl2 = Nothing + | abs res <= angleFuzz = Nothing + | otherwise = Just $ res > 0 where - -- FIXME: naieve implementation. use npl1Err and npl2Err to get two angle differences. - (res, _) = angleCosBetween2PL npl1 npl2 + angleFuzz :: ℝ + angleFuzz = realToFrac $ ulpVal angleFuzzRaw + (res, (_,_, angleFuzzRaw)) = angleCosBetween2PL pl1 pl2 (npl1, _) = normalizeL pl1 (npl2, _) = normalizeL pl2 From 50778f051c9c13865f7e7aabeb0cc0ab8a81ca01 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 5 Nov 2022 16:20:50 +0000 Subject: [PATCH 064/206] expose projectivePointIsIdeal as isIdealP, and use it through the typeclass. allows false by construction. --- Graphics/Slicer/Math/PGA.hs | 9 +++++---- Graphics/Slicer/Math/PGAPrimitives.hs | 20 ++++++++++++-------- 2 files changed, 17 insertions(+), 12 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 73e554b84..9b3981a11 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -91,7 +91,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (GNum(G0, GEPlus, GEZero), GVal(GVa import Graphics.Slicer.Math.Line (combineLineSegs) -import Graphics.Slicer.Math.PGAPrimitives(Arcable(errOfOut, hasArc, outAndErrOf, outOf), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(angleBetween2PL, angleCosBetween2PL, distance2PL, flipL, forceBasisOfL, intersect2PL, normalizeL, normOfL, translateL, vecOfL), ProjectivePoint2(canonicalize, distance2PP, forceBasisOfP, idealNormOfP, interpolate2PP, join2PP, pToEP, vecOfP), canonicalizedIntersectionOf2PL, pLineErrAtPPoint, xIntercept, yIntercept) +import Graphics.Slicer.Math.PGAPrimitives(Arcable(errOfOut, hasArc, outAndErrOf, outOf), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(angleBetween2PL, angleCosBetween2PL, distance2PL, flipL, forceBasisOfL, intersect2PL, normalizeL, normOfL, translateL, vecOfL), ProjectivePoint2(canonicalize, distance2PP, forceBasisOfP, idealNormOfP, interpolate2PP, isIdealP, join2PP, pToEP, vecOfP), canonicalizedIntersectionOf2PL, pLineErrAtPPoint, xIntercept, yIntercept) -- Our 2D plane coresponds to a Clifford algebra of 2,0,1. @@ -139,7 +139,7 @@ plinesIntersectIn (pl1, pl1Err) (pl2, pl2Err) -- | Check if the second line's direction is on the 'left' side of the first line, assuming they intersect. If they don't intersect, return Nothing. pLineIsLeft :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Maybe Bool pLineIsLeft (pl1, _) (pl2, _) --- FIXME: Is there a way we can use Eq on a and b if they are the same type, rather than normalizing them first? + -- | FIXME: Is there a way we can use Eq on a and b if they are the same type, rather than normalizing them first? | npl1 == npl2 = Nothing | abs res <= angleFuzz = Nothing | otherwise = Just $ res > 0 @@ -150,11 +150,13 @@ pLineIsLeft (pl1, _) (pl2, _) (npl1, _) = normalizeL pl1 (npl2, _) = normalizeL pl2 +-- | Find the distance between a projective point and a projective line. +-- Note: fails in the case of ideal points. -- FIXME: use the distance to increase ULP appropriately? -- FIXME: we lose a lot of error in this function. distancePPointToPLineWithErr :: (ProjectivePoint2 a, ProjectiveLine2 b) => a -> b -> (ℝ, UlpSum) distancePPointToPLineWithErr point line - | valOf 0 foundVal == 0 = error "attempted to get the distance of an ideal point." + | isIdealP point = error "attempted to get the distance of an ideal point." | otherwise = (res, ulpTotal) where (res, _) = normOfL newPLine @@ -164,7 +166,6 @@ distancePPointToPLineWithErr point line npvec = vecOfP $ forceBasisOfP point (linePoint, _) = fromJust $ canonicalizedIntersectionOf2PL (PLine2 lvec) (PLine2 perpLine) ulpTotal = sumErrVals plMulErr <> sumErrVals plAddErr - foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(GVec vals) -> vals) $ vecOfP $ point (NPLine2 nplvec,_) = normalizeL line -- | Determine if two points are on the same side of a given line. diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index cb2137a25..1935ed4bc 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -63,6 +63,7 @@ module Graphics.Slicer.Math.PGAPrimitives fuzzinessOfP, idealNormOfP, interpolate2PP, + isIdealP, join2PP, pToEP, vecOfP @@ -72,7 +73,7 @@ module Graphics.Slicer.Math.PGAPrimitives yIntercept ) where -import Prelude(Bool, Eq((==),(/=)), Monoid(mempty), Ord, Semigroup((<>)), Show(show), ($), (+), (*), (/), (<$>), (&&), abs, error, filter, fst, negate, otherwise, realToFrac, snd, sqrt) +import Prelude(Bool(False), Eq((==),(/=)), Monoid(mempty), Ord, Semigroup((<>)), Show(show), ($), (+), (*), (/), (<$>), (&&), abs, error, filter, fst, negate, otherwise, realToFrac, snd, sqrt) import Control.DeepSeq (NFData) @@ -145,10 +146,6 @@ forceBasis numsets (GVec vals) = GVec $ forceVal vals <$> sort numsets forceVal :: [GVal] -> Set GNum -> GVal forceVal has needs = GVal (valOf 0 $ getVal (elems needs) has) needs --- | Determine if a point is an ideal point. -projectivePointIsIdeal :: (ProjectivePoint2 a) => a -> Bool -projectivePointIsIdeal point = isNothing $ getVal [GEPlus 1, GEPlus 2] $ (\(GVec vals) -> vals) $ vecOfP point - ------------------------------- --- Projective Line Support --- ------------------------------- @@ -517,7 +514,7 @@ angleCosBetweenProjectiveLines line1 line2 canonicalizedIntersectionOfProjectiveLines :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Maybe (CPPoint2, (PLine2Err, PLine2Err, PPoint2Err)) canonicalizedIntersectionOfProjectiveLines line1 line2 -- | Check whether the result of our intersection returns an ideal point. if it does, it means the two lines are (anti)parallel, and we should fail. - | projectivePointIsIdeal pp1 = Nothing + | isIdealP pp1 = Nothing | otherwise = Just (cpp1, (l1Err, l2Err, pp1Err <> cpp1Err)) where (cpp1, cpp1Err) = canonicalize pp1 @@ -585,6 +582,7 @@ class (Show a) => ProjectivePoint2 a where fuzzinessOfP :: (a, PPoint2Err) -> UlpSum idealNormOfP :: a -> (ℝ, UlpSum) interpolate2PP :: (ProjectivePoint2 b) => a -> b -> ℝ -> ℝ -> (PPoint2, (PPoint2Err, PPoint2Err, PPoint2Err)) + isIdealP :: a -> Bool join2PP :: (ProjectivePoint2 b) => a -> b -> (PLine2, (PPoint2Err, PPoint2Err, PLine2Err)) pToEP :: a -> (Point2, PPoint2Err) vecOfP :: a -> GVec @@ -599,6 +597,7 @@ instance ProjectivePoint2 PPoint2 where fuzzinessOfP p = pPointFuzziness p idealNormOfP p = idealNormOfProjectivePoint p interpolate2PP p1 p2 = projectivePointBetweenProjectivePoints p1 p2 + isIdealP p = projectivePointIsIdeal p join2PP p1 p2 = joinOfProjectivePoints p1 p2 pToEP p = fromMaybe (error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point.") $ projectivePointToEuclidianPoint p vecOfP (PPoint2 a) = a @@ -613,6 +612,7 @@ instance ProjectivePoint2 CPPoint2 where fuzzinessOfP p = pPointFuzziness p idealNormOfP p = idealNormOfProjectivePoint p interpolate2PP p1 p2 = projectivePointBetweenProjectivePoints p1 p2 + isIdealP _ = False join2PP p1 p2 = joinOfProjectivePoints p1 p2 pToEP p = fromMaybe (error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point.") $ projectivePointToEuclidianPoint p vecOfP (CPPoint2 v) = v @@ -622,7 +622,7 @@ instance ProjectivePoint2 CPPoint2 where -- Note: For precision, we go through some work to not bother dividing the GP1,GP2 component with itsself, and just substitute in the answer, as exactly 1. canonicalizeProjectivePoint :: (ProjectivePoint2 a) => a -> (CPPoint2, PPoint2Err) canonicalizeProjectivePoint point - | projectivePointIsIdeal point = error $ "tried to canonicalize an ideal point: " <> show point <> "\n" + | isIdealP point = error $ "tried to canonicalize an ideal point: " <> show point <> "\n" -- | Handle the ID case. The passed in point is canonicalized already. | valOf 1 foundVal == 1 = (CPPoint2 $ GVec rawVals, mempty) | otherwise = (res, PPoint2Err mempty scaledErrs mempty mempty mempty mempty mempty) @@ -711,7 +711,7 @@ joinOfProjectivePoints point1 point2 = (PLine2 res, -- If the weights are equal, the distance will be right between the two points. projectivePointBetweenProjectivePoints :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> ℝ -> ℝ -> (PPoint2, (PPoint2Err, PPoint2Err, PPoint2Err)) projectivePointBetweenProjectivePoints startPoint stopPoint weight1 weight2 - | projectivePointIsIdeal res = error "tried to generate an ideal point?" + | isIdealP res = error "tried to generate an ideal point?" | otherwise = (res, resErr) where res = PPoint2 rawRes @@ -724,6 +724,10 @@ projectivePointBetweenProjectivePoints startPoint stopPoint weight1 weight2 (cStartPoint, cStartPointErr) = canonicalize startPoint (cStopPoint, cStopPointErr) = canonicalize stopPoint +-- | Determine if a point is an ideal point. +projectivePointIsIdeal :: (ProjectivePoint2 a) => a -> Bool +projectivePointIsIdeal point = isNothing $ getVal [GEPlus 1, GEPlus 2] $ (\(GVec vals) -> vals) $ vecOfP point + -- | Maybe create a euclidian point from a projective point. Will fail if the projective point is ideal. projectivePointToEuclidianPoint :: (ProjectivePoint2 a) => a -> Maybe (Point2, PPoint2Err) projectivePointToEuclidianPoint point From 263689ca5ad14ade55a766e20646a9073f49f823 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Wed, 9 Nov 2022 02:16:11 +0000 Subject: [PATCH 065/206] make distancePPointToPLineWithErr take input error, and use distance2PP internally. --- Graphics/Slicer/Math/Lossy.hs | 2 +- Graphics/Slicer/Math/PGA.hs | 29 +++++++++++++----------- Graphics/Slicer/Math/Skeleton/Concave.hs | 2 +- tests/Math/PGA.hs | 14 ++++++------ 4 files changed, 25 insertions(+), 22 deletions(-) diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index 71b9359c8..7cff7f9c7 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -65,7 +65,7 @@ distanceBetweenPLines nPLine1 nPLine2 = fst $ distance2PL nPLine1 nPLine2 -- | Find the unsigned distance between a point and a line. distancePPointToPLine :: (ProjectivePoint2 a, ProjectiveLine2 b) => a -> b -> ℝ -distancePPointToPLine point line = fst $ distancePPointToPLineWithErr point line +distancePPointToPLine point line = fst $ distancePPointToPLineWithErr (point, mempty) (line, mempty) -- | Create a projective point from a euclidian point. eToCPPoint2 :: Point2 -> CPPoint2 diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 9b3981a11..0eddfe4d8 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -87,11 +87,11 @@ import Graphics.Slicer.Definitions (ℝ) import Graphics.Slicer.Math.Definitions (Point2(Point2), LineSeg(LineSeg), addPoints, startPoint, endPoint, distance) -import Graphics.Slicer.Math.GeometricAlgebra (GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎤+), (⨅), (⨅+), (•), addValWithoutErr, addVecPairWithoutErr, getVal, mulScalarVecWithErr, sumErrVals, ulpVal, valOf) +import Graphics.Slicer.Math.GeometricAlgebra (ErrVal, GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎤+), (⨅), (⨅+), (•), addValWithoutErr, addVecPairWithoutErr, getVal, mulScalarVecWithErr, sumErrVals, ulpVal, valOf) import Graphics.Slicer.Math.Line (combineLineSegs) -import Graphics.Slicer.Math.PGAPrimitives(Arcable(errOfOut, hasArc, outAndErrOf, outOf), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(angleBetween2PL, angleCosBetween2PL, distance2PL, flipL, forceBasisOfL, intersect2PL, normalizeL, normOfL, translateL, vecOfL), ProjectivePoint2(canonicalize, distance2PP, forceBasisOfP, idealNormOfP, interpolate2PP, isIdealP, join2PP, pToEP, vecOfP), canonicalizedIntersectionOf2PL, pLineErrAtPPoint, xIntercept, yIntercept) +import Graphics.Slicer.Math.PGAPrimitives(Arcable(errOfOut, hasArc, outAndErrOf, outOf), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(angleBetween2PL, angleCosBetween2PL, distance2PL, flipL, forceBasisOfL, intersect2PL, normalizeL, translateL, vecOfL), ProjectivePoint2(canonicalize, distance2PP, forceBasisOfP, idealNormOfP, interpolate2PP, isIdealP, join2PP, pToEP, vecOfP), canonicalizedIntersectionOf2PL, pLineErrAtPPoint, xIntercept, yIntercept) -- Our 2D plane coresponds to a Clifford algebra of 2,0,1. @@ -154,19 +154,22 @@ pLineIsLeft (pl1, _) (pl2, _) -- Note: fails in the case of ideal points. -- FIXME: use the distance to increase ULP appropriately? -- FIXME: we lose a lot of error in this function. -distancePPointToPLineWithErr :: (ProjectivePoint2 a, ProjectiveLine2 b) => a -> b -> (ℝ, UlpSum) -distancePPointToPLineWithErr point line +distancePPointToPLineWithErr :: (ProjectivePoint2 a, ProjectiveLine2 b) => (a, PPoint2Err) -> (b, PLine2Err) -> (ℝ, (PPoint2Err, PLine2Err, ([ErrVal],[ErrVal]), PLine2Err, PPoint2Err, UlpSum)) +distancePPointToPLineWithErr (inPoint, inPointErr) (inLine, inLineErr) | isIdealP point = error "attempted to get the distance of an ideal point." - | otherwise = (res, ulpTotal) + | otherwise = (res, resErr) where - (res, _) = normOfL newPLine - (newPLine, _) = join2PP point linePoint - (perpLine, (plMulErr,plAddErr))= lvec ⨅+ npvec - lvec = vecOfL $ forceBasisOfL (PLine2 nplvec) - npvec = vecOfP $ forceBasisOfP point - (linePoint, _) = fromJust $ canonicalizedIntersectionOf2PL (PLine2 lvec) (PLine2 perpLine) - ulpTotal = sumErrVals plMulErr <> sumErrVals plAddErr - (NPLine2 nplvec,_) = normalizeL line + (res, (_, _, resErrRaw)) = distance2PP (point, pointErr) (linePoint, linePointErr) + resErr = (pointErr, lineErr, (plMulErr, plAddErr), perpLineErr, linePointErr, resErrRaw) + (linePoint, (_, perpLineErr, linePointErr)) = fromJust $ canonicalizedIntersectionOf2PL (PLine2 lVec) (PLine2 perpLine) + (perpLine, (plMulErr, plAddErr)) = lVec ⨅+ pVec + lVec = vecOfL $ forceBasisOfL nLine + lineErr = inLineErr <> nLineErr + (nLine, nLineErr) = normalizeL inLine + pVec = vecOfP point + pointErr = inPointErr <> cPointErr + point = forceBasisOfP cPoint + (cPoint, cPointErr) = canonicalize inPoint -- | Determine if two points are on the same side of a given line. pPointsOnSameSideOfPLine :: (ProjectivePoint2 a, ProjectivePoint2 b, ProjectiveLine2 c) => a -> b -> c -> Maybe Bool diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index cd64be241..3a431d808 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -673,7 +673,7 @@ skeletonOfNodes connectedLoop inSegSets iNodes = [] -> error "one line, no points.. makes no sense." (x:_) -> [and pointsCloseEnough && foundDistance < realToFrac foundErr] where - (foundDistance, UlpSum foundErr) = distancePPointToPLineWithErr ((\(CPPoint2 v,_) -> PPoint2 v) x) a + (foundDistance, (_,_,_,_,_,UlpSum foundErr)) = distancePPointToPLineWithErr ((\(CPPoint2 v,_) -> PPoint2 v) x, mempty) (a, mempty) (_:_) -> error $ "detected multiple lines?\n" <> show lineIntersections <> "\n" diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index 3b6613b07..324bc52ea 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -1226,11 +1226,11 @@ prop_PLineWithinErrRange1 x1 y1 rawX2 rawY2 <> "PPoint1: " <> show pPoint1 <> "\n" <> "PPoint2: " <> show pPoint2 <> "\n" -- distance1 and distance2 should be 0, in an ideal world. - (distance1, UlpSum distance1Err) = distancePPointToPLineWithErr pPoint1 nPLine - (distance2, UlpSum distance2Err) = distancePPointToPLineWithErr pPoint2 nPLine + (distance1, (_,_,_,_,_,UlpSum distance1Err)) = distancePPointToPLineWithErr (pPoint1, mempty) (nPLine, nPLineErr) + (distance2, (_,_,_,_,_,UlpSum distance2Err)) = distancePPointToPLineWithErr (pPoint2, mempty) (nPLine, nPLineErr) pPoint1 = makePPoint2 x1 y1 pPoint2 = makePPoint2 x2 y2 - (nPLine, _) = normalizeL pLine + (nPLine, nPLineErr) = normalizeL pLine (pLine, pLineErr) = eToPL $ makeLineSeg (Point2 (x1,y1)) (Point2 (x2,y2)) ulpTotal1 = distance1Err ulpTotal2 = distance2Err @@ -1260,8 +1260,8 @@ prop_PLineWithinErrRange2 x1 y1 rawX2 rawY2 <> "xIntercept(PLine1): " <> show (xIntercept (pLine1,pLine1Err)) <> "\n" <> "yIntercept(PLine1): " <> show (yIntercept (pLine1,pLine1Err)) <> "\n" -- distance1 and distance2 should be 0, in an ideal world. - (distance1, distance1Err) = distancePPointToPLineWithErr pPoint1 pLine1 - (distance2, distance2Err) = distancePPointToPLineWithErr pPoint2 pLine1 + (distance1, (_,_,_,_,_,distance1Err)) = distancePPointToPLineWithErr (pPoint1, mempty) (pLine1, pLine1Err) + (distance2, (_,_,_,_,_,distance2Err)) = distancePPointToPLineWithErr (pPoint2, mempty) (pLine1, pLine1Err) pPoint1 = makePPoint2 x1 y1 pPoint2 = makePPoint2 x2 y2 (pLine1, (_,_,pLine1Err)) = join2PP pPoint1 pPoint2 @@ -1289,8 +1289,8 @@ prop_PPointOnPerpWithinErrRange x1 y1 rawX2 rawY2 rawD <> "ulpTotal1: " <> show ulpTotal1 <> "\n" <> "ulpTotal2: " <> show ulpTotal2 <> "\n" -- res should be d, in an ideal world. - (res1,UlpSum res1Err) = distancePPointToPLineWithErr perp1 pLine - (res2,UlpSum res2Err) = distancePPointToPLineWithErr perp2 pLine + (res1,(_,_,_,_,_,UlpSum res1Err)) = distancePPointToPLineWithErr (perp1, mempty) (pLine, mempty) + (res2,(_,_,_,_,_,UlpSum res2Err)) = distancePPointToPLineWithErr (perp2, mempty) (pLine, mempty) (perp1, UlpSum ulpSumPerp1) = pPointOnPerpWithErr pLine (PPoint2 pPoint1) d (perp2, UlpSum ulpSumPerp2) = pPointOnPerpWithErr pLine (PPoint2 pPoint2) d (CPPoint2 pPoint1) = makePPoint2 x1 y1 From 99fc2e9ec33b87c710b024dececb6e62e484aa06 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Wed, 9 Nov 2022 02:17:09 +0000 Subject: [PATCH 066/206] make distancePPointToPLineWithErr take input error, and use distance2PP internally. --- Graphics/Slicer/Math/PGA.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 0eddfe4d8..39310c36a 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -156,7 +156,7 @@ pLineIsLeft (pl1, _) (pl2, _) -- FIXME: we lose a lot of error in this function. distancePPointToPLineWithErr :: (ProjectivePoint2 a, ProjectiveLine2 b) => (a, PPoint2Err) -> (b, PLine2Err) -> (ℝ, (PPoint2Err, PLine2Err, ([ErrVal],[ErrVal]), PLine2Err, PPoint2Err, UlpSum)) distancePPointToPLineWithErr (inPoint, inPointErr) (inLine, inLineErr) - | isIdealP point = error "attempted to get the distance of an ideal point." + | isIdealP inPoint = error "attempted to get the distance of an ideal point." | otherwise = (res, resErr) where (res, (_, _, resErrRaw)) = distance2PP (point, pointErr) (linePoint, linePointErr) From 49926cd2f4ea9cea8d8bac26cfed5de309a9abee Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Wed, 9 Nov 2022 23:09:05 +0000 Subject: [PATCH 067/206] change error calculation for distancePPointtoPLineWithErr, and comment a bit better. --- Graphics/Slicer/Math/PGA.hs | 22 +++++++++++++--------- 1 file changed, 13 insertions(+), 9 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 39310c36a..152ebd9d2 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -91,7 +91,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (ErrVal, GNum(G0, GEPlus, GEZero), import Graphics.Slicer.Math.Line (combineLineSegs) -import Graphics.Slicer.Math.PGAPrimitives(Arcable(errOfOut, hasArc, outAndErrOf, outOf), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(angleBetween2PL, angleCosBetween2PL, distance2PL, flipL, forceBasisOfL, intersect2PL, normalizeL, translateL, vecOfL), ProjectivePoint2(canonicalize, distance2PP, forceBasisOfP, idealNormOfP, interpolate2PP, isIdealP, join2PP, pToEP, vecOfP), canonicalizedIntersectionOf2PL, pLineErrAtPPoint, xIntercept, yIntercept) +import Graphics.Slicer.Math.PGAPrimitives(Arcable(errOfOut, hasArc, outAndErrOf, outOf), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(angleBetween2PL, angleCosBetween2PL, distance2PL, flipL, forceBasisOfL, intersect2PL, normalizeL, translateL, vecOfL), ProjectivePoint2(canonicalize, distance2PP, forceBasisOfP, fuzzinessOfP, idealNormOfP, interpolate2PP, isIdealP, join2PP, pToEP, vecOfP), canonicalizedIntersectionOf2PL, pLineErrAtPPoint, xIntercept, yIntercept) -- Our 2D plane coresponds to a Clifford algebra of 2,0,1. @@ -150,24 +150,28 @@ pLineIsLeft (pl1, _) (pl2, _) (npl1, _) = normalizeL pl1 (npl2, _) = normalizeL pl2 --- | Find the distance between a projective point and a projective line. +-- | Find the distance between a projective point and a projective line, along with the difference's error quotent. -- Note: fails in the case of ideal points. --- FIXME: use the distance to increase ULP appropriately? --- FIXME: we lose a lot of error in this function. distancePPointToPLineWithErr :: (ProjectivePoint2 a, ProjectiveLine2 b) => (a, PPoint2Err) -> (b, PLine2Err) -> (ℝ, (PPoint2Err, PLine2Err, ([ErrVal],[ErrVal]), PLine2Err, PPoint2Err, UlpSum)) distancePPointToPLineWithErr (inPoint, inPointErr) (inLine, inLineErr) | isIdealP inPoint = error "attempted to get the distance of an ideal point." | otherwise = (res, resErr) where - (res, (_, _, resErrRaw)) = distance2PP (point, pointErr) (linePoint, linePointErr) - resErr = (pointErr, lineErr, (plMulErr, plAddErr), perpLineErr, linePointErr, resErrRaw) - (linePoint, (_, perpLineErr, linePointErr)) = fromJust $ canonicalizedIntersectionOf2PL (PLine2 lVec) (PLine2 perpLine) + resErr = (cPointErr, nLineErr, (plMulErr, plAddErr), perpLineNormErr, crossPointErr, errSum) + where + errSum = distanceErr <> fuzzinessOfP (inPoint, inPointErr) <> pLineErrAtPPoint (inLine, inLineErr) crossPoint <> pLineErrAtPPoint (PLine2 perpLine, perpLineNormErr) crossPoint + -- | use distance2PP to find the distance between this crossover point, and the given point. + (res, (_, _, distanceErr)) = distance2PP (point, pointErr) (crossPoint, crossPointErr) + -- | Get the point where the perpendicular line and the input line meet. + -- FIXME: how does perpLineErr effect the result of canonicalizedIntersectionOf2PL? + (crossPoint, (_, perpLineNormErr, crossPointErr)) = fromJust $ canonicalizedIntersectionOf2PL nLine (PLine2 perpLine) + -- | Get a perpendicular line, crossing the input line closest to the given point. + -- FIXME: where should we put this in PLine2Err? (perpLine, (plMulErr, plAddErr)) = lVec ⨅+ pVec lVec = vecOfL $ forceBasisOfL nLine - lineErr = inLineErr <> nLineErr (nLine, nLineErr) = normalizeL inLine - pVec = vecOfP point pointErr = inPointErr <> cPointErr + pVec = vecOfP point point = forceBasisOfP cPoint (cPoint, cPointErr) = canonicalize inPoint From ec9ce0a33e4c2da0766b061329f1b9cc5e806115 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Fri, 11 Nov 2022 20:15:35 +0000 Subject: [PATCH 068/206] force pPointOnPerpWithErr to return some of the error quotent, and use canonicalization on its input. --- Graphics/Slicer/Math/Contour.hs | 4 +-- Graphics/Slicer/Math/PGA.hs | 44 +++++++++++++++++++-------------- tests/Math/PGA.hs | 14 +++++------ 3 files changed, 34 insertions(+), 28 deletions(-) diff --git a/Graphics/Slicer/Math/Contour.hs b/Graphics/Slicer/Math/Contour.hs index 7dbd1de37..9b1592f3d 100644 --- a/Graphics/Slicer/Math/Contour.hs +++ b/Graphics/Slicer/Math/Contour.hs @@ -246,8 +246,8 @@ innerContourPoint contour (p1, p2) = firstPointPairOfContour contour source = join2PPoint2 (eToPPoint2 p1) (eToPPoint2 p2) myMidPoint = pPointBetweenPPoints (eToPPoint2 p1) (eToPPoint2 p2) 0.5 0.5 - (perpPoint, UlpSum perpErr) = pPointOnPerpWithErr source myMidPoint minDistanceFromSeg - (otherPoint, UlpSum otherErr) = pPointOnPerpWithErr source myMidPoint (-minDistanceFromSeg) + (perpPoint, (_,_,_, UlpSum perpErr)) = pPointOnPerpWithErr source myMidPoint minDistanceFromSeg + (otherPoint,(_,_,_, UlpSum otherErr)) = pPointOnPerpWithErr source myMidPoint (-minDistanceFromSeg) numIntersections = contourIntersectionCount contour (pToEPoint2 perpPoint, outsidePoint) otherIntersections = contourIntersectionCount contour (pToEPoint2 otherPoint, outsidePoint) outsidePoint = pointFarOutsideContour contour diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 152ebd9d2..3e288664a 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -87,7 +87,7 @@ import Graphics.Slicer.Definitions (ℝ) import Graphics.Slicer.Math.Definitions (Point2(Point2), LineSeg(LineSeg), addPoints, startPoint, endPoint, distance) -import Graphics.Slicer.Math.GeometricAlgebra (ErrVal, GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎤+), (⨅), (⨅+), (•), addValWithoutErr, addVecPairWithoutErr, getVal, mulScalarVecWithErr, sumErrVals, ulpVal, valOf) +import Graphics.Slicer.Math.GeometricAlgebra (ErrVal, GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎤+), (⨅), (⨅+), (•), addValWithoutErr, addVecPairWithoutErr, eValOf, getVal, mulScalarVecWithErr, ulpVal, valOf) import Graphics.Slicer.Math.Line (combineLineSegs) @@ -151,7 +151,7 @@ pLineIsLeft (pl1, _) (pl2, _) (npl2, _) = normalizeL pl2 -- | Find the distance between a projective point and a projective line, along with the difference's error quotent. --- Note: fails in the case of ideal points. +-- Note: Fails in the case of ideal points. distancePPointToPLineWithErr :: (ProjectivePoint2 a, ProjectiveLine2 b) => (a, PPoint2Err) -> (b, PLine2Err) -> (ℝ, (PPoint2Err, PLine2Err, ([ErrVal],[ErrVal]), PLine2Err, PPoint2Err, UlpSum)) distancePPointToPLineWithErr (inPoint, inPointErr) (inLine, inLineErr) | isIdealP inPoint = error "attempted to get the distance of an ideal point." @@ -176,17 +176,20 @@ distancePPointToPLineWithErr (inPoint, inPointErr) (inLine, inLineErr) (cPoint, cPointErr) = canonicalize inPoint -- | Determine if two points are on the same side of a given line. +-- Returns Nothing if one of the points is on the line. pPointsOnSameSideOfPLine :: (ProjectivePoint2 a, ProjectivePoint2 b, ProjectiveLine2 c) => a -> b -> c -> Maybe Bool pPointsOnSameSideOfPLine point1 point2 line - -- Return nothing if one of the points is on the line. - | abs foundP1 < realToFrac (ulpVal unlikeP1UlpSum) || - abs foundP2 < realToFrac (ulpVal unlikeP2UlpSum) = Nothing + | abs foundP1 < foundErr1 || + abs foundP2 < foundErr2 = Nothing | otherwise = Just $ signum foundP1 == signum foundP2 where + foundErr1, foundErr2 :: ℝ + foundErr1 = realToFrac $ ulpVal (eValOf mempty (getVal [GEZero 1, GEPlus 1, GEPlus 2] unlikeP1AddErr)) + + ulpVal (eValOf mempty (getVal [GEZero 1, GEPlus 1, GEPlus 2] unlikeP1MulErr)) + foundErr2 = realToFrac $ ulpVal (eValOf mempty (getVal [GEZero 1, GEPlus 1, GEPlus 2] unlikeP2AddErr)) + + ulpVal (eValOf mempty (getVal [GEZero 1, GEPlus 1, GEPlus 2] unlikeP2MulErr)) foundP1 = valOf 0 $ getVal [GEZero 1, GEPlus 1, GEPlus 2] unlikeP1 foundP2 = valOf 0 $ getVal [GEZero 1, GEPlus 1, GEPlus 2] unlikeP2 - unlikeP1UlpSum = sumErrVals unlikeP1MulErr <> sumErrVals unlikeP1AddErr - unlikeP2UlpSum = sumErrVals unlikeP2MulErr <> sumErrVals unlikeP2AddErr (GVec unlikeP1, (unlikeP1MulErr, unlikeP1AddErr)) = pv1 ⎤+ lv1 (GVec unlikeP2, (unlikeP2MulErr, unlikeP2AddErr)) = pv2 ⎤+ lv1 pv1 = vecOfP $ forceBasisOfP point1 @@ -194,7 +197,6 @@ pPointsOnSameSideOfPLine point1 point2 line lv1 = vecOfL $ forceBasisOfL line -- | A checker, to ensure two Projective Lines are going the same direction, and are parallel. --- FIXME: precision on inputs? sameDirection :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Bool sameDirection a b = res >= maxAngle where @@ -214,20 +216,24 @@ oppositeDirection a b = res <= minAngle (res, (_,_,resErr)) = angleBetween2PL a b -- | Find a projective point a given distance along a line perpendicularly bisecting the given line at a given point. -pPointOnPerpWithErr :: (ProjectiveLine2 a, ProjectivePoint2 b) => a -> b -> ℝ -> (PPoint2, UlpSum) -pPointOnPerpWithErr line ppoint d = (PPoint2 res, - ulpTotal) +-- FIXME: many operators here have error preserving forms, use those! +-- FIXME: we were skipping canonicalization, are canonicalization and normalization necessary? +pPointOnPerpWithErr :: (ProjectiveLine2 a, ProjectivePoint2 b) => a -> b -> ℝ -> (PPoint2, (PLine2Err, PPoint2Err, ([ErrVal],[ErrVal]), UlpSum)) +pPointOnPerpWithErr line point d = (res, resErr) where - res = motor•pvec•reverseGVec motor - (perpLine, (plMulErr,plAddErr))= lvec ⨅+ pvec - lvec = vecOfL $ forceBasisOfL npl - (npl,_) = normalizeL line - pvec = vecOfP $ forceBasisOfP ppoint + -- translate the input point along the perpendicular bisector. + res = PPoint2 $ motor•pvec•reverseGVec motor + resErr = (nLineErr, cPointErr, perpLineErrs, gaIErr) motor = addVecPairWithoutErr (perpLine • gaIScaled) (GVec [GVal 1 (singleton G0)]) - -- I, in this geometric algebra system. we multiply it times d/2, to shorten the number of multiples we have to do when creating the motor. - gaIScaled = GVec [GVal (d/2) (fromList [GEZero 1, GEPlus 1, GEPlus 2])] + where + -- I, in this geometric algebra system. we multiply it times d/2, to reduce the number of multiples we have to do when creating the motor. + gaIScaled = GVec [GVal (d/2) (fromList [GEZero 1, GEPlus 1, GEPlus 2])] gaIErr = UlpSum $ abs $ realToFrac $ doubleUlp $ d/2 - ulpTotal = sumErrVals plMulErr <> sumErrVals plAddErr <> gaIErr + (perpLine, perpLineErrs) = lvec ⨅+ pvec + lvec = vecOfL $ forceBasisOfL nLine + (nLine, nLineErr) = normalizeL line + pvec = vecOfP $ forceBasisOfP cPoint + (cPoint, cPointErr) = canonicalize point -- | Translate a point a given distance away from where it is, rotating it a given amount clockwise (in radians) around it's original location, with 0 degrees being aligned to the X axis. translateRotatePPoint2 :: (ProjectivePoint2 a) => a -> ℝ -> ℝ -> PPoint2 diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index 324bc52ea..538ff3202 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -1289,13 +1289,13 @@ prop_PPointOnPerpWithinErrRange x1 y1 rawX2 rawY2 rawD <> "ulpTotal1: " <> show ulpTotal1 <> "\n" <> "ulpTotal2: " <> show ulpTotal2 <> "\n" -- res should be d, in an ideal world. - (res1,(_,_,_,_,_,UlpSum res1Err)) = distancePPointToPLineWithErr (perp1, mempty) (pLine, mempty) - (res2,(_,_,_,_,_,UlpSum res2Err)) = distancePPointToPLineWithErr (perp2, mempty) (pLine, mempty) - (perp1, UlpSum ulpSumPerp1) = pPointOnPerpWithErr pLine (PPoint2 pPoint1) d - (perp2, UlpSum ulpSumPerp2) = pPointOnPerpWithErr pLine (PPoint2 pPoint2) d - (CPPoint2 pPoint1) = makePPoint2 x1 y1 - (CPPoint2 pPoint2) = makePPoint2 x2 y2 - (pLine, _) = join2PP (CPPoint2 pPoint1) (CPPoint2 pPoint2) + (res1,(_,_,_,_,_, UlpSum res1Err)) = distancePPointToPLineWithErr (perp1, mempty) (pLine, mempty) + (res2,(_,_,_,_,_, UlpSum res2Err)) = distancePPointToPLineWithErr (perp2, mempty) (pLine, mempty) + (perp1, (_,_,_, UlpSum ulpSumPerp1)) = pPointOnPerpWithErr pLine pPoint1 d + (perp2, (_,_,_, UlpSum ulpSumPerp2)) = pPointOnPerpWithErr pLine pPoint2 d + pPoint1 = makePPoint2 x1 y1 + pPoint2 = makePPoint2 x2 y2 + (pLine, _) = join2PP pPoint1 pPoint2 ulpTotal1 = res1Err + ulpSumPerp1 ulpTotal2 = res2Err + ulpSumPerp2 d :: ℝ From 54da1ec6d8d10835913d069f6e23f3b2fe3f6ec4 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Fri, 11 Nov 2022 21:55:21 +0000 Subject: [PATCH 069/206] break out perpLineAt. --- Graphics/Slicer/Math/PGA.hs | 27 +++++++++++++++++---------- 1 file changed, 17 insertions(+), 10 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 3e288664a..c1a68b0b8 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -161,18 +161,15 @@ distancePPointToPLineWithErr (inPoint, inPointErr) (inLine, inLineErr) where errSum = distanceErr <> fuzzinessOfP (inPoint, inPointErr) <> pLineErrAtPPoint (inLine, inLineErr) crossPoint <> pLineErrAtPPoint (PLine2 perpLine, perpLineNormErr) crossPoint -- | use distance2PP to find the distance between this crossover point, and the given point. - (res, (_, _, distanceErr)) = distance2PP (point, pointErr) (crossPoint, crossPointErr) + (res, (_, _, distanceErr)) = distance2PP (cPoint, pointErr) (crossPoint, crossPointErr) -- | Get the point where the perpendicular line and the input line meet. -- FIXME: how does perpLineErr effect the result of canonicalizedIntersectionOf2PL? (crossPoint, (_, perpLineNormErr, crossPointErr)) = fromJust $ canonicalizedIntersectionOf2PL nLine (PLine2 perpLine) - -- | Get a perpendicular line, crossing the input line closest to the given point. + -- | Get a perpendicular line, crossing the input line at the given point. -- FIXME: where should we put this in PLine2Err? - (perpLine, (plMulErr, plAddErr)) = lVec ⨅+ pVec - lVec = vecOfL $ forceBasisOfL nLine - (nLine, nLineErr) = normalizeL inLine + (PLine2 perpLine, (_, _, (plMulErr, plAddErr))) = perpLineAt nLine cPoint pointErr = inPointErr <> cPointErr - pVec = vecOfP point - point = forceBasisOfP cPoint + (nLine, nLineErr) = normalizeL inLine (cPoint, cPointErr) = canonicalize inPoint -- | Determine if two points are on the same side of a given line. @@ -222,14 +219,24 @@ pPointOnPerpWithErr :: (ProjectiveLine2 a, ProjectivePoint2 b) => a -> b -> ℝ pPointOnPerpWithErr line point d = (res, resErr) where -- translate the input point along the perpendicular bisector. - res = PPoint2 $ motor•pvec•reverseGVec motor + res = PPoint2 $ motor•pVec•reverseGVec motor resErr = (nLineErr, cPointErr, perpLineErrs, gaIErr) motor = addVecPairWithoutErr (perpLine • gaIScaled) (GVec [GVal 1 (singleton G0)]) where -- I, in this geometric algebra system. we multiply it times d/2, to reduce the number of multiples we have to do when creating the motor. gaIScaled = GVec [GVal (d/2) (fromList [GEZero 1, GEPlus 1, GEPlus 2])] - gaIErr = UlpSum $ abs $ realToFrac $ doubleUlp $ d/2 - (perpLine, perpLineErrs) = lvec ⨅+ pvec + gaIErr = UlpSum $ realToFrac $ doubleUlp $ realToFrac (realToFrac (abs d) / 2 :: Rounded 'TowardInf ℝ) + -- | Get a perpendicular line, crossing the input line at the given point. + -- FIXME: where should we put the error component of this in PLine2Err? + (PLine2 perpLine, (nLineErr, _, perpLineErrs)) = perpLineAt line cPoint + pVec = vecOfP $ forceBasisOfP cPoint + (cPoint, cPointErr) = canonicalize point + +perpLineAt :: (ProjectiveLine2 a, ProjectivePoint2 b) => a -> b -> (PLine2, (PLine2Err, PPoint2Err, ([ErrVal],[ErrVal]))) +perpLineAt line point = (PLine2 res, resErr) + where + (res, perpLineErrs) = lvec ⨅+ pvec + resErr = (nLineErr, cPointErr, perpLineErrs) lvec = vecOfL $ forceBasisOfL nLine (nLine, nLineErr) = normalizeL line pvec = vecOfP $ forceBasisOfP cPoint From 8eacd4ab0d3fabf0061f404dc39dc4450de94519 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Fri, 11 Nov 2022 23:33:15 +0000 Subject: [PATCH 070/206] better implementation of GaIScaledErr. --- Graphics/Slicer/Math/PGA.hs | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index c1a68b0b8..b42653280 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -203,7 +203,6 @@ sameDirection a b = res >= maxAngle (res, (_,_,resErr)) = angleBetween2PL a b -- | A checker, to ensure two Projective Lines are going the opposite direction, and are parallel. --- FIXME: precision on inputs? oppositeDirection :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Bool oppositeDirection a b = res <= minAngle where @@ -216,22 +215,22 @@ oppositeDirection a b = res <= minAngle -- FIXME: many operators here have error preserving forms, use those! -- FIXME: we were skipping canonicalization, are canonicalization and normalization necessary? pPointOnPerpWithErr :: (ProjectiveLine2 a, ProjectivePoint2 b) => a -> b -> ℝ -> (PPoint2, (PLine2Err, PPoint2Err, ([ErrVal],[ErrVal]), UlpSum)) -pPointOnPerpWithErr line point d = (res, resErr) +pPointOnPerpWithErr line point d = (PPoint2 res, resErr) where -- translate the input point along the perpendicular bisector. - res = PPoint2 $ motor•pVec•reverseGVec motor - resErr = (nLineErr, cPointErr, perpLineErrs, gaIErr) + res = motor•pVec•reverseGVec motor + resErr = (nLineErr, cPointErr, perpLineErrs, gaIScaledErr) motor = addVecPairWithoutErr (perpLine • gaIScaled) (GVec [GVal 1 (singleton G0)]) - where - -- I, in this geometric algebra system. we multiply it times d/2, to reduce the number of multiples we have to do when creating the motor. - gaIScaled = GVec [GVal (d/2) (fromList [GEZero 1, GEPlus 1, GEPlus 2])] - gaIErr = UlpSum $ realToFrac $ doubleUlp $ realToFrac (realToFrac (abs d) / 2 :: Rounded 'TowardInf ℝ) + -- I, in this geometric algebra system. we multiply it times d/2, to reduce the number of multiples we have to do when creating the motor. + gaIScaled = GVec [GVal (d/2) (fromList [GEZero 1, GEPlus 1, GEPlus 2])] + gaIScaledErr = UlpSum $ realToFrac $ doubleUlp $ realToFrac (realToFrac (abs d) / 2 :: Rounded 'TowardInf ℝ) -- | Get a perpendicular line, crossing the input line at the given point. -- FIXME: where should we put the error component of this in PLine2Err? (PLine2 perpLine, (nLineErr, _, perpLineErrs)) = perpLineAt line cPoint pVec = vecOfP $ forceBasisOfP cPoint (cPoint, cPointErr) = canonicalize point +-- Find a projective line crossing the given projective line at the given projective point at a 90 degree angle. perpLineAt :: (ProjectiveLine2 a, ProjectivePoint2 b) => a -> b -> (PLine2, (PLine2Err, PPoint2Err, ([ErrVal],[ErrVal]))) perpLineAt line point = (PLine2 res, resErr) where From cf0cb3beed9abab2008f3f17f90e1cf6b254c881 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 12 Nov 2022 16:00:21 +0000 Subject: [PATCH 071/206] rename translateRotatePPoint2 to translateRotatePPoint2WithErr. --- Graphics/Slicer/Math/Ganja.hs | 12 ++++++------ Graphics/Slicer/Math/PGA.hs | 11 ++++++----- tests/Math/PGA.hs | 4 ++-- 3 files changed, 14 insertions(+), 13 deletions(-) diff --git a/Graphics/Slicer/Math/Ganja.hs b/Graphics/Slicer/Math/Ganja.hs index 3ad64632c..d609d5c6c 100644 --- a/Graphics/Slicer/Math/Ganja.hs +++ b/Graphics/Slicer/Math/Ganja.hs @@ -114,7 +114,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (GNum(GEPlus, GEZero), GVec(GVec), import Graphics.Slicer.Math.Lossy (eToPLine2, join2PPoint2, normalizePLine2, pPointBetweenPPoints, pToEPoint2) -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), PLine2(PLine2), PPoint2(PPoint2), PLine2Err, eToPL, eToPPoint2, flipL, normalizeL, translateRotatePPoint2, outOf, pPointOf, NPLine2(NPLine2)) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), PLine2(PLine2), PPoint2(PPoint2), PLine2Err, eToPL, eToPPoint2, flipL, normalizeL, translateRotatePPoint2WithErr, outOf, pPointOf, NPLine2(NPLine2)) import Graphics.Slicer.Math.Skeleton.Concave (makeENode, getOutsideArc) @@ -629,7 +629,7 @@ randomStarPoly centerX centerY radianDistPairs = fromMaybe dumpError $ maybeFlip where contour = makePointContour points points = pToEPoint2 <$> pointsAroundCenter - pointsAroundCenter = (\(distanceFromPoint, angle) -> translateRotatePPoint2 centerPPoint (coerce distanceFromPoint) (coerce angle)) <$> radianDistPairs + pointsAroundCenter = (\(distanceFromPoint, angle) -> translateRotatePPoint2WithErr centerPPoint (coerce distanceFromPoint) (coerce angle)) <$> radianDistPairs centerPPoint = eToPPoint2 $ Point2 (centerX, centerY) dumpError = error $ "failed to flip a contour:" <> dumpGanjas [toGanja contour, toGanja (Point2 (centerX, centerY)), toGanja outsidePLine] <> "\n" where @@ -644,8 +644,8 @@ randomENode x y d1 rawR1 d2 rawR2 = makeENode p1 intersectionPoint p2 r1 = rawR1 / 2 r2 = r1 + (rawR2 / 2) intersectionPoint = Point2 (x,y) - pp1 = translateRotatePPoint2 intersectionPPoint (coerce d1) (coerce r1) - pp2 = translateRotatePPoint2 intersectionPPoint (coerce d2) (coerce r2) + pp1 = translateRotatePPoint2WithErr intersectionPPoint (coerce d1) (coerce r1) + pp2 = translateRotatePPoint2WithErr intersectionPPoint (coerce d2) (coerce r2) p1 = pToEPoint2 pp1 p2 = pToEPoint2 pp2 intersectionPPoint = eToPPoint2 intersectionPoint @@ -659,8 +659,8 @@ randomINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 = makeINode [maybeFlippedpl1,m pl2 = (\(NPLine2 a,b) -> (PLine2 a,b)) $ normalizeL $ flipL $ eToPLine2 $ getLastLineSeg eNode intersectionPPoint = pPointOf eNode eNode = randomENode x y d1 rawR1 d2 rawR2 - pp1 = translateRotatePPoint2 intersectionPPoint (coerce d1) (coerce r1) - pp2 = translateRotatePPoint2 intersectionPPoint (coerce d2) (coerce r2) + pp1 = translateRotatePPoint2WithErr intersectionPPoint (coerce d1) (coerce r1) + pp2 = translateRotatePPoint2WithErr intersectionPPoint (coerce d2) (coerce r2) maybeFlippedpl1 = (if flipIn1 then flipL (fst pl1) else (fst pl1), snd pl1) maybeFlippedpl2 = (if flipIn2 then flipL (fst pl2) else (fst pl2), snd pl2) bisector1 = normalizeL outsideRes diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index b42653280..01d427246 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -62,7 +62,7 @@ module Graphics.Slicer.Math.PGA( pPointOnPerpWithErr, pPointsOnSameSideOfPLine, plinesIntersectIn, - translateRotatePPoint2, + translateRotatePPoint2WithErr, ) where import Prelude (Bool, Eq((==),(/=)), Monoid(mempty), Semigroup((<>)), Show(show), ($), (*), (-), (>=), (&&), (<$>), otherwise, signum, snd, (>), (<=), (+), negate, (/), (||), (<), abs, error, sin, cos, realToFrac, fst, sum, (.)) @@ -225,7 +225,7 @@ pPointOnPerpWithErr line point d = (PPoint2 res, resErr) gaIScaled = GVec [GVal (d/2) (fromList [GEZero 1, GEPlus 1, GEPlus 2])] gaIScaledErr = UlpSum $ realToFrac $ doubleUlp $ realToFrac (realToFrac (abs d) / 2 :: Rounded 'TowardInf ℝ) -- | Get a perpendicular line, crossing the input line at the given point. - -- FIXME: where should we put the error component of this in PLine2Err? + -- FIXME: where should we put this in the error quotent of PLine2Err? (PLine2 perpLine, (nLineErr, _, perpLineErrs)) = perpLineAt line cPoint pVec = vecOfP $ forceBasisOfP cPoint (cPoint, cPointErr) = canonicalize point @@ -242,9 +242,10 @@ perpLineAt line point = (PLine2 res, resErr) (cPoint, cPointErr) = canonicalize point -- | Translate a point a given distance away from where it is, rotating it a given amount clockwise (in radians) around it's original location, with 0 degrees being aligned to the X axis. -translateRotatePPoint2 :: (ProjectivePoint2 a) => a -> ℝ -> ℝ -> PPoint2 -translateRotatePPoint2 ppoint d rotation = PPoint2 $ translator•pvec•reverseGVec translator +translateRotatePPoint2WithErr :: (ProjectivePoint2 a) => a -> ℝ -> ℝ -> PPoint2 +translateRotatePPoint2WithErr ppoint d rotation = PPoint2 res where + res = translator•pvec•reverseGVec translator pvec = vecOfP ppoint xLineThroughPPoint2 = (pvec ⨅ xLineVec) • pvec where @@ -254,7 +255,7 @@ translateRotatePPoint2 ppoint d rotation = PPoint2 $ translator•pvec•reverse rotator = addVecPairWithoutErr (fst $ mulScalarVecWithErr (sin $ rotation/2) pvec) (GVec [GVal (cos $ rotation/2) (singleton G0)]) translator = addVecPairWithoutErr (angledLineThroughPPoint2 • gaIScaled) (GVec [GVal 1 (singleton G0)]) where - -- I, in this geometric algebra system. we multiply it times d/2, to shorten the number of multiples we have to do when creating the motor. + -- I, in this geometric algebra system. we multiply it times d/2, to reduce the number of multiples we have to do when creating the motor. gaIScaled = GVec [GVal (d/2) (fromList [GEZero 1, GEPlus 1, GEPlus 2])] ---------------------------------------------------------- diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index 538ff3202..89cdfa8e9 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -59,7 +59,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(GEZero, GEPlu import Graphics.Slicer.Math.Lossy (angleBetween, canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenPLines, distancePPointToPLine, eToCPPoint2, eToPLine2, getFirstArc, join2PPoint2, normalizePLine2, pPointOnPerp) -- Our 2D Projective Geometric Algebra library. -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PLine2Err(PLine2Err), canonicalize, distance2PP, distancePPointToPLineWithErr, eToPL, eToPPoint2, interpolate2PP, intersect2PL, translateL, translateRotatePPoint2, angleBetween2PL, flipL, join2PP, makePPoint2, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, distancePPointToPLineWithErr, errOfOut, pPointOnPerpWithErr, outOf, pPointOf, outputIntersectsLineSeg) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PLine2Err(PLine2Err), canonicalize, distance2PP, distancePPointToPLineWithErr, eToPL, eToPPoint2, interpolate2PP, intersect2PL, translateL, translateRotatePPoint2WithErr, angleBetween2PL, flipL, join2PP, makePPoint2, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, distancePPointToPLineWithErr, errOfOut, pPointOnPerpWithErr, outOf, pPointOf, outputIntersectsLineSeg) -- The primitives of our PGA only library, and error estimation code. @@ -1345,7 +1345,7 @@ prop_eNodeAwayFromIntersection2 x y d1 rawR1 d2 rawR2 = l2TowardIntersection --> eNode = randomENode x y d1 rawR1 d2 rawR2 prop_translateRotateMoves :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> Expectation -prop_translateRotateMoves x y rawD rawR = distanceBetweenPPoints (canonicalizePPoint2 $ translateRotatePPoint2 pPoint d r) cPPoint /= 0 --> True +prop_translateRotateMoves x y rawD rawR = distanceBetweenPPoints (canonicalizePPoint2 $ translateRotatePPoint2WithErr pPoint d r) cPPoint /= 0 --> True where pPoint = eToPPoint2 $ Point2 (x,y) cPPoint = makePPoint2 x y From 8bc1c7949504ac69b1da94c9c68145d8a6d36d8e Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 12 Nov 2022 16:17:13 +0000 Subject: [PATCH 072/206] rename translateRotatePPoint2 to translateRotatePPoint2WithErr. --- Graphics/Slicer/Math/PGA.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 01d427246..4d1ab4921 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -243,13 +243,12 @@ perpLineAt line point = (PLine2 res, resErr) -- | Translate a point a given distance away from where it is, rotating it a given amount clockwise (in radians) around it's original location, with 0 degrees being aligned to the X axis. translateRotatePPoint2WithErr :: (ProjectivePoint2 a) => a -> ℝ -> ℝ -> PPoint2 -translateRotatePPoint2WithErr ppoint d rotation = PPoint2 res +translateRotatePPoint2WithErr point d rotation = PPoint2 res where - res = translator•pvec•reverseGVec translator - pvec = vecOfP ppoint - xLineThroughPPoint2 = (pvec ⨅ xLineVec) • pvec + res = translator•pVec•reverseGVec translator + xLineThroughPPoint2 = (pvec ⨅ xLineVec) • pVec where - xLineVec = vecOfL $ forceBasisOfL $ fst $ eToPL (LineSeg (Point2 (0,0)) (Point2 (1,0))) + xLineVec = vecOfL $ forceBasisOfL $ fst $ eToPL $ makeLineSeg (Point2 (0,0)) (Point2 (1,0)) angledLineThroughPPoint2 = vecOfL $ forceBasisOfL $ PLine2 $ rotator•xLineThroughPPoint2•reverseGVec rotator where rotator = addVecPairWithoutErr (fst $ mulScalarVecWithErr (sin $ rotation/2) pvec) (GVec [GVal (cos $ rotation/2) (singleton G0)]) @@ -257,6 +256,7 @@ translateRotatePPoint2WithErr ppoint d rotation = PPoint2 res where -- I, in this geometric algebra system. we multiply it times d/2, to reduce the number of multiples we have to do when creating the motor. gaIScaled = GVec [GVal (d/2) (fromList [GEZero 1, GEPlus 1, GEPlus 2])] + pVec = vecOfP point ---------------------------------------------------------- -------------- Euclidian Mixed Interface ----------------- From f5cc7385f3044a39ad898a8cc2d256c8663c37fd Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 12 Nov 2022 17:59:19 +0000 Subject: [PATCH 073/206] make translateRotatePPoint2WithErr return an error quotent. --- Graphics/Slicer/Math/Ganja.hs | 10 +++++----- Graphics/Slicer/Math/PGA.hs | 13 +++++++------ tests/Math/PGA.hs | 2 +- 3 files changed, 13 insertions(+), 12 deletions(-) diff --git a/Graphics/Slicer/Math/Ganja.hs b/Graphics/Slicer/Math/Ganja.hs index d609d5c6c..362cfec00 100644 --- a/Graphics/Slicer/Math/Ganja.hs +++ b/Graphics/Slicer/Math/Ganja.hs @@ -629,7 +629,7 @@ randomStarPoly centerX centerY radianDistPairs = fromMaybe dumpError $ maybeFlip where contour = makePointContour points points = pToEPoint2 <$> pointsAroundCenter - pointsAroundCenter = (\(distanceFromPoint, angle) -> translateRotatePPoint2WithErr centerPPoint (coerce distanceFromPoint) (coerce angle)) <$> radianDistPairs + pointsAroundCenter = (\(distanceFromPoint, angle) -> fst $ translateRotatePPoint2WithErr centerPPoint (coerce distanceFromPoint) (coerce angle)) <$> radianDistPairs centerPPoint = eToPPoint2 $ Point2 (centerX, centerY) dumpError = error $ "failed to flip a contour:" <> dumpGanjas [toGanja contour, toGanja (Point2 (centerX, centerY)), toGanja outsidePLine] <> "\n" where @@ -644,8 +644,8 @@ randomENode x y d1 rawR1 d2 rawR2 = makeENode p1 intersectionPoint p2 r1 = rawR1 / 2 r2 = r1 + (rawR2 / 2) intersectionPoint = Point2 (x,y) - pp1 = translateRotatePPoint2WithErr intersectionPPoint (coerce d1) (coerce r1) - pp2 = translateRotatePPoint2WithErr intersectionPPoint (coerce d2) (coerce r2) + pp1 = fst $ translateRotatePPoint2WithErr intersectionPPoint (coerce d1) (coerce r1) + pp2 = fst $ translateRotatePPoint2WithErr intersectionPPoint (coerce d2) (coerce r2) p1 = pToEPoint2 pp1 p2 = pToEPoint2 pp2 intersectionPPoint = eToPPoint2 intersectionPoint @@ -659,8 +659,8 @@ randomINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 = makeINode [maybeFlippedpl1,m pl2 = (\(NPLine2 a,b) -> (PLine2 a,b)) $ normalizeL $ flipL $ eToPLine2 $ getLastLineSeg eNode intersectionPPoint = pPointOf eNode eNode = randomENode x y d1 rawR1 d2 rawR2 - pp1 = translateRotatePPoint2WithErr intersectionPPoint (coerce d1) (coerce r1) - pp2 = translateRotatePPoint2WithErr intersectionPPoint (coerce d2) (coerce r2) + pp1 = fst $ translateRotatePPoint2WithErr intersectionPPoint (coerce d1) (coerce r1) + pp2 = fst $ translateRotatePPoint2WithErr intersectionPPoint (coerce d2) (coerce r2) maybeFlippedpl1 = (if flipIn1 then flipL (fst pl1) else (fst pl1), snd pl1) maybeFlippedpl2 = (if flipIn2 then flipL (fst pl2) else (fst pl2), snd pl2) bisector1 = normalizeL outsideRes diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 4d1ab4921..ddcd64135 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -62,7 +62,7 @@ module Graphics.Slicer.Math.PGA( pPointOnPerpWithErr, pPointsOnSameSideOfPLine, plinesIntersectIn, - translateRotatePPoint2WithErr, + translateRotatePPoint2WithErr ) where import Prelude (Bool, Eq((==),(/=)), Monoid(mempty), Semigroup((<>)), Show(show), ($), (*), (-), (>=), (&&), (<$>), otherwise, signum, snd, (>), (<=), (+), negate, (/), (||), (<), abs, error, sin, cos, realToFrac, fst, sum, (.)) @@ -89,7 +89,7 @@ import Graphics.Slicer.Math.Definitions (Point2(Point2), LineSeg(LineSeg), addPo import Graphics.Slicer.Math.GeometricAlgebra (ErrVal, GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎤+), (⨅), (⨅+), (•), addValWithoutErr, addVecPairWithoutErr, eValOf, getVal, mulScalarVecWithErr, ulpVal, valOf) -import Graphics.Slicer.Math.Line (combineLineSegs) +import Graphics.Slicer.Math.Line (combineLineSegs, makeLineSeg) import Graphics.Slicer.Math.PGAPrimitives(Arcable(errOfOut, hasArc, outAndErrOf, outOf), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(angleBetween2PL, angleCosBetween2PL, distance2PL, flipL, forceBasisOfL, intersect2PL, normalizeL, translateL, vecOfL), ProjectivePoint2(canonicalize, distance2PP, forceBasisOfP, fuzzinessOfP, idealNormOfP, interpolate2PP, isIdealP, join2PP, pToEP, vecOfP), canonicalizedIntersectionOf2PL, pLineErrAtPPoint, xIntercept, yIntercept) @@ -242,16 +242,17 @@ perpLineAt line point = (PLine2 res, resErr) (cPoint, cPointErr) = canonicalize point -- | Translate a point a given distance away from where it is, rotating it a given amount clockwise (in radians) around it's original location, with 0 degrees being aligned to the X axis. -translateRotatePPoint2WithErr :: (ProjectivePoint2 a) => a -> ℝ -> ℝ -> PPoint2 -translateRotatePPoint2WithErr point d rotation = PPoint2 res +translateRotatePPoint2WithErr :: (ProjectivePoint2 a) => a -> ℝ -> ℝ -> (PPoint2, [ErrVal]) +translateRotatePPoint2WithErr point d rotation = (PPoint2 res, scaledPVecErr) where res = translator•pVec•reverseGVec translator - xLineThroughPPoint2 = (pvec ⨅ xLineVec) • pVec + xLineThroughPPoint2 = (pVec ⨅ xLineVec) • pVec where xLineVec = vecOfL $ forceBasisOfL $ fst $ eToPL $ makeLineSeg (Point2 (0,0)) (Point2 (1,0)) angledLineThroughPPoint2 = vecOfL $ forceBasisOfL $ PLine2 $ rotator•xLineThroughPPoint2•reverseGVec rotator where - rotator = addVecPairWithoutErr (fst $ mulScalarVecWithErr (sin $ rotation/2) pvec) (GVec [GVal (cos $ rotation/2) (singleton G0)]) + rotator = addVecPairWithoutErr scaledPVec (GVec [GVal (cos $ rotation/2) (singleton G0)]) + (scaledPVec, scaledPVecErr) = mulScalarVecWithErr (sin $ rotation/2) pVec translator = addVecPairWithoutErr (angledLineThroughPPoint2 • gaIScaled) (GVec [GVal 1 (singleton G0)]) where -- I, in this geometric algebra system. we multiply it times d/2, to reduce the number of multiples we have to do when creating the motor. diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index 89cdfa8e9..1fde54c3b 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -1345,7 +1345,7 @@ prop_eNodeAwayFromIntersection2 x y d1 rawR1 d2 rawR2 = l2TowardIntersection --> eNode = randomENode x y d1 rawR1 d2 rawR2 prop_translateRotateMoves :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> Expectation -prop_translateRotateMoves x y rawD rawR = distanceBetweenPPoints (canonicalizePPoint2 $ translateRotatePPoint2WithErr pPoint d r) cPPoint /= 0 --> True +prop_translateRotateMoves x y rawD rawR = distanceBetweenPPoints (fst $ translateRotatePPoint2WithErr pPoint d r) cPPoint /= 0 --> True where pPoint = eToPPoint2 $ Point2 (x,y) cPPoint = makePPoint2 x y From 5da1dd52f8f882577fb974e06d314bceded5e6fc Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 13 Nov 2022 11:26:53 +0000 Subject: [PATCH 074/206] completely rebuild translateRotatePPoint2WithErr. actually return a lot more error, comment everything, and some minor optimizations. --- Graphics/Slicer/Math/PGA.hs | 35 ++++++++++++++++++++--------------- 1 file changed, 20 insertions(+), 15 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index ddcd64135..58bfc2de2 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -65,7 +65,7 @@ module Graphics.Slicer.Math.PGA( translateRotatePPoint2WithErr ) where -import Prelude (Bool, Eq((==),(/=)), Monoid(mempty), Semigroup((<>)), Show(show), ($), (*), (-), (>=), (&&), (<$>), otherwise, signum, snd, (>), (<=), (+), negate, (/), (||), (<), abs, error, sin, cos, realToFrac, fst, sum, (.)) +import Prelude (Bool, Eq((==),(/=)), Monoid(mempty), Semigroup((<>)), Show(show), ($), (*), (-), (>=), (&&), (<$>), otherwise, signum, snd, (>), (<=), (+), negate, (/), (||), (<), abs, error, sin, cos, realToFrac, sum, (.)) import Data.Bits.Floating.Ulp (doubleUlp) @@ -87,7 +87,7 @@ import Graphics.Slicer.Definitions (ℝ) import Graphics.Slicer.Math.Definitions (Point2(Point2), LineSeg(LineSeg), addPoints, startPoint, endPoint, distance) -import Graphics.Slicer.Math.GeometricAlgebra (ErrVal, GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎤+), (⨅), (⨅+), (•), addValWithoutErr, addVecPairWithoutErr, eValOf, getVal, mulScalarVecWithErr, ulpVal, valOf) +import Graphics.Slicer.Math.GeometricAlgebra (ErrVal, GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎤+), (⨅+), (•), addValWithoutErr, addVecPairWithoutErr, eValOf, getVal, mulScalarVecWithErr, ulpVal, valOf) import Graphics.Slicer.Math.Line (combineLineSegs, makeLineSeg) @@ -242,21 +242,26 @@ perpLineAt line point = (PLine2 res, resErr) (cPoint, cPointErr) = canonicalize point -- | Translate a point a given distance away from where it is, rotating it a given amount clockwise (in radians) around it's original location, with 0 degrees being aligned to the X axis. -translateRotatePPoint2WithErr :: (ProjectivePoint2 a) => a -> ℝ -> ℝ -> (PPoint2, [ErrVal]) -translateRotatePPoint2WithErr point d rotation = (PPoint2 res, scaledPVecErr) +translateRotatePPoint2WithErr :: (ProjectivePoint2 a) => a -> ℝ -> ℝ -> (PPoint2, (UlpSum, UlpSum, [ErrVal], PLine2Err, PLine2Err, PPoint2Err, ([ErrVal],[ErrVal]))) +translateRotatePPoint2WithErr point d rotation = (res, resErr) where - res = translator•pVec•reverseGVec translator - xLineThroughPPoint2 = (pVec ⨅ xLineVec) • pVec - where - xLineVec = vecOfL $ forceBasisOfL $ fst $ eToPL $ makeLineSeg (Point2 (0,0)) (Point2 (1,0)) - angledLineThroughPPoint2 = vecOfL $ forceBasisOfL $ PLine2 $ rotator•xLineThroughPPoint2•reverseGVec rotator - where - rotator = addVecPairWithoutErr scaledPVec (GVec [GVal (cos $ rotation/2) (singleton G0)]) + res = PPoint2 $ translator•pVec•reverseGVec translator + resErr = (gaIScaledErr, rotationErr, scaledPVecErr, yLineErr, nYLineErr, cPointErr, xLineErr) + -- Our translation motor, which translates the provided distance along the angled line. + translator = addVecPairWithoutErr (gaIScaled • angledLineThroughPPoint2) (GVec [GVal 1 (singleton G0)]) + -- A line crossing the provided point, at the provided angle. + angledLineThroughPPoint2 = rotator•(vecOfL xLineThroughPPoint2)•reverseGVec rotator + -- A line along the X axis, crossing the provided point. + (xLineThroughPPoint2, (nYLineErr, cPointErr, xLineErr)) = perpLineAt yLine point + -- A line along the Y axis, crossing the origin. + (yLine, yLineErr) = eToPL $ makeLineSeg (Point2 (0,0)) (Point2 (0,1)) + -- Our rotation motor, which rotates the provided angle around the provided point, in the clockwise direction. + rotator = addVecPairWithoutErr scaledPVec (GVec [GVal (cos $ rotation/2) (singleton G0)]) (scaledPVec, scaledPVecErr) = mulScalarVecWithErr (sin $ rotation/2) pVec - translator = addVecPairWithoutErr (angledLineThroughPPoint2 • gaIScaled) (GVec [GVal 1 (singleton G0)]) - where - -- I, in this geometric algebra system. we multiply it times d/2, to reduce the number of multiples we have to do when creating the motor. - gaIScaled = GVec [GVal (d/2) (fromList [GEZero 1, GEPlus 1, GEPlus 2])] + rotationErr = UlpSum $ realToFrac $ doubleUlp $ realToFrac (realToFrac rotation / 2 :: Rounded 'TowardInf ℝ) + -- I, in this geometric algebra system. We multiply it times -d/2, to reduce the number of multiples we have to do when creating the motor. + gaIScaled = GVec [GVal (-d/2) (fromList [GEZero 1, GEPlus 1, GEPlus 2])] + gaIScaledErr = UlpSum $ realToFrac $ doubleUlp $ realToFrac (realToFrac (abs d) / 2 :: Rounded 'TowardInf ℝ) pVec = vecOfP point ---------------------------------------------------------- From 7e0e838fcf9f2d769e734063a2ce6c1e84419d61 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 13 Nov 2022 22:29:49 +0000 Subject: [PATCH 075/206] remove intersectsWith, ulpOfPLine2, ulpOfLineSeg, and stop pretending line segments have an error quotent. --- Graphics/Slicer/Math/Intersections.hs | 7 +-- Graphics/Slicer/Math/PGA.hs | 77 ++++++++------------------- tests/Math/PGA.hs | 16 +++--- 3 files changed, 34 insertions(+), 66 deletions(-) diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index d52523c21..8c6c7f550 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -36,7 +36,7 @@ import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, mapWithNeighb import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum)) -import Graphics.Slicer.Math.PGA (CPPoint2, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), Intersection(HitEndPoint, HitStartPoint, NoIntersection), PLine2, PPoint2Err, intersectsWith, distance2PL, outputIntersectsLineSeg, plinesIntersectIn, pToEP) +import Graphics.Slicer.Math.PGA (CPPoint2, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), Intersection(HitEndPoint, HitStartPoint, NoIntersection), PLine2, PPoint2Err, distance2PL, intersectsWithErr, outputIntersectsLineSeg, plinesIntersectIn, pToEP) import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle)) @@ -85,17 +85,18 @@ contourIntersectionCount :: Contour -> (Point2, Point2) -> Int contourIntersectionCount contour (start, end) = len $ getIntersections contour (start, end) where getIntersections :: Contour -> (Point2, Point2) -> Slist (LineSeg, Either Point2 CPPoint2) - getIntersections c (pt1, pt2) = slist $ catMaybes $ mapWithNeighbors filterIntersections $ openCircuit $ zip (lineSegsOfContour contour) $ intersectsWith (Left $ makeLineSeg pt1 pt2) . Left <$> lineSegsOfContour c + getIntersections c (pt1, pt2) = slist $ catMaybes $ mapWithNeighbors filterIntersections $ openCircuit $ zip (lineSegsOfContour contour) $ intersectsWithErr (Left $ makeLineSeg pt1 pt2) . Left <$> lineSegsOfContour c where openCircuit v = Just <$> v -- | Get the intersections between a PLine2 and a contour as a series of points. always returns an even number of intersections. +-- FIXME: accept error on this first pLine! getPLine2Intersections :: PLine2 -> Contour -> [Point2] getPLine2Intersections pLine c | odd $ length res = error $ "odd number of transitions: " <> show (length res) <> "\n" <> show c <> "\n" <> show pLine <> "\n" <> show res <> "\n" | otherwise = res where - res = getPoints $ catMaybes $ mapWithNeighbors filterIntersections $ openCircuit $ zip (lineSegsOfContour c) $ intersectsWith (Right pLine) . Left <$> lineSegsOfContour c + res = getPoints $ catMaybes $ mapWithNeighbors filterIntersections $ openCircuit $ zip (lineSegsOfContour c) $ intersectsWithErr (Right (pLine, mempty)) . Left <$> lineSegsOfContour c openCircuit v = Just <$> v getPoints :: [(LineSeg, Either Point2 CPPoint2)] -> [Point2] getPoints vs = getPoint <$> vs diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 58bfc2de2..2a7b17837 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -54,7 +54,6 @@ module Graphics.Slicer.Math.PGA( distancePPointToPLineWithErr, eToPL, eToPPoint2, - intersectsWith, intersectsWithErr, makePPoint2, outputIntersectsLineSeg, @@ -65,7 +64,7 @@ module Graphics.Slicer.Math.PGA( translateRotatePPoint2WithErr ) where -import Prelude (Bool, Eq((==),(/=)), Monoid(mempty), Semigroup((<>)), Show(show), ($), (*), (-), (>=), (&&), (<$>), otherwise, signum, snd, (>), (<=), (+), negate, (/), (||), (<), abs, error, sin, cos, realToFrac, sum, (.)) +import Prelude (Bool, Eq((==),(/=)), Monoid(mempty), Semigroup((<>)), Show(show), ($), (*), (-), (>=), (&&), (<$>), otherwise, signum, snd, (>), (<=), (+), negate, (/), (||), (<), abs, error, sin, cos, realToFrac) import Data.Bits.Floating.Ulp (doubleUlp) @@ -75,7 +74,7 @@ import Data.List (foldl') import Data.List.Ordered (foldt) -import Data.Maybe (Maybe(Just, Nothing), catMaybes, fromJust, fromMaybe, isNothing, maybeToList) +import Data.Maybe (Maybe(Just, Nothing), fromJust, fromMaybe, isNothing, maybeToList) import Data.Set (singleton, fromList) @@ -275,30 +274,17 @@ data Intersection = | HitEndPoint !LineSeg deriving Show --- | A type alias, for cases where either input is acceptable. -type SegOrPLine2 = Either LineSeg PLine2 - -- FIXME: as long as this is required, we're not accounting for ULP correctly everywhere. ulpMultiplier :: Rounded 'TowardInf ℝ ulpMultiplier = 570 --- | Check if/where lines/line segments intersect. --- entry point usable for all intersection needs. --- FIXME: take UlpSums here. -intersectsWith :: SegOrPLine2 -> SegOrPLine2 -> Either Intersection PIntersection -intersectsWith (Left l1) (Left l2) = lineSegIntersectsLineSeg (l1, ulpOfLineSeg l1) (l2, ulpOfLineSeg l2) -intersectsWith (Right pl1) (Right pl2) = Right $ plinesIntersectIn (pl1, mempty) (pl2, mempty) -intersectsWith (Left l1) (Right pl1) = pLineIntersectsLineSeg (pl1, ulpOfPLine2 pl1) (l1, ulpOfLineSeg l1) 0 -intersectsWith (Right pl1) (Left l1) = pLineIntersectsLineSeg (pl1, ulpOfPLine2 pl1) (l1, ulpOfLineSeg l1) 0 - -- | Check if/where the arc of a motorcycle, inode, or enode intersect a line segment. outputIntersectsLineSeg :: (Show a, Arcable a) => a -> LineSeg -> Either Intersection PIntersection outputIntersectsLineSeg source l1 -- handle the case where a segment that is an input to the node is checked against. | isNothing canonicalizedIntersection = Right $ plinesIntersectIn (pl1, pl1Err) (pl2, pl2Err) - | otherwise = pLineIntersectsLineSeg (pl1, pl1Ulp) (l1, pl2Ulp) 1 + | otherwise = pLineIntersectsLineSeg (pl1, pl1Ulp) l1 1 where - pl2Ulp = snd (fromMaybe (Right 0,mempty) $ xIntercept (pl2,pl2Err)) <> snd (fromMaybe (Right 0,mempty) $ yIntercept (pl2,pl2Err)) (pl2, pl2Err) = eToPL l1 pl1Ulp = snd (fromMaybe (Right 0,mempty) $ xIntercept (pl1,pl1Err)) <> snd (fromMaybe (Right 0,mempty) $ yIntercept (pl1,pl1Err)) (pl1, pl1Err) @@ -309,19 +295,19 @@ outputIntersectsLineSeg source l1 canonicalizedIntersection = canonicalizedIntersectionOf2PL pl1 pl2 -- | A type alias, for cases where either input is acceptable. -type SegOrPLine2WithErr = Either (LineSeg, UlpSum) (PLine2, UlpSum) +type SegOrPLine2WithErr = Either LineSeg (PLine2, UlpSum) -- entry point usable for all intersection needs, complete with passed in error values. intersectsWithErr :: SegOrPLine2WithErr -> SegOrPLine2WithErr -> Either Intersection PIntersection intersectsWithErr (Left l1) (Left l2) = lineSegIntersectsLineSeg l1 l2 intersectsWithErr (Right (pl1,_)) (Right (pl2,_)) = Right $ plinesIntersectIn (pl1,mempty) (pl2,mempty) -intersectsWithErr (Left l1@(rawL1,_)) (Right pl1@(rawPL1, _)) = pLineIntersectsLineSeg pl1 l1 ulpScale +intersectsWithErr (Left l1@(rawL1)) (Right pl1@(rawPL1, _)) = pLineIntersectsLineSeg pl1 l1 ulpScale where ulpScale :: ℝ ulpScale = realToFrac $ ulpMultiplier * (abs (realToFrac angle) + angleErr) (angle, (_,_, UlpSum angleErr)) = angleBetween2PL rawPL1 pl2 (pl2, _) = eToPL rawL1 -intersectsWithErr (Right pl1@(rawPL1, _)) (Left l1@(rawL1,_)) = pLineIntersectsLineSeg pl1 l1 ulpScale +intersectsWithErr (Right pl1@(rawPL1, _)) (Left l1@(rawL1)) = pLineIntersectsLineSeg pl1 l1 ulpScale where ulpScale :: ℝ ulpScale = realToFrac $ ulpMultiplier * (abs (realToFrac angle) + angleErr) @@ -329,13 +315,13 @@ intersectsWithErr (Right pl1@(rawPL1, _)) (Left l1@(rawL1,_)) = pLineIntersectsL (pl2, _) = eToPL rawL1 -- | Check if/where a line segment and a PLine intersect. -pLineIntersectsLineSeg :: (PLine2, UlpSum) -> (LineSeg, UlpSum) -> ℝ -> Either Intersection PIntersection -pLineIntersectsLineSeg (pl1, UlpSum pl1Err) (l1, UlpSum l1Err) ulpScale +pLineIntersectsLineSeg :: (PLine2, UlpSum) -> LineSeg -> ℝ -> Either Intersection PIntersection +pLineIntersectsLineSeg (pl1, UlpSum pl1Err) l1 ulpScale | plinesIntersectIn (pl1,mempty) (pl2,pl2Err) == PParallel = Right PParallel | plinesIntersectIn (pl1,mempty) (pl2,pl2Err) == PAntiParallel = Right PAntiParallel | plinesIntersectIn (pl1,mempty) (pl2,pl2Err) == PCollinear = Right PCollinear | plinesIntersectIn (pl1,mempty) (pl2,pl2Err) == PAntiCollinear = Right PAntiCollinear - | hasRawIntersection && distance (startPoint l1) (endPoint l1) < realToFrac (startDistanceErr+endDistanceErr+ulpTotal) = error $ "cannot resolve endpoints of segment: " <> show l1 <> ".\nulpTotal: " <> show ulpTotal <> "\nulpScale: " <> show ulpScale <> "\nrawIntersect" <> show rawIntersect <> dumpULPs + | hasRawIntersection && distance (startPoint l1) (endPoint l1) < realToFrac (startDistanceErr+endDistanceErr) = error $ "cannot resolve endpoints of segment: " <> show l1 <> "\nulpScale: " <> show ulpScale <> "\nrawIntersect" <> show rawIntersect <> dumpULPs | hasIntersection && valOf 0 foundVal == 0 = error "intersection, but cannot cannonicalize." | hasIntersection && startDistance <= ulpStartSum = Left $ HitStartPoint l1 | hasIntersection && endDistance <= ulpEndSum = Left $ HitEndPoint l1 @@ -348,12 +334,9 @@ pLineIntersectsLineSeg (pl1, UlpSum pl1Err) (l1, UlpSum l1Err) ulpScale start = eToPPoint2 $ startPoint l1 end = eToPPoint2 $ endPoint l1 ulpStartSum, ulpEndSum :: ℝ - ulpStartSum = realToFrac $ ulpTotal+startDistanceErr - ulpEndSum = realToFrac $ ulpTotal+endDistanceErr - -- | the sum of all ULPs. used to expand the hitcircle of an endpoint. - -- Note: we do not use rawIntersectionErr here. - ulpTotal = l1Err - dumpULPs = "pl1Err: " <> show pl1Err <> "\npl2Err: " <> show pl2Err <> "\nl1Err: " <> show l1Err <> "\nrawIntersectErr: " <> show rawIntersectErr <> "\n" + ulpStartSum = realToFrac $ startDistanceErr + ulpEndSum = realToFrac $ endDistanceErr + dumpULPs = "pl1Err: " <> show pl1Err <> "\npl2Err: " <> show pl2Err <> "\nrawIntersectErr: " <> show rawIntersectErr <> "\n" hasIntersection = hasRawIntersection && onSegment l1 (rawIntersection, rawIntersectionErr) ulpStartSum ulpEndSum hasRawIntersection = valOf 0 foundVal /= 0 foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(PPoint2 (GVec vals)) -> vals) rawIntersect @@ -362,13 +345,13 @@ pLineIntersectsLineSeg (pl1, UlpSum pl1Err) (l1, UlpSum l1Err) ulpScale (rawIntersect, (_,_,rawIntersectErr)) = intersect2PL pl1 pl2 (pl2, pl2Err) = eToPL l1 --- | Check if/where two line segments intersect. -lineSegIntersectsLineSeg :: (LineSeg, UlpSum) -> (LineSeg, UlpSum) -> Either Intersection PIntersection -lineSegIntersectsLineSeg (l1, UlpSum l1Err) (l2, UlpSum ulpL2) +-- | Check if/where two l]ine segments intersect. +lineSegIntersectsLineSeg :: LineSeg -> LineSeg -> Either Intersection PIntersection +lineSegIntersectsLineSeg l1 l2 | plinesIntersectIn (pl1,pl1Err) (pl2,pl2Err) == PParallel = Right PParallel | plinesIntersectIn (pl1,pl1Err) (pl2,pl2Err) == PAntiParallel = Right PAntiParallel - | hasRawIntersection && distance (startPoint l1) (endPoint l1) < realToFrac (start1DistanceErr+end1DistanceErr+ulpTotal) = error $ "cannot resolve endpoints of segment: " <> show l1 <> ".\nulpTotal: " <> show ulpTotal <> "\nrawIntersection" <> show rawIntersection <> dumpULPs - | hasRawIntersection && distance (startPoint l2) (endPoint l2) < realToFrac (start2DistanceErr+end2DistanceErr+ulpTotal) = error $ "cannot resolve endpoints of segment: " <> show l1 <> ".\nulpTotal: " <> show ulpTotal <> "\nrawIntersection" <> show rawIntersection <> dumpULPs + | hasRawIntersection && distance (startPoint l1) (endPoint l1) < realToFrac (start1DistanceErr+end1DistanceErr) = error $ "cannot resolve endpoints of segment: " <> show l1 <> "\nrawIntersection" <> show rawIntersection <> dumpULPs + | hasRawIntersection && distance (startPoint l2) (endPoint l2) < realToFrac (start2DistanceErr+end2DistanceErr) = error $ "cannot resolve endpoints of segment: " <> show l1 <> "\nrawIntersection" <> show rawIntersection <> dumpULPs | hasIntersection && plinesIntersectIn (pl1,pl1Err) (pl2,pl2Err) == PCollinear = Right PCollinear | hasIntersection && plinesIntersectIn (pl1,pl1Err) (pl2,pl2Err) == PAntiCollinear = Right PAntiCollinear -- FIXME: why do we return a start/endpoint here? @@ -381,10 +364,10 @@ lineSegIntersectsLineSeg (l1, UlpSum l1Err) (l2, UlpSum ulpL2) | otherwise = Left $ NoIntersection ((\(PPoint2 p) -> CPPoint2 p) rawIntersect) (mempty, mempty, mempty, mempty) where ulpStartSum1, ulpEndSum1, ulpStartSum2, ulpEndSum2 :: ℝ - ulpStartSum1 = realToFrac $ ulpTotal+start1DistanceErr - ulpStartSum2 = realToFrac $ ulpTotal+start2DistanceErr - ulpEndSum1 = realToFrac $ ulpTotal - ulpEndSum2 = realToFrac $ ulpTotal + ulpStartSum1 = realToFrac $ start1DistanceErr + ulpStartSum2 = realToFrac $ start2DistanceErr + ulpEndSum1 = 0 + ulpEndSum2 = 0 (start1Distance, (_,_,UlpSum start1DistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (start1, mempty) (start2Distance, (_,_,UlpSum start2DistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (start2, mempty) (end1Distance, (_,_,UlpSum end1DistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (end1, mempty) @@ -395,9 +378,7 @@ lineSegIntersectsLineSeg (l1, UlpSum l1Err) (l2, UlpSum ulpL2) end2 = eToPPoint2 $ endPoint l2 (pl1, pl1Err) = eToPL l1 (pl2, pl2Err) = eToPL l2 - -- | the sum of all ULPs. used to expand the hitcircle of an endpoint. - ulpTotal = l1Err + ulpL2 - dumpULPs = "pl1Err: " <> show pl1Err <> "\npl2Err: " <> show pl2Err <> "\nl1Err: " <> show l1Err <> "\nrawIntersectionErr: " <> show rawIntersectionErr <> "\n" + dumpULPs = "pl1Err: " <> show pl1Err <> "\npl2Err: " <> show pl2Err <> "\nrawIntersectionErr: " <> show rawIntersectionErr <> "\n" hasIntersection = hasRawIntersection && onSegment l1 (rawIntersection,rawIntersectionErr) ulpStartSum1 ulpEndSum1 && onSegment l2 (rawIntersection,rawIntersectionErr) ulpStartSum2 ulpEndSum2 hasRawIntersection = valOf 0 foundVal /= 0 foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(PPoint2 (GVec vals)) -> vals) rawIntersect @@ -488,17 +469,3 @@ eToPL l1 = (res, resErr) where (res, (_,_,resErr)) = join2PP (eToPPoint2 $ startPoint l1) (eToPPoint2 $ endPoint l1) --- | Get the sum of the error involved in storing the values in a given PLine2. -ulpOfPLine2 :: (ProjectiveLine2 a) => a -> UlpSum -ulpOfPLine2 line = UlpSum $ sum $ abs . realToFrac . doubleUlp . (\(GVal r _) -> r) <$> catMaybes - [getVal [GEZero 1] vals - ,getVal [GEPlus 1] vals - ,getVal [GEPlus 2] vals] - where - (GVec vals) = vecOfL line - --- | Get the sum of the error involved in storing the values in a given Line Segment. -ulpOfLineSeg :: LineSeg -> UlpSum -ulpOfLineSeg (LineSeg (Point2 (x1,y1)) (Point2 (x2,y2))) = UlpSum $ sum $ abs . realToFrac . doubleUlp <$> [x1, y1, x2, y2] - - diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index 1fde54c3b..b54f55d70 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -507,8 +507,8 @@ prop_QuadBisectorCrosses rawX1 rawY1 rawX2 rawY2 <> show eNode <> "\n" <> "(" <> show x3 <> "," <> show y3 <> ")\n" where - intersect1 = intersectsWithErr (Right (PLine2 bisector1, mempty)) (Left (lineSeg1, mempty)) - intersect2 = intersectsWithErr (Right (PLine2 bisector1, mempty)) (Left (lineSeg2, mempty)) + intersect1 = intersectsWithErr (Right (PLine2 bisector1, mempty)) (Left lineSeg1) + intersect2 = intersectsWithErr (Right (PLine2 bisector1, mempty)) (Left lineSeg2) intersect3 = outputIntersectsLineSeg eNode lineSeg1 intersect4 = outputIntersectsLineSeg eNode lineSeg2 -- note that our bisector always intersects the origin. @@ -560,8 +560,8 @@ prop_QuadBisectorCrossesMultiple rawX1 rawY1 rawX2 rawY2 rawTimes <> "(" <> show x3 <> "," <> show y3 <> ")\n" <> "(" <> show x4 <> "," <> show y4 <> ")\n" where - intersect1 = intersectsWithErr (Right (PLine2 bisector1, mempty)) (Left (lineSeg1, mempty)) - intersect2 = intersectsWithErr (Right (PLine2 bisector1, mempty)) (Left (lineSeg2, mempty)) + intersect1 = intersectsWithErr (Right (PLine2 bisector1, mempty)) (Left lineSeg1) + intersect2 = intersectsWithErr (Right (PLine2 bisector1, mempty)) (Left lineSeg2) intersect3 = outputIntersectsLineSeg eNode lineSeg1 intersect4 = outputIntersectsLineSeg eNode lineSeg2 -- note that our bisector always intersects the origin. @@ -621,8 +621,8 @@ prop_LineSegIntersectionStableAtOrigin d1 x1 y1 rawX2 rawY2 ) <> "\n" <> "(x2,y2): " <> show (x2,y2) <> "\n" where - res1 = intersectsWithErr (Right (pLineThroughOriginNotX1Y1NotOther,mempty)) (Left (x1y1LineSegToOrigin,mempty)) - res2 = intersectsWithErr (Right (pLineThroughOriginNotX1Y1NotOther,mempty)) (Left (lineSegFromOrigin,mempty)) + res1 = intersectsWithErr (Right (pLineThroughOriginNotX1Y1NotOther,mempty)) (Left x1y1LineSegToOrigin) + res2 = intersectsWithErr (Right (pLineThroughOriginNotX1Y1NotOther,mempty)) (Left lineSegFromOrigin) distanceStart = case res2 of (Left (NoIntersection iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP (iPoint,mempty) (makePPoint2 0 0, mempty)) <> "\nUlpSum:" <> show ulpSum <> "\n" (Right (IntersectsIn iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP (iPoint,mempty) (makePPoint2 0 0, mempty)) <> "\nUlpSum:" <> show ulpSum <> "\n" @@ -667,8 +667,8 @@ prop_LineSegIntersectionStableAtX1Y1Point pointD rawD1 x1 y1 rawX2 rawY2 <> distanceEnd ) <> "\n" where - res1 = intersectsWithErr (Right (pLineThroughPointNotX1Y1NotOther,mempty)) (Left (x1y1LineSegToPoint,mempty)) - res2 = intersectsWithErr (Right (pLineThroughPointNotX1Y1NotOther,mempty)) (Left (lineSegFromPointNotX1Y1,mempty)) + res1 = intersectsWithErr (Right (pLineThroughPointNotX1Y1NotOther,mempty)) (Left x1y1LineSegToPoint) + res2 = intersectsWithErr (Right (pLineThroughPointNotX1Y1NotOther,mempty)) (Left lineSegFromPointNotX1Y1) distanceStart = case res2 of (Left (NoIntersection iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP (iPoint, mempty) (makePPoint2 d2 d2, mempty)) <> "\nUlpSum:" <> show ulpSum <> "\n" (Right (IntersectsIn iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP (iPoint, mempty) (makePPoint2 d2 d2, mempty)) <> "\nUlpSum:" <> show ulpSum <> "\n" From b1e90b68c36b35ba8c3e3c292d6f44f2c6aa793a Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Mon, 14 Nov 2022 21:24:49 +0000 Subject: [PATCH 076/206] pass PLine2Err instead of UlpSum. --- Graphics/Slicer/Math/PGA.hs | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 2a7b17837..65c555e1b 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -64,7 +64,7 @@ module Graphics.Slicer.Math.PGA( translateRotatePPoint2WithErr ) where -import Prelude (Bool, Eq((==),(/=)), Monoid(mempty), Semigroup((<>)), Show(show), ($), (*), (-), (>=), (&&), (<$>), otherwise, signum, snd, (>), (<=), (+), negate, (/), (||), (<), abs, error, sin, cos, realToFrac) +import Prelude (Bool, Eq((==),(/=)), Monoid(mempty), Semigroup((<>)), Show(show), ($), (*), (-), (>=), (&&), (<$>), otherwise, signum, (>), (<=), (+), negate, (/), (||), (<), abs, error, sin, cos, realToFrac) import Data.Bits.Floating.Ulp (doubleUlp) @@ -74,7 +74,7 @@ import Data.List (foldl') import Data.List.Ordered (foldt) -import Data.Maybe (Maybe(Just, Nothing), fromJust, fromMaybe, isNothing, maybeToList) +import Data.Maybe (Maybe(Just, Nothing), fromJust, isNothing, maybeToList) import Data.Set (singleton, fromList) @@ -90,7 +90,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (ErrVal, GNum(G0, GEPlus, GEZero), import Graphics.Slicer.Math.Line (combineLineSegs, makeLineSeg) -import Graphics.Slicer.Math.PGAPrimitives(Arcable(errOfOut, hasArc, outAndErrOf, outOf), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(angleBetween2PL, angleCosBetween2PL, distance2PL, flipL, forceBasisOfL, intersect2PL, normalizeL, translateL, vecOfL), ProjectivePoint2(canonicalize, distance2PP, forceBasisOfP, fuzzinessOfP, idealNormOfP, interpolate2PP, isIdealP, join2PP, pToEP, vecOfP), canonicalizedIntersectionOf2PL, pLineErrAtPPoint, xIntercept, yIntercept) +import Graphics.Slicer.Math.PGAPrimitives(Arcable(errOfOut, hasArc, outAndErrOf, outOf), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(angleBetween2PL, angleCosBetween2PL, distance2PL, flipL, forceBasisOfL, intersect2PL, normalizeL, translateL, vecOfL), ProjectivePoint2(canonicalize, distance2PP, forceBasisOfP, fuzzinessOfP, idealNormOfP, interpolate2PP, isIdealP, join2PP, pToEP, vecOfP), canonicalizedIntersectionOf2PL, pLineErrAtPPoint) -- Our 2D plane coresponds to a Clifford algebra of 2,0,1. @@ -283,10 +283,9 @@ outputIntersectsLineSeg :: (Show a, Arcable a) => a -> LineSeg -> Either Interse outputIntersectsLineSeg source l1 -- handle the case where a segment that is an input to the node is checked against. | isNothing canonicalizedIntersection = Right $ plinesIntersectIn (pl1, pl1Err) (pl2, pl2Err) - | otherwise = pLineIntersectsLineSeg (pl1, pl1Ulp) l1 1 + | otherwise = pLineIntersectsLineSeg (pl1, pl1Err) l1 1 where (pl2, pl2Err) = eToPL l1 - pl1Ulp = snd (fromMaybe (Right 0,mempty) $ xIntercept (pl1,pl1Err)) <> snd (fromMaybe (Right 0,mempty) $ yIntercept (pl1,pl1Err)) (pl1, pl1Err) | hasArc source = (outOf source, errOfOut source) | otherwise = error @@ -295,7 +294,7 @@ outputIntersectsLineSeg source l1 canonicalizedIntersection = canonicalizedIntersectionOf2PL pl1 pl2 -- | A type alias, for cases where either input is acceptable. -type SegOrPLine2WithErr = Either LineSeg (PLine2, UlpSum) +type SegOrPLine2WithErr = Either LineSeg (PLine2, PLine2Err) -- entry point usable for all intersection needs, complete with passed in error values. intersectsWithErr :: SegOrPLine2WithErr -> SegOrPLine2WithErr -> Either Intersection PIntersection @@ -315,8 +314,8 @@ intersectsWithErr (Right pl1@(rawPL1, _)) (Left l1@(rawL1)) = pLineIntersectsLin (pl2, _) = eToPL rawL1 -- | Check if/where a line segment and a PLine intersect. -pLineIntersectsLineSeg :: (PLine2, UlpSum) -> LineSeg -> ℝ -> Either Intersection PIntersection -pLineIntersectsLineSeg (pl1, UlpSum pl1Err) l1 ulpScale +pLineIntersectsLineSeg :: (PLine2, PLine2Err) -> LineSeg -> ℝ -> Either Intersection PIntersection +pLineIntersectsLineSeg (pl1, pl1Err) l1 ulpScale | plinesIntersectIn (pl1,mempty) (pl2,pl2Err) == PParallel = Right PParallel | plinesIntersectIn (pl1,mempty) (pl2,pl2Err) == PAntiParallel = Right PAntiParallel | plinesIntersectIn (pl1,mempty) (pl2,pl2Err) == PCollinear = Right PCollinear From e907a44a336cdb34123455fe73afda993b791679 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Tue, 15 Nov 2022 00:17:55 +0000 Subject: [PATCH 077/206] allow intersectionWithErr to use the ProjectiveLine2 typeclass. --- Graphics/Slicer/Math/Intersections.hs | 17 +++++++++++++---- Graphics/Slicer/Math/PGA.hs | 9 +++------ tests/Math/PGA.hs | 22 +++++++++++----------- 3 files changed, 27 insertions(+), 21 deletions(-) diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index 8c6c7f550..3562c86e1 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -20,7 +20,7 @@ module Graphics.Slicer.Math.Intersections (getMotorcycleSegSetIntersections, getMotorcycleContourIntersections, contourIntersectionCount, getPLine2Intersections, intersectionOf, intersectionBetween, noIntersection, isCollinear, isAntiCollinear, isParallel, isAntiParallel) where -import Prelude (Bool, Either(Left,Right), error, otherwise, show, (&&), (<>), ($), (<$>), (/=), (.), zip, Int, (<), (*), (||), (==), fst, length, mempty, odd, realToFrac) +import Prelude (Bool, Either(Left,Right), error, otherwise, show, (&&), (<>), ($), (<$>), (/=), zip, Int, (<), (*), (||), (==), fst, length, mempty, odd, realToFrac) import Data.Maybe( Maybe(Just,Nothing), catMaybes, isJust, fromJust) @@ -36,7 +36,7 @@ import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, mapWithNeighb import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum)) -import Graphics.Slicer.Math.PGA (CPPoint2, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), Intersection(HitEndPoint, HitStartPoint, NoIntersection), PLine2, PPoint2Err, distance2PL, intersectsWithErr, outputIntersectsLineSeg, plinesIntersectIn, pToEP) +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), Intersection(HitEndPoint, HitStartPoint, NoIntersection), PLine2, PLine2Err, PPoint2Err, distance2PL, intersectsWithErr, outputIntersectsLineSeg, plinesIntersectIn, pToEP) import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle)) @@ -85,8 +85,12 @@ contourIntersectionCount :: Contour -> (Point2, Point2) -> Int contourIntersectionCount contour (start, end) = len $ getIntersections contour (start, end) where getIntersections :: Contour -> (Point2, Point2) -> Slist (LineSeg, Either Point2 CPPoint2) - getIntersections c (pt1, pt2) = slist $ catMaybes $ mapWithNeighbors filterIntersections $ openCircuit $ zip (lineSegsOfContour contour) $ intersectsWithErr (Left $ makeLineSeg pt1 pt2) . Left <$> lineSegsOfContour c + getIntersections c (pt1, pt2) = slist $ catMaybes $ mapWithNeighbors filterIntersections $ openCircuit $ zip (lineSegsOfContour contour) $ intersectsWithErr targetSeg <$> segs where + segs :: [Either LineSeg (NPLine2, PLine2Err)] + segs = Left <$> lineSegsOfContour c + targetSeg :: Either LineSeg (NPLine2, PLine2Err) + targetSeg = Left $ makeLineSeg pt1 pt2 openCircuit v = Just <$> v -- | Get the intersections between a PLine2 and a contour as a series of points. always returns an even number of intersections. @@ -96,7 +100,12 @@ getPLine2Intersections pLine c | odd $ length res = error $ "odd number of transitions: " <> show (length res) <> "\n" <> show c <> "\n" <> show pLine <> "\n" <> show res <> "\n" | otherwise = res where - res = getPoints $ catMaybes $ mapWithNeighbors filterIntersections $ openCircuit $ zip (lineSegsOfContour c) $ intersectsWithErr (Right (pLine, mempty)) . Left <$> lineSegsOfContour c + res = getPoints $ catMaybes $ mapWithNeighbors filterIntersections $ openCircuit $ zip (lineSegsOfContour c) $ intersectsWithErr targetLine <$> segs + where + segs :: [Either LineSeg (NPLine2, PLine2Err)] + segs = Left <$> lineSegsOfContour c + targetLine :: Either LineSeg (PLine2, PLine2Err) + targetLine = Right (pLine, mempty) openCircuit v = Just <$> v getPoints :: [(LineSeg, Either Point2 CPPoint2)] -> [Point2] getPoints vs = getPoint <$> vs diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 65c555e1b..f6738629d 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -293,13 +293,10 @@ outputIntersectsLineSeg source l1 <> show source <> "\n" canonicalizedIntersection = canonicalizedIntersectionOf2PL pl1 pl2 --- | A type alias, for cases where either input is acceptable. -type SegOrPLine2WithErr = Either LineSeg (PLine2, PLine2Err) - -- entry point usable for all intersection needs, complete with passed in error values. -intersectsWithErr :: SegOrPLine2WithErr -> SegOrPLine2WithErr -> Either Intersection PIntersection +intersectsWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => Either LineSeg (a, PLine2Err) -> Either LineSeg (b, PLine2Err) -> Either Intersection PIntersection intersectsWithErr (Left l1) (Left l2) = lineSegIntersectsLineSeg l1 l2 -intersectsWithErr (Right (pl1,_)) (Right (pl2,_)) = Right $ plinesIntersectIn (pl1,mempty) (pl2,mempty) +intersectsWithErr (Right (pl1,pl1Err)) (Right (pl2,pl2Err)) = Right $ plinesIntersectIn (pl1,pl1Err) (pl2,pl2Err) intersectsWithErr (Left l1@(rawL1)) (Right pl1@(rawPL1, _)) = pLineIntersectsLineSeg pl1 l1 ulpScale where ulpScale :: ℝ @@ -314,7 +311,7 @@ intersectsWithErr (Right pl1@(rawPL1, _)) (Left l1@(rawL1)) = pLineIntersectsLin (pl2, _) = eToPL rawL1 -- | Check if/where a line segment and a PLine intersect. -pLineIntersectsLineSeg :: (PLine2, PLine2Err) -> LineSeg -> ℝ -> Either Intersection PIntersection +pLineIntersectsLineSeg :: (ProjectiveLine2 a) => (a, PLine2Err) -> LineSeg -> ℝ -> Either Intersection PIntersection pLineIntersectsLineSeg (pl1, pl1Err) l1 ulpScale | plinesIntersectIn (pl1,mempty) (pl2,pl2Err) == PParallel = Right PParallel | plinesIntersectIn (pl1,mempty) (pl2,pl2Err) == PAntiParallel = Right PAntiParallel diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index b54f55d70..38073cdf3 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -507,13 +507,13 @@ prop_QuadBisectorCrosses rawX1 rawY1 rawX2 rawY2 <> show eNode <> "\n" <> "(" <> show x3 <> "," <> show y3 <> ")\n" where - intersect1 = intersectsWithErr (Right (PLine2 bisector1, mempty)) (Left lineSeg1) - intersect2 = intersectsWithErr (Right (PLine2 bisector1, mempty)) (Left lineSeg2) + intersect1 = intersectsWithErr (Right (bisector1, mempty)) (Left lineSeg1 :: Either LineSeg (PLine2, PLine2Err)) + intersect2 = intersectsWithErr (Right (bisector1, mempty)) (Left lineSeg2 :: Either LineSeg (PLine2, PLine2Err)) intersect3 = outputIntersectsLineSeg eNode lineSeg1 intersect4 = outputIntersectsLineSeg eNode lineSeg2 -- note that our bisector always intersects the origin. (bisector, bisectorRawErr) = eToPL $ makeLineSeg (Point2 (0,0)) (Point2 (x3,y3)) - (NPLine2 bisector1, bisector1NormErr) = normalizeL bisector + (bisector1, bisector1NormErr) = normalizeL bisector bisector1Err = bisectorRawErr <> bisector1NormErr bisector2 = getFirstArc (Point2 (x1,y1)) (Point2 (0,0)) (Point2 (x2,y2)) eNode = makeENode (Point2 (x1,y1)) (Point2 (0,0)) (Point2 (x2,y2)) @@ -556,16 +556,16 @@ prop_QuadBisectorCrossesMultiple rawX1 rawY1 rawX2 rawY2 rawTimes <> show lineSeg2 <> "\n" <> show bisector1 <> "\n" <> show eNode <> "\n" - <> show (angleBetween (normalizePLine2 $ outOf eNode) (normalizePLine2 $ PLine2 bisector1)) <> "\n" + <> show (angleBetween (normalizePLine2 $ outOf eNode) bisector1) <> "\n" <> "(" <> show x3 <> "," <> show y3 <> ")\n" <> "(" <> show x4 <> "," <> show y4 <> ")\n" where - intersect1 = intersectsWithErr (Right (PLine2 bisector1, mempty)) (Left lineSeg1) - intersect2 = intersectsWithErr (Right (PLine2 bisector1, mempty)) (Left lineSeg2) + intersect1 = intersectsWithErr (Right (bisector1, mempty)) (Left lineSeg1 :: Either LineSeg (PLine2, PLine2Err)) + intersect2 = intersectsWithErr (Right (bisector1, mempty)) (Left lineSeg2 :: Either LineSeg (PLine2, PLine2Err)) intersect3 = outputIntersectsLineSeg eNode lineSeg1 intersect4 = outputIntersectsLineSeg eNode lineSeg2 -- note that our bisector always intersects the origin. - (NPLine2 bisector1, bisector1ErrRaw) = normalizeL bisector + (bisector1, bisector1ErrRaw) = normalizeL bisector (bisector, bisectorErr) = eToPL $ makeLineSeg (Point2 (0,0)) (Point2 (x3,y3)) eNode = makeENode (Point2 (x1,y1)) (Point2 (0,0)) (Point2 (x2,y2)) -- X1, Y1 and X2 forced uniqueness. additionally, forced "not 180 degree opposition). @@ -621,8 +621,8 @@ prop_LineSegIntersectionStableAtOrigin d1 x1 y1 rawX2 rawY2 ) <> "\n" <> "(x2,y2): " <> show (x2,y2) <> "\n" where - res1 = intersectsWithErr (Right (pLineThroughOriginNotX1Y1NotOther,mempty)) (Left x1y1LineSegToOrigin) - res2 = intersectsWithErr (Right (pLineThroughOriginNotX1Y1NotOther,mempty)) (Left lineSegFromOrigin) + res1 = intersectsWithErr (Right (pLineThroughOriginNotX1Y1NotOther,mempty)) (Left x1y1LineSegToOrigin :: Either LineSeg (PLine2, PLine2Err)) + res2 = intersectsWithErr (Right (pLineThroughOriginNotX1Y1NotOther,mempty)) (Left lineSegFromOrigin :: Either LineSeg (PLine2, PLine2Err)) distanceStart = case res2 of (Left (NoIntersection iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP (iPoint,mempty) (makePPoint2 0 0, mempty)) <> "\nUlpSum:" <> show ulpSum <> "\n" (Right (IntersectsIn iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP (iPoint,mempty) (makePPoint2 0 0, mempty)) <> "\nUlpSum:" <> show ulpSum <> "\n" @@ -667,8 +667,8 @@ prop_LineSegIntersectionStableAtX1Y1Point pointD rawD1 x1 y1 rawX2 rawY2 <> distanceEnd ) <> "\n" where - res1 = intersectsWithErr (Right (pLineThroughPointNotX1Y1NotOther,mempty)) (Left x1y1LineSegToPoint) - res2 = intersectsWithErr (Right (pLineThroughPointNotX1Y1NotOther,mempty)) (Left lineSegFromPointNotX1Y1) + res1 = intersectsWithErr (Right (pLineThroughPointNotX1Y1NotOther,mempty)) (Left x1y1LineSegToPoint :: Either LineSeg (PLine2, PLine2Err)) + res2 = intersectsWithErr (Right (pLineThroughPointNotX1Y1NotOther,mempty)) (Left lineSegFromPointNotX1Y1 :: Either LineSeg (PLine2, PLine2Err)) distanceStart = case res2 of (Left (NoIntersection iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP (iPoint, mempty) (makePPoint2 d2 d2, mempty)) <> "\nUlpSum:" <> show ulpSum <> "\n" (Right (IntersectsIn iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP (iPoint, mempty) (makePPoint2 d2 d2, mempty)) <> "\nUlpSum:" <> show ulpSum <> "\n" From de5af04090f34698a3a6cc2e24575e89d10fc99a Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Tue, 15 Nov 2022 00:31:46 +0000 Subject: [PATCH 078/206] move Arcable and Pointable back into PGA.hs. --- Graphics/Slicer/Math/PGA.hs | 61 +++++++++++++++++++++------ Graphics/Slicer/Math/PGAPrimitives.hs | 31 -------------- 2 files changed, 47 insertions(+), 45 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index f6738629d..8af1a3cad 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -24,14 +24,23 @@ -- | The purpose of this file is to hold projective geometric algebraic arithmatic. It defines a 2D PGA with mixed linear components. module Graphics.Slicer.Math.PGA( - Arcable(errOfOut, hasArc, outAndErrOf, outOf), + Arcable( + errOfOut, + hasArc, + outAndErrOf, + outOf + ), CPPoint2(CPPoint2), Intersection(HitStartPoint, HitEndPoint, NoIntersection), NPLine2(NPLine2), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), PLine2(PLine2), PLine2Err(PLine2Err), - Pointable(canPoint, pPointOf, ePointOf), + Pointable( + canPoint, + ePointOf, + pPointOf + ), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2( @@ -90,7 +99,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (ErrVal, GNum(G0, GEPlus, GEZero), import Graphics.Slicer.Math.Line (combineLineSegs, makeLineSeg) -import Graphics.Slicer.Math.PGAPrimitives(Arcable(errOfOut, hasArc, outAndErrOf, outOf), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), Pointable(canPoint, ePointOf, pPointOf), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(angleBetween2PL, angleCosBetween2PL, distance2PL, flipL, forceBasisOfL, intersect2PL, normalizeL, translateL, vecOfL), ProjectivePoint2(canonicalize, distance2PP, forceBasisOfP, fuzzinessOfP, idealNormOfP, interpolate2PP, isIdealP, join2PP, pToEP, vecOfP), canonicalizedIntersectionOf2PL, pLineErrAtPPoint) +import Graphics.Slicer.Math.PGAPrimitives(CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(angleBetween2PL, angleCosBetween2PL, distance2PL, flipL, forceBasisOfL, intersect2PL, normalizeL, translateL, vecOfL), ProjectivePoint2(canonicalize, distance2PP, forceBasisOfP, fuzzinessOfP, idealNormOfP, interpolate2PP, isIdealP, join2PP, pToEP, vecOfP), canonicalizedIntersectionOf2PL, pLineErrAtPPoint) -- Our 2D plane coresponds to a Clifford algebra of 2,0,1. @@ -264,19 +273,28 @@ translateRotatePPoint2WithErr point d rotation = (res, resErr) pVec = vecOfP point ---------------------------------------------------------- --------------- Euclidian Mixed Interface ----------------- +-------------------- Node Interface ---------------------- ---------------------------------------------------------- --- | Intersection events that can only happen with line segments. -data Intersection = - NoIntersection !CPPoint2 !(UlpSum, UlpSum, UlpSum, UlpSum) - | HitStartPoint !LineSeg - | HitEndPoint !LineSeg - deriving Show - --- FIXME: as long as this is required, we're not accounting for ULP correctly everywhere. -ulpMultiplier :: Rounded 'TowardInf ℝ -ulpMultiplier = 570 +-- | Does this node have an output (resulting) line? +class Arcable a where + -- | Return the error quotent of the output arc, if the output arc exists. + errOfOut :: a -> PLine2Err + -- | Is there an output arc from this node? + hasArc :: a -> Bool + -- | If there is an output arc, return it, along with it's error quotent. + outAndErrOf :: a -> (PLine2, PLine2Err) + -- | If there is an output arc, return it. + outOf :: a -> PLine2 + +-- | Typeclass for nodes that may be able to be resolved into a point. +class Pointable a where + -- | Can this node be resolved into a point in 2d space? + canPoint :: a -> Bool + -- | Get a euclidian representation of this point. + ePointOf :: a -> Point2 + -- | Get a projective representation of this point. + pPointOf :: a -> PPoint2 -- | Check if/where the arc of a motorcycle, inode, or enode intersect a line segment. outputIntersectsLineSeg :: (Show a, Arcable a) => a -> LineSeg -> Either Intersection PIntersection @@ -293,6 +311,21 @@ outputIntersectsLineSeg source l1 <> show source <> "\n" canonicalizedIntersection = canonicalizedIntersectionOf2PL pl1 pl2 +---------------------------------------------------------- +-------------- Euclidian Mixed Interface ----------------- +---------------------------------------------------------- + +-- | Intersection events that can only happen with line segments. +data Intersection = + NoIntersection !CPPoint2 !(UlpSum, UlpSum, UlpSum, UlpSum) + | HitStartPoint !LineSeg + | HitEndPoint !LineSeg + deriving Show + +-- FIXME: as long as this is required, we're not accounting for ULP correctly everywhere. +ulpMultiplier :: Rounded 'TowardInf ℝ +ulpMultiplier = 570 + -- entry point usable for all intersection needs, complete with passed in error values. intersectsWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => Either LineSeg (a, PLine2Err) -> Either LineSeg (b, PLine2Err) -> Either Intersection PIntersection intersectsWithErr (Left l1) (Left l2) = lineSegIntersectsLineSeg l1 l2 diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index 1935ed4bc..6c0001fba 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -24,21 +24,10 @@ module Graphics.Slicer.Math.PGAPrimitives ( - Arcable( - errOfOut, - hasArc, - outAndErrOf, - outOf - ), CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), - Pointable( - canPoint, - ePointOf, - pPointOf - ), PPoint2(PPoint2), PPoint2Err(PPoint2Err), ProjectiveLine2( @@ -242,17 +231,6 @@ instance Semigroup PLine2Err where instance Monoid PLine2Err where mempty = PLine2Err mempty mempty mempty mempty mempty mempty --- | Does this node have an output (resulting) line? -class Arcable a where - -- | Return the error quotent of the output arc, if the output arc exists. - errOfOut :: a -> PLine2Err - -- | Is there an output arc from this node? - hasArc :: a -> Bool - -- | If there is an output arc, return it, along with it's error quotent. - outAndErrOf :: a -> (PLine2, PLine2Err) - -- | If there is an output arc, return it. - outOf :: a -> PLine2 - -- | Return the sine of the angle between the two lines, along with the error. -- Results in a value that is ~+1 when a line points in the same direction of the other given line, and ~-1 when pointing backwards. angleBetweenProjectiveLines :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, ([ErrVal], [ErrVal]), UlpSum)) @@ -565,15 +543,6 @@ instance Semigroup PPoint2Err where instance Monoid PPoint2Err where mempty = PPoint2Err mempty mempty mempty mempty mempty mempty mempty --- | Typeclass for nodes that may be able to be resolved into a point. -class Pointable a where - -- | Can this node be resolved into a point in 2d space? - canPoint :: a -> Bool - -- | Get a euclidian representation of this point. - ePointOf :: a -> Point2 - -- | Get a projective representation of this point. - pPointOf :: a -> PPoint2 - class (Show a) => ProjectivePoint2 a where canonicalize :: a -> (CPPoint2, PPoint2Err) consLikeP :: a -> (GVec -> a) From e56835ef1bd17487b4b1a1d2a14b046a55354049 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Fri, 18 Nov 2022 00:07:41 +0000 Subject: [PATCH 079/206] remove members of the ProjectiveLine2 and ProjectivePoint2 typeclasses that do not change between implementations. --- Graphics/Slicer/Machine/Contour.hs | 2 +- Graphics/Slicer/Math/Contour.hs | 2 +- Graphics/Slicer/Math/Intersections.hs | 4 +- Graphics/Slicer/Math/Lossy.hs | 4 +- Graphics/Slicer/Math/PGA.hs | 32 +-- Graphics/Slicer/Math/PGAPrimitives.hs | 235 +++++++++---------- Graphics/Slicer/Math/Skeleton/Cells.hs | 2 +- Graphics/Slicer/Math/Skeleton/Concave.hs | 22 +- Graphics/Slicer/Math/Skeleton/Definitions.hs | 4 +- Graphics/Slicer/Math/Skeleton/Line.hs | 18 +- Graphics/Slicer/Math/Skeleton/Motorcycles.hs | 8 +- tests/Math/PGA.hs | 12 +- 12 files changed, 171 insertions(+), 174 deletions(-) diff --git a/Graphics/Slicer/Machine/Contour.hs b/Graphics/Slicer/Machine/Contour.hs index a596d0fb8..726c7a3c7 100644 --- a/Graphics/Slicer/Machine/Contour.hs +++ b/Graphics/Slicer/Machine/Contour.hs @@ -37,7 +37,7 @@ import Graphics.Slicer.Math.Line (combineLineSegs) import Graphics.Slicer.Math.Lossy (eToPLine2, pToEPoint2) -import Graphics.Slicer.Math.PGA (combineConsecutiveLineSegs, PIntersection(IntersectsIn), ProjectiveLine2(translateL), plinesIntersectIn) +import Graphics.Slicer.Math.PGA (combineConsecutiveLineSegs, PIntersection(IntersectsIn), plinesIntersectIn, translateL) import Graphics.Slicer.Definitions(ℝ) diff --git a/Graphics/Slicer/Math/Contour.hs b/Graphics/Slicer/Math/Contour.hs index 9b1592f3d..8360418f0 100644 --- a/Graphics/Slicer/Math/Contour.hs +++ b/Graphics/Slicer/Math/Contour.hs @@ -52,7 +52,7 @@ import Graphics.Slicer.Math.Intersections (contourIntersectionCount, noIntersect import Graphics.Slicer.Math.Lossy (join2PPoint2, pPointBetweenPPoints, pToEPoint2) -import Graphics.Slicer.Math.PGA (ProjectivePoint2(join2PP), PPoint2, eToPPoint2, eToPL, pLineIsLeft, pPointOnPerpWithErr) +import Graphics.Slicer.Math.PGA (ProjectivePoint2, PPoint2, eToPPoint2, eToPL, join2PP, pLineIsLeft, pPointOnPerpWithErr) -- Unapologetically ripped from ImplicitCAD. -- Added the ability to look at line segments backwards. diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index 3562c86e1..8f44597b9 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -181,14 +181,14 @@ filterIntersections l1 l2 l3 = error lineLength (mySeg, _) = distance (startPoint mySeg) (endPoint mySeg) -- | Get the intersection point of two lines we know have an intersection point. -intersectionOf :: PLine2 -> PLine2 -> CPPoint2 +intersectionOf :: PLine2 -> PLine2 -> (CPPoint2, PPoint2Err) intersectionOf pl1 pl2 = saneIntersection $ plinesIntersectIn (pl1,mempty) (pl2,mempty) where saneIntersection PAntiCollinear = error $ "cannot get the intersection of anti-collinear lines.\npl1: " <> show pl1 <> "\npl2: " <> show pl2 <> "\n" saneIntersection PCollinear = error $ "cannot get the intersection of collinear lines.\npl1: " <> show pl1 <> "\npl2: " <> show pl2 <> "\n" saneIntersection PParallel = error $ "cannot get the intersection of parallel lines.\npl1: " <> show pl1 <> "\npl2: " <> show pl2 <> "\n" saneIntersection PAntiParallel = error $ "cannot get the intersection of antiparallel lines.\npl1: " <> show pl1 <> "\npl2: " <> show pl2 <> "\n" - saneIntersection (IntersectsIn p _) = p + saneIntersection (IntersectsIn p (_,_,_,pErr)) = (p,pErr) -- | Get the intersection point of two lines. intersectionBetween :: PLine2 -> PLine2 -> Maybe (Either PLine2 (CPPoint2, PPoint2Err)) diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index 7cff7f9c7..36703fd45 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -48,14 +48,14 @@ import Graphics.Slicer.Math.Definitions (LineSeg, Point2, makeLineSeg) import Graphics.Slicer.Math.Arcs (getFirstArcWithErr, getInsideArcWithErr) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PPoint2, ProjectiveLine2, ProjectivePoint2, angleBetween2PL, canonicalize, distance2PP, distance2PL, distancePPointToPLineWithErr, eToPL, eToPPoint2, interpolate2PP, join2PP, normalizeL, pPointOnPerpWithErr, pToEP, translateL) +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PPoint2, ProjectiveLine2, ProjectivePoint2, angleBetween2PL, canonicalizeP, distance2PP, distance2PL, distancePPointToPLineWithErr, eToPL, eToPPoint2, interpolate2PP, join2PP, normalizeL, pPointOnPerpWithErr, pToEP, translateL) angleBetween :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> ℝ angleBetween pLine1 pLine2 = fst $ angleBetween2PL pLine1 pLine2 -- | canonicalize a euclidian point. canonicalizePPoint2 :: PPoint2 -> CPPoint2 -canonicalizePPoint2 point = fst $ canonicalize point +canonicalizePPoint2 point = fst $ canonicalizeP point distanceBetweenPPoints :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> ℝ distanceBetweenPPoints point1 point2 = fst $ distance2PP (point1, mempty) (point2, mempty) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 8af1a3cad..7c7488b92 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -44,32 +44,32 @@ module Graphics.Slicer.Math.PGA( PPoint2(PPoint2), PPoint2Err, ProjectiveLine2( - angleBetween2PL, - distance2PL, - flipL, - intersect2PL, normalizeL, - translateL, vecOfL ), ProjectivePoint2( - canonicalize, - distance2PP, - interpolate2PP, - join2PP, - pToEP + canonicalizeP ), + angleBetween2PL, combineConsecutiveLineSegs, distancePPointToPLineWithErr, + distance2PP, + distance2PL, eToPL, eToPPoint2, + flipL, + interpolate2PP, intersectsWithErr, + intersect2PL, + join2PP, makePPoint2, outputIntersectsLineSeg, pLineIsLeft, pPointOnPerpWithErr, pPointsOnSameSideOfPLine, + pToEP, plinesIntersectIn, + translateL, translateRotatePPoint2WithErr ) where @@ -99,7 +99,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (ErrVal, GNum(G0, GEPlus, GEZero), import Graphics.Slicer.Math.Line (combineLineSegs, makeLineSeg) -import Graphics.Slicer.Math.PGAPrimitives(CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(angleBetween2PL, angleCosBetween2PL, distance2PL, flipL, forceBasisOfL, intersect2PL, normalizeL, translateL, vecOfL), ProjectivePoint2(canonicalize, distance2PP, forceBasisOfP, fuzzinessOfP, idealNormOfP, interpolate2PP, isIdealP, join2PP, pToEP, vecOfP), canonicalizedIntersectionOf2PL, pLineErrAtPPoint) +import Graphics.Slicer.Math.PGAPrimitives(CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(normalizeL, vecOfL), ProjectivePoint2(canonicalizeP, isIdealP, vecOfP), angleBetween2PL, angleCosBetween2PL, canonicalizedIntersectionOf2PL, distance2PL, distance2PP, flipL, forceBasisOfL, forceBasisOfP, fuzzinessOfP, idealNormOfP, interpolate2PP, intersect2PL, join2PP, pLineErrAtPPoint, pToEP, translateL) -- Our 2D plane coresponds to a Clifford algebra of 2,0,1. @@ -178,7 +178,7 @@ distancePPointToPLineWithErr (inPoint, inPointErr) (inLine, inLineErr) (PLine2 perpLine, (_, _, (plMulErr, plAddErr))) = perpLineAt nLine cPoint pointErr = inPointErr <> cPointErr (nLine, nLineErr) = normalizeL inLine - (cPoint, cPointErr) = canonicalize inPoint + (cPoint, cPointErr) = canonicalizeP inPoint -- | Determine if two points are on the same side of a given line. -- Returns Nothing if one of the points is on the line. @@ -236,7 +236,7 @@ pPointOnPerpWithErr line point d = (PPoint2 res, resErr) -- FIXME: where should we put this in the error quotent of PLine2Err? (PLine2 perpLine, (nLineErr, _, perpLineErrs)) = perpLineAt line cPoint pVec = vecOfP $ forceBasisOfP cPoint - (cPoint, cPointErr) = canonicalize point + (cPoint, cPointErr) = canonicalizeP point -- Find a projective line crossing the given projective line at the given projective point at a 90 degree angle. perpLineAt :: (ProjectiveLine2 a, ProjectivePoint2 b) => a -> b -> (PLine2, (PLine2Err, PPoint2Err, ([ErrVal],[ErrVal]))) @@ -247,7 +247,7 @@ perpLineAt line point = (PLine2 res, resErr) lvec = vecOfL $ forceBasisOfL nLine (nLine, nLineErr) = normalizeL line pvec = vecOfP $ forceBasisOfP cPoint - (cPoint, cPointErr) = canonicalize point + (cPoint, cPointErr) = canonicalizeP point -- | Translate a point a given distance away from where it is, rotating it a given amount clockwise (in radians) around it's original location, with 0 degrees being aligned to the X axis. translateRotatePPoint2WithErr :: (ProjectivePoint2 a) => a -> ℝ -> ℝ -> (PPoint2, (UlpSum, UlpSum, [ErrVal], PLine2Err, PLine2Err, PPoint2Err, ([ErrVal],[ErrVal]))) @@ -370,7 +370,7 @@ pLineIntersectsLineSeg (pl1, pl1Err) l1 ulpScale hasRawIntersection = valOf 0 foundVal /= 0 foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(PPoint2 (GVec vals)) -> vals) rawIntersect rawIntersectionErr = rawIntersectErr <> cRawIntersectErr - (rawIntersection, cRawIntersectErr) = canonicalize rawIntersect + (rawIntersection, cRawIntersectErr) = canonicalizeP rawIntersect (rawIntersect, (_,_,rawIntersectErr)) = intersect2PL pl1 pl2 (pl2, pl2Err) = eToPL l1 @@ -413,7 +413,7 @@ lineSegIntersectsLineSeg l1 l2 foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(PPoint2 (GVec vals)) -> vals) rawIntersect -- FIXME: remove the canonicalization from this function, moving it to the callers. rawIntersectionErr = rawIntersectErrRaw <> cRawIntersectErr - (rawIntersection, cRawIntersectErr) = canonicalize rawIntersect + (rawIntersection, cRawIntersectErr) = canonicalizeP rawIntersect (rawIntersect, (_,_,rawIntersectErrRaw)) = intersect2PL pl1 pl2 -- | Given the result of intersectionPoint, find out whether this intersection point is on the given segment, or not. diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index 6c0001fba..a06eefd87 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -31,33 +31,31 @@ module Graphics.Slicer.Math.PGAPrimitives PPoint2(PPoint2), PPoint2Err(PPoint2Err), ProjectiveLine2( - angleBetween2PL, - angleCosBetween2PL, - canonicalizedIntersectionOf2PL, - distance2PL, - flipL, - forceBasisOfL, - fuzzinessOfL, - intersect2PL, normalizeL, - normOfL, - sqNormOfL, - translateL, vecOfL ), ProjectivePoint2( - canonicalize, - distance2PP, - forceBasisOfP, - fuzzinessOfP, - idealNormOfP, - interpolate2PP, + canonicalizeP, isIdealP, - join2PP, - pToEP, vecOfP ), + angleBetween2PL, + angleCosBetween2PL, + canonicalizedIntersectionOf2PL, + distance2PL, + distance2PP, + flipL, + forceBasisOfL, + forceBasisOfP, + fuzzinessOfL, + fuzzinessOfP, + idealNormOfP, + interpolate2PP, + intersect2PL, + join2PP, pLineErrAtPPoint, + pToEP, + translateL, xIntercept, yIntercept ) where @@ -72,7 +70,7 @@ import Data.Either (Either(Left, Right), fromRight, isRight) import Data.List (foldl', sort) -import Data.Maybe (Maybe(Just,Nothing), fromJust, fromMaybe, isJust, isNothing) +import Data.Maybe (Maybe(Just,Nothing), fromJust, isJust, isNothing) import Data.Set (Set, elems, fromList, singleton) @@ -147,60 +145,22 @@ newtype PLine2 = PLine2 GVec newtype NPLine2 = NPLine2 GVec deriving (Eq, Generic, NFData, Show) +-- | The typeclass definition. functions that must be implemented for any projective line type. class ProjectiveLine2 a where - angleBetween2PL :: (ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, UlpSum)) - angleCosBetween2PL :: (ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, UlpSum)) - canonicalizedIntersectionOf2PL :: (ProjectiveLine2 b) => a -> b -> Maybe (CPPoint2, (PLine2Err, PLine2Err, PPoint2Err)) consLikeL :: a -> (GVec -> a) - distance2PL :: (ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, UlpSum)) - flipL :: a -> a - forceBasisOfL :: a -> a - fuzzinessOfL :: (a, PLine2Err) -> UlpSum - intersect2PL :: (ProjectiveLine2 b) => a -> b -> (PPoint2, (PLine2Err, PLine2Err, PPoint2Err)) normalizeL :: a -> (NPLine2, PLine2Err) - normOfL :: a -> (ℝ, PLine2Err) - sqNormOfL :: a -> (ℝ, UlpSum) - translateL :: a -> ℝ -> (PLine2, PLine2Err) vecOfL :: a -> GVec +-- | The implementation of typeclass operations for normalized lines. instance ProjectiveLine2 NPLine2 where - angleBetween2PL l1 l2 = crushErr $ angleBetweenProjectiveLines l1 l2 - where - crushErr (res, (n1,n2,_,resErr)) = (res, (n1,n2,resErr)) - angleCosBetween2PL l1 l2 = angleCosBetweenProjectiveLines l1 l2 - canonicalizedIntersectionOf2PL l1 l2 = canonicalizedIntersectionOfProjectiveLines l1 l2 consLikeL _ = NPLine2 - distance2PL l1 l2 = crushErr $ distanceBetweenProjectiveLines l1 l2 - where - crushErr (res, (n1,n2,_,resErr)) = (res, (n1,n2,resErr)) - flipL l = flipProjectiveLine l - forceBasisOfL l = forceProjectiveLineBasis l - fuzzinessOfL l = fuzzinessOfProjectiveLine l - intersect2PL l1 l2 = intersectionOfProjectiveLines l1 l2 normalizeL l = (l, mempty) - normOfL l = normOfProjectiveLine l - sqNormOfL l = squaredNormOfProjectiveLine l - translateL l d = translateProjectiveLine l d vecOfL (NPLine2 v) = v +-- | The implementation of typeclass operations for un-normalized lines. instance ProjectiveLine2 PLine2 where - angleBetween2PL l1 l2 = crushErr $ angleBetweenProjectiveLines l1 l2 - where - crushErr (res, (n1,n2,_,ulpSum)) = (res, (n1,n2,ulpSum)) - angleCosBetween2PL l1 l2 = angleCosBetweenProjectiveLines l1 l2 - canonicalizedIntersectionOf2PL l1 l2 = canonicalizedIntersectionOfProjectiveLines l1 l2 consLikeL _ = PLine2 - distance2PL l1 l2 = crushErr $ distanceBetweenProjectiveLines l1 l2 - where - crushErr (res, (n1,n2,_,resErr)) = (res, (n1,n2,resErr)) - flipL l = flipProjectiveLine l - forceBasisOfL l = forceProjectiveLineBasis l - fuzzinessOfL l = fuzzinessOfProjectiveLine l - intersect2PL l1 l2 = intersectionOfProjectiveLines l1 l2 normalizeL l = normalizeProjectiveLine l - normOfL l = normOfProjectiveLine l - sqNormOfL l = squaredNormOfProjectiveLine l - translateL l d = translateProjectiveLine l d vecOfL (PLine2 v) = v -- | The types of error of a projective line. @@ -245,6 +205,12 @@ angleBetweenProjectiveLines line1 line2 = (scalarPart likeRes, resErr) (npl1, npl1Err) = normalizeL line1 (npl2, npl2Err) = normalizeL line2 +-- | A wrapper for the above function, that removes error quotents that are not directly related to the input or result. +angleBetween2PL :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, UlpSum)) +angleBetween2PL l1 l2 = crushErr $ angleBetweenProjectiveLines l1 l2 + where + crushErr (res, (n1,n2,_,resErr)) = (res, (n1,n2,resErr)) + -- | Find the distance between two parallel or antiparallel projective lines. distanceBetweenProjectiveLines :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, ([ErrVal], [ErrVal]), UlpSum)) distanceBetweenProjectiveLines line1 line2 = (res, resErr) @@ -257,8 +223,15 @@ distanceBetweenProjectiveLines line1 line2 = (res, resErr) (npl1, npl1Err) = normalizeL line1 (npl2, npl2Err) = normalizeL line2 +-- | A wrapper for the above function, that removes error quotents that are not directly related to the input or result. +distance2PL :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, UlpSum)) +distance2PL l1 l2 = crushErr $ distanceBetweenProjectiveLines l1 l2 + where + crushErr (res, (n1,n2,_,resErr)) = (res, (n1,n2,resErr)) + -- | Reverse a line. same line, but pointed in the other direction. -flipProjectiveLine :: (ProjectiveLine2 a) => a -> a +flipProjectiveLine, flipL :: (ProjectiveLine2 a) => a -> a +-- | Actual implementation. flipProjectiveLine line = (consLikeL line) rawRes where rawRes = GVec $ foldl' addValWithoutErr [] @@ -268,9 +241,12 @@ flipProjectiveLine line = (consLikeL line) rawRes , GVal (negate $ valOf 0 $ getVal [GEPlus 2] vals) (singleton (GEPlus 2)) ] (GVec vals) = vecOfL line +-- | Wrapper. +flipL l = flipProjectiveLine l -- | Ensure all of the '0' components exist on a Projective Line. -forceProjectiveLineBasis :: (ProjectiveLine2 a) => a -> a +forceProjectiveLineBasis, forceBasisOfL :: (ProjectiveLine2 a) => a -> a +-- | Actual implementation. forceProjectiveLineBasis line | gnums == Just [singleton (GEZero 1), singleton (GEPlus 1), @@ -282,11 +258,14 @@ forceProjectiveLineBasis line [GVal _ g1, GVal _ g2, GVal _ g3] -> Just [g1,g2,g3] _ -> Nothing vec@(GVec vals) = vecOfL line +-- | Wrapper. +forceBasisOfL l = forceProjectiveLineBasis l -- | Determine the amount of translation error when trying to resolve a projective line. -- NOTE: A projective line's error varies depending where on that line you are trying to resolve it. -- For complete results, combine this with scaling xIntercept and yIntercept. -fuzzinessOfProjectiveLine :: (ProjectiveLine2 a) => (a, PLine2Err) -> UlpSum +fuzzinessOfProjectiveLine, fuzzinessOfL :: (ProjectiveLine2 a) => (a, PLine2Err) -> UlpSum +-- | Actual implementation. fuzzinessOfProjectiveLine (line, lineErr) = tUlp <> joinAddTErr <> joinMulTErr <> normalizeTErr <> additionTErr where (PLine2Err additionErr normalizeErr _ _ tUlp (joinMulErr, joinAddErr)) = lineErr <> normalizeErrRaw @@ -295,16 +274,21 @@ fuzzinessOfProjectiveLine (line, lineErr) = tUlp <> joinAddTErr <> joinMulTErr < joinMulTErr = eValOf mempty (getVal [GEZero 1] joinMulErr) joinAddTErr = eValOf mempty (getVal [GEZero 1] joinAddErr) (_,normalizeErrRaw) = normalizeL line +-- | Wrapper. +fuzzinessOfL l = fuzzinessOfProjectiveLine l -- | Find out where two lines intersect, returning a projective point, and the error quotents. -- Note: This should only be used when you can guarantee the input lines are not collinear, or parallel. -intersectionOfProjectiveLines :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PPoint2, (PLine2Err, PLine2Err, PPoint2Err)) -intersectionOfProjectiveLines line1 line2 = (res,(line1Err, line2Err, resErr)) +intersectionOfProjectiveLines, intersect2PL :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PPoint2, (PLine2Err, PLine2Err, PPoint2Err)) +-- | Actual implementation. +intersectionOfProjectiveLines line1 line2 = (res, (line1Err, line2Err, resErr)) where (res, (line1Err, line2Err, resUnlikeErrs)) = meetOfProjectiveLines line1 line2 resErr = PPoint2Err resUnlikeErrs mempty mempty mempty mempty iAngleErr iAngleUnlikeErr -- Since the angle of intersection has an effect on how well this point was resolved, save it with the point. (iAngleErr,(_,_,iAngleUnlikeErr,_)) = angleBetweenProjectiveLines line1 line2 +-- | Wrapper. +intersect2PL l1 l2 = intersectionOfProjectiveLines l1 l2 -- | A typed meet function. the meeting of two lines is a point. -- Kept separate from intersectionOfProjectiveLines for verification reasons. @@ -333,7 +317,8 @@ normalizeProjectiveLine line = (res, resErr) -- | Find the norm of a given Projective Line. -- FIXME: should we be placing this error in the PLine2Err? it doesn't effect resolving the line... -normOfProjectiveLine :: (ProjectiveLine2 a) => a -> (ℝ, PLine2Err) +normOfProjectiveLine, normOfL :: (ProjectiveLine2 a) => a -> (ℝ, PLine2Err) +-- | Actual implementation. normOfProjectiveLine line = (res, resErr) where (res, resErr) = case sqNormOfPLine2 of @@ -342,9 +327,12 @@ normOfProjectiveLine line = (res, resErr) rawRes = sqrt sqNormOfPLine2 rawResUlp = UlpSum (abs $ realToFrac $ doubleUlp rawRes) (sqNormOfPLine2, sqNormUlp) = sqNormOfL line +-- | Wrapper. +normOfL l = normOfProjectiveLine l -- | Find the squared norm of a given Projective Line. -squaredNormOfProjectiveLine :: (ProjectiveLine2 a) => a -> (ℝ, UlpSum) +squaredNormOfProjectiveLine, sqNormOfL :: (ProjectiveLine2 a) => a -> (ℝ, UlpSum) +-- | Actual implementation. squaredNormOfProjectiveLine line = (res, ulpTotal) where res = a*a+b*b @@ -355,10 +343,13 @@ squaredNormOfProjectiveLine line = (res, ulpTotal) + abs (realToFrac $ doubleUlp $ b*b) + abs (realToFrac $ doubleUlp res) (GVec vals) = vecOfL line +-- | Wrapper. +sqNormOfL l = squaredNormOfProjectiveLine l -- | Translate a line a given distance along it's perpendicular bisector. -- Uses the property that translation of a line is expressed on the GEZero component. -translateProjectiveLine :: (ProjectiveLine2 a) => a -> ℝ -> (PLine2, PLine2Err) +translateProjectiveLine, translateL :: (ProjectiveLine2 a) => a -> ℝ -> (PLine2, PLine2Err) +-- | Actual implementation. translateProjectiveLine line d = (PLine2 res, normErr <> PLine2Err resErrs mempty mempty mempty tUlp mempty) where (res, resErrs) = addVecPairWithErr m $ vecOfL line @@ -367,6 +358,8 @@ translateProjectiveLine line d = (PLine2 res, normErr <> PLine2Err resErrs mempt tAdd = d * norm tUlp = UlpSum $ abs $ realToFrac $ doubleUlp tAdd (norm, normErr) = normOfL line +-- | Wrapper. +translateL l d = translateProjectiveLine l d ----------------------------------------- --- Projective Line Error Calculation --- @@ -470,9 +463,11 @@ yIntercept (line, lineErr) -- | Find the cosine of the angle between the two lines, along with the error. -- Results in a value that is ~+1 when the first line points to the "left" of the second given line, and ~-1 when pointing "right". +angleCosBetweenProjectiveLines, angleCosBetween2PL :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, UlpSum)) +-- | Actual implementation. -- FIXME: the sum of iPointErrVals is not +/- radians. -- FIXME: lots of places for precision related error here, that are not recorded or reported. -angleCosBetweenProjectiveLines :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, UlpSum)) +-- FIXME: what was the older method we used here? perhaps it has less opportunities for fuzziness? angleCosBetweenProjectiveLines line1 line2 | isNothing canonicalizedIntersection = (0, mempty) | otherwise = (angle, (npl1Err, npl2Err, sumPPointErrs iPointErrVals)) @@ -486,17 +481,22 @@ angleCosBetweenProjectiveLines line1 line2 gaI = GVec [GVal 1 (fromList [GEZero 1, GEPlus 1, GEPlus 2])] lvec1 = vecOfL $ forceBasisOfL line1 lvec2 = vecOfL $ forceBasisOfL line2 +-- | Wrapper. +angleCosBetween2PL l1 l2 = angleCosBetweenProjectiveLines l1 l2 -- | Get the canonicalized intersection of two lines. -- NOTE: Returns Nothing when the lines are (anti)parallel. -canonicalizedIntersectionOfProjectiveLines :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Maybe (CPPoint2, (PLine2Err, PLine2Err, PPoint2Err)) +canonicalizedIntersectionOfProjectiveLines, canonicalizedIntersectionOf2PL :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Maybe (CPPoint2, (PLine2Err, PLine2Err, PPoint2Err)) +-- | Actual implementation. canonicalizedIntersectionOfProjectiveLines line1 line2 -- | Check whether the result of our intersection returns an ideal point. if it does, it means the two lines are (anti)parallel, and we should fail. | isIdealP pp1 = Nothing | otherwise = Just (cpp1, (l1Err, l2Err, pp1Err <> cpp1Err)) where - (cpp1, cpp1Err) = canonicalize pp1 + (cpp1, cpp1Err) = canonicalizeP pp1 (pp1, (l1Err, l2Err, pp1Err)) = intersect2PL line1 line2 +-- | Wrapper. +canonicalizedIntersectionOf2PL l1 l2 = canonicalizedIntersectionOfProjectiveLines l1 l2 -------------------------------- --- Projective Point Support --- @@ -544,46 +544,21 @@ instance Monoid PPoint2Err where mempty = PPoint2Err mempty mempty mempty mempty mempty mempty mempty class (Show a) => ProjectivePoint2 a where - canonicalize :: a -> (CPPoint2, PPoint2Err) + canonicalizeP :: a -> (CPPoint2, PPoint2Err) consLikeP :: a -> (GVec -> a) - distance2PP :: (ProjectivePoint2 b) => (a, PPoint2Err) -> (b, PPoint2Err) -> (ℝ, (PPoint2Err, PPoint2Err, UlpSum)) - forceBasisOfP :: a -> a - fuzzinessOfP :: (a, PPoint2Err) -> UlpSum - idealNormOfP :: a -> (ℝ, UlpSum) - interpolate2PP :: (ProjectivePoint2 b) => a -> b -> ℝ -> ℝ -> (PPoint2, (PPoint2Err, PPoint2Err, PPoint2Err)) isIdealP :: a -> Bool - join2PP :: (ProjectivePoint2 b) => a -> b -> (PLine2, (PPoint2Err, PPoint2Err, PLine2Err)) - pToEP :: a -> (Point2, PPoint2Err) vecOfP :: a -> GVec instance ProjectivePoint2 PPoint2 where - canonicalize p = canonicalizeProjectivePoint p + canonicalizeP p = canonicalizeProjectivePoint p consLikeP (PPoint2 _) = PPoint2 - distance2PP p1 p2 = crushErr $ distanceBetweenProjectivePoints p1 p2 - where - crushErr (res,(c1, c2, _, resErr)) = (res, (c1, c2, resErr)) - forceBasisOfP p = forceProjectivePointBasis p - fuzzinessOfP p = pPointFuzziness p - idealNormOfP p = idealNormOfProjectivePoint p - interpolate2PP p1 p2 = projectivePointBetweenProjectivePoints p1 p2 isIdealP p = projectivePointIsIdeal p - join2PP p1 p2 = joinOfProjectivePoints p1 p2 - pToEP p = fromMaybe (error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point.") $ projectivePointToEuclidianPoint p vecOfP (PPoint2 a) = a instance ProjectivePoint2 CPPoint2 where - canonicalize p = (p, mempty) + canonicalizeP p = (p, mempty) consLikeP (CPPoint2 _) = CPPoint2 - distance2PP p1 p2 = crushErr $ distanceBetweenProjectivePoints p1 p2 - where - crushErr (res, (c1, c2, _, resErr)) = (res, (c1, c2, resErr)) - forceBasisOfP p = forceProjectivePointBasis p - fuzzinessOfP p = pPointFuzziness p - idealNormOfP p = idealNormOfProjectivePoint p - interpolate2PP p1 p2 = projectivePointBetweenProjectivePoints p1 p2 isIdealP _ = False - join2PP p1 p2 = joinOfProjectivePoints p1 p2 - pToEP p = fromMaybe (error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point.") $ projectivePointToEuclidianPoint p vecOfP (CPPoint2 v) = v -- | Canonicalize a euclidian point. @@ -626,11 +601,18 @@ distanceBetweenProjectivePoints (point1, point1Err) (point2, point2Err) -- FIXME: how does the error in newPLine effect the found norm here? (res, normErr) = normOfL newPLine (newPLine, (_, _, newPLineErrRaw)) = join2PP cPoint1 cPoint2 - (cPoint1, cPoint1Err) = canonicalize point1 - (cPoint2, cPoint2Err) = canonicalize point2 + (cPoint1, cPoint1Err) = canonicalizeP point1 + (cPoint2, cPoint2Err) = canonicalizeP point2 + +-- | A wrapper for the above function, that removes error quotents that are not directly related to the input or result. +distance2PP :: (ProjectivePoint2 a, ProjectivePoint2 b) => (a, PPoint2Err) -> (b, PPoint2Err) -> (ℝ, (PPoint2Err, PPoint2Err, UlpSum)) +distance2PP p1 p2 = crushErr $ distanceBetweenProjectivePoints p1 p2 + where + crushErr (res, (c1, c2, _, resErr)) = (res, (c1, c2, resErr)) -- | Ensure all of the '0' components exist on a Projective Point. This is to ensure like, unlike, and reductive work properly. -forceProjectivePointBasis :: (ProjectivePoint2 a) => a -> a +forceProjectivePointBasis, forceBasisOfP :: (ProjectivePoint2 a) => a -> a +-- | Actual implementation. forceProjectivePointBasis point | gnums == Just [fromList [GEZero 1, GEPlus 1], fromList [GEZero 1, GEPlus 2], @@ -642,9 +624,12 @@ forceProjectivePointBasis point [GVal _ g1, GVal _ g2, GVal _ g3] -> Just [g1,g2,g3] _ -> Nothing vec@(GVec vals) = vecOfP point +-- | Wrapper. +forceBasisOfP p = forceProjectivePointBasis p -- | Find the idealized norm of a projective point (ideal or not). -idealNormOfProjectivePoint :: (ProjectivePoint2 a) => a -> (ℝ, UlpSum) +idealNormOfProjectivePoint, idealNormOfP :: (ProjectivePoint2 a) => a -> (ℝ, UlpSum) +-- | Actual implementation. idealNormOfProjectivePoint point | preRes == 0 = (0, mempty) | otherwise = (res, ulpTotal) @@ -662,9 +647,12 @@ idealNormOfProjectivePoint point | otherwise = (\(Point2 (x1,y1),_) -> (x1,y1)) $ pToEP point e12Val = valOf 0 (getVal [GEPlus 1, GEPlus 2] rawVals) (GVec rawVals) = vecOfP point +-- | Wrapper. +idealNormOfP p = idealNormOfProjectivePoint p -- | Join two points, returning the line that connects them. -joinOfProjectivePoints :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> (PLine2, (PPoint2Err, PPoint2Err, PLine2Err)) +joinOfProjectivePoints, join2PP :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> (PLine2, (PPoint2Err, PPoint2Err, PLine2Err)) +-- | Actual implementation. joinOfProjectivePoints point1 point2 = (PLine2 res, (cPoint1Err, cPoint2Err, PLine2Err mempty mempty mempty mempty mempty resUlp)) where @@ -672,13 +660,16 @@ joinOfProjectivePoints point1 point2 = (PLine2 res, (res, resUlp) = pv1 ∨+ pv2 pv1 = vecOfP $ forceBasisOfP cPoint1 pv2 = vecOfP $ forceBasisOfP cPoint2 - (cPoint1, cPoint1Err) = canonicalize point1 - (cPoint2, cPoint2Err) = canonicalize point2 + (cPoint1, cPoint1Err) = canonicalizeP point1 + (cPoint2, cPoint2Err) = canonicalizeP point2 +-- | Wrapper. +join2PP p1 p2 = joinOfProjectivePoints p1 p2 -- | Find a point along the line between the two given points. -- The position of the found point is determined by the ratio betwenn the two weights supplied. -- If the weights are equal, the distance will be right between the two points. -projectivePointBetweenProjectivePoints :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> ℝ -> ℝ -> (PPoint2, (PPoint2Err, PPoint2Err, PPoint2Err)) +projectivePointBetweenProjectivePoints, interpolate2PP :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> ℝ -> ℝ -> (PPoint2, (PPoint2Err, PPoint2Err, PPoint2Err)) +-- | Actual implementation. projectivePointBetweenProjectivePoints startPoint stopPoint weight1 weight2 | isIdealP res = error "tried to generate an ideal point?" | otherwise = (res, resErr) @@ -690,25 +681,28 @@ projectivePointBetweenProjectivePoints startPoint stopPoint weight1 weight2 (weighedStop, weighedStopErr) = mulScalarVecWithErr weight2 rawStopPoint rawStartPoint = vecOfP cStartPoint rawStopPoint = vecOfP cStopPoint - (cStartPoint, cStartPointErr) = canonicalize startPoint - (cStopPoint, cStopPointErr) = canonicalize stopPoint + (cStartPoint, cStartPointErr) = canonicalizeP startPoint + (cStopPoint, cStopPointErr) = canonicalizeP stopPoint +-- | Wrapper. +interpolate2PP p1 p2 = projectivePointBetweenProjectivePoints p1 p2 -- | Determine if a point is an ideal point. projectivePointIsIdeal :: (ProjectivePoint2 a) => a -> Bool projectivePointIsIdeal point = isNothing $ getVal [GEPlus 1, GEPlus 2] $ (\(GVec vals) -> vals) $ vecOfP point -- | Maybe create a euclidian point from a projective point. Will fail if the projective point is ideal. -projectivePointToEuclidianPoint :: (ProjectivePoint2 a) => a -> Maybe (Point2, PPoint2Err) +projectivePointToEuclidianPoint, pToEP :: (ProjectivePoint2 a) => a -> (Point2, PPoint2Err) +-- | Actual implementation. projectivePointToEuclidianPoint point - | e12Val == 0 = Nothing - | otherwise = Just (res, resErr) + | projectivePointIsIdeal point = error "Attempted to create an infinite point when trying to convert from a Projective Point to a Euclidian Point." + | otherwise = (res, resErr) where res = Point2 (xVal, yVal) xVal = negate $ valOf 0 $ getVal [GEZero 1, GEPlus 2] vals yVal = valOf 0 $ getVal [GEZero 1, GEPlus 1] vals - (CPPoint2 (GVec vals), resErr) = canonicalize point - e12Val = valOf 0 (getVal [GEPlus 1, GEPlus 2] rawVals) - (GVec rawVals) = vecOfP point + (CPPoint2 (GVec vals), resErr) = canonicalizeP point +-- | Wrapper. +pToEP p = projectivePointToEuclidianPoint p ------------------------------------------ --- Projective Point Error Calculation --- @@ -721,8 +715,9 @@ sumPPointErrs errs = eValOf mempty (getVal [GEZero 1, GEPlus 1] errs) -- | Determine the amount of error in resolving a projective point. Returns the radius of a circle aroind the given point within which the 'correct' answer should be. -- FIXME: This 1000 here is completely made up BS. -pPointFuzziness :: (ProjectivePoint2 a) => (a, PPoint2Err) -> UlpSum -pPointFuzziness (point, pointErr) = UlpSum $ sumTotal * realToFrac (1+(1000*(abs angleIn + realToFrac (ulpVal $ sumPPointErrs angleUnlikeAddErr <> sumPPointErrs angleUnlikeMulErr)))) +fuzzinessOfProjectivePoint, fuzzinessOfP :: (ProjectivePoint2 a) => (a, PPoint2Err) -> UlpSum +-- | Actual implementation. +fuzzinessOfProjectivePoint (point, pointErr) = UlpSum $ sumTotal * realToFrac (1+(1000*(abs angleIn + realToFrac (ulpVal $ sumPPointErrs angleUnlikeAddErr <> sumPPointErrs angleUnlikeMulErr)))) where sumTotal = ulpVal $ sumPPointErrs pJoinAddErr <> sumPPointErrs pJoinMulErr @@ -731,4 +726,6 @@ pPointFuzziness (point, pointErr) = UlpSum $ sumTotal * realToFrac (1+(1000*(abs <> sumPPointErrs pIn1MulErr <> sumPPointErrs pIn2MulErr (PPoint2Err (pJoinAddErr, pJoinMulErr) pCanonicalizeErr pAddErr pIn1MulErr pIn2MulErr angleIn (angleUnlikeAddErr,angleUnlikeMulErr)) = cPointErr <> pointErr - (_, cPointErr) = canonicalize point + (_, cPointErr) = canonicalizeP point +-- | Wrapper. +fuzzinessOfP p = fuzzinessOfProjectivePoint p diff --git a/Graphics/Slicer/Math/Skeleton/Cells.hs b/Graphics/Slicer/Math/Skeleton/Cells.hs index 7e2b9fbc7..7bb187410 100644 --- a/Graphics/Slicer/Math/Skeleton/Cells.hs +++ b/Graphics/Slicer/Math/Skeleton/Cells.hs @@ -115,7 +115,7 @@ findDivisions contour crashTree = case motorcyclesIn crashTree of where (angleFound, (_,_, angleErr)) = angleBetween2PL (outOf m) (eToPLine2 $ lineSegToIntersection m) lineSegToIntersection m = makeLineSeg (ePointOf m) (pToEPoint2 intersectionPPoint) - intersectionPPoint = intersectionOf (outOf firstMC) (outOf secondMC) + intersectionPPoint = fst $ intersectionOf (outOf firstMC) (outOf secondMC) (Slist (_:_) _) -> error "too many motorcycles." motorcyclesIn (CrashTree motorcycles _ _) = motorcycles -- | find where the last motorcycle of a divide lands diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index 3a431d808..ecfd67844 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -60,9 +60,9 @@ import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum), ulpVal) import Graphics.Slicer.Math.Intersections (intersectionOf, intersectionBetween, isCollinear, isParallel, isAntiCollinear, noIntersection) -import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, distancePPointToPLine, eToPLine2, join2CPPoint2, normalizePLine2) +import Graphics.Slicer.Math.Lossy (distancePPointToPLine, eToPLine2, normalizePLine2) -import Graphics.Slicer.Math.PGA (Arcable(errOfOut, hasArc, outAndErrOf, outOf), Pointable(canPoint, pPointOf), PLine2(PLine2), PLine2Err, ProjectivePoint2, CPPoint2(CPPoint2), PPoint2(PPoint2), canonicalize, distance2PP, flipL, pLineIsLeft, angleBetween2PL, distancePPointToPLineWithErr, NPLine2(NPLine2)) +import Graphics.Slicer.Math.PGA (Arcable(errOfOut, hasArc, outAndErrOf, outOf), Pointable(canPoint, pPointOf), PLine2(PLine2), PLine2Err, ProjectivePoint2, CPPoint2(CPPoint2), PPoint2(PPoint2), distance2PP, flipL, pLineIsLeft, angleBetween2PL, distancePPointToPLineWithErr, join2PP, NPLine2(NPLine2)) import Graphics.Slicer.Math.Skeleton.Definitions (ENode(ENode), ENodeSet(ENodeSet), INode(INode), INodeSet(INodeSet), NodeTree(NodeTree), concavePLines, getFirstLineSeg, getLastLineSeg, finalOutOf, firstInOf, getPairs, indexPLinesTo, insOf, lastINodeOf, linePairs, makeINode, sortedPLinesWithErr, isLoop) @@ -179,8 +179,8 @@ averageNodes n1 n2 | n2Distance < getRounded n2Err = error $ "intersection is AT the point of n2!\n" <> dumpInput | otherwise = makeINode (sortedPair n1 n2) $ Just $ getOutsideArc (pPointOf n1) (normalizePLine2 $ outOf n1) (pPointOf n2) (normalizePLine2 $ outOf n2) where - (n1Distance, (_,_,UlpSum n1Err)) = distance2PP (intersectionOf (outOf n1) (outOf n2), mempty) (canonicalize $ pPointOf n1) - (n2Distance, (_,_,UlpSum n2Err)) = distance2PP (intersectionOf (outOf n1) (outOf n2), mempty) (canonicalize $ pPointOf n2) + (n1Distance, (_,_,UlpSum n1Err)) = distance2PP (intersectionOf (outOf n1) (outOf n2)) (pPointOf n1, mempty) + (n2Distance, (_,_,UlpSum n2Err)) = distance2PP (intersectionOf (outOf n1) (outOf n2)) (pPointOf n2, mempty) dumpInput = "Node1: " <> show n1 <> "\nNode2: " <> show n2 <> "\nNode1Out: " <> show (outOf n1) @@ -208,7 +208,7 @@ getOutsideArc ppoint1 npline1 ppoint2 npline2 (resFlipped, resFlippedErr) = getInsideArcWithErr pline1 (flipL pline2) pline1 = (\(NPLine2 v) -> PLine2 v) npline1 pline2 = (\(NPLine2 v) -> PLine2 v) npline2 - intersectionPoint = intersectionOf pline1 pline2 + intersectionPoint = fst $ intersectionOf pline1 pline2 l1TowardPoint = towardIntersection ppoint1 pline1 intersectionPoint l2TowardPoint = towardIntersection ppoint2 pline2 intersectionPoint @@ -221,8 +221,8 @@ towardIntersection pp1 pl1 pp2 | otherwise = angleFound > realToFrac (ulpVal angleErr) where (angleFound, (_,_, angleErr)) = angleBetween2PL newPLine pl1 - (d, (_,_,UlpSum dErr)) = distance2PP (canonicalize pp1) (pp2, mempty) - newPLine = join2CPPoint2 (fst $ canonicalize pp1) pp2 + (d, (_,_,UlpSum dErr)) = distance2PP (pp1, mempty) (pp2, mempty) + newPLine = fst $ join2PP pp1 pp2 -- | Make a first generation node. makeENode :: Point2 -> Point2 -> Point2 -> ENode @@ -854,9 +854,9 @@ skeletonOfNodes connectedLoop inSegSets iNodes = | canPoint node1 && canPoint node2 && intersectsInPoint node1 node2 = - Just $ distanceBetweenPPoints (canonicalizePPoint2 $ pPointOf node1) (intersectionOf (outOf node1) (outOf node2)) + Just $ fst (distance2PP (pPointOf node1, mempty) (intersectionOf (outOf node1) (outOf node2))) `max` - distanceBetweenPPoints (canonicalizePPoint2 $ pPointOf node2) (intersectionOf (outOf node1) (outOf node2)) + fst (distance2PP (pPointOf node2, mempty) (intersectionOf (outOf node1) (outOf node2))) | otherwise = Nothing -- | Check if the intersection of two nodes results in a point or not. intersectsInPoint :: (Arcable a, Pointable a, Show a, Arcable b, Pointable b, Show b) => a -> b -> Bool @@ -866,5 +866,5 @@ skeletonOfNodes connectedLoop inSegSets iNodes = && (dist2 >= realToFrac dist2Err) | otherwise = error $ "cannot intersect a node with no output:\nNode1: " <> show node1 <> "\nNode2: " <> show node2 <> "\nnodes: " <> show iNodes <> "\n" where - (dist1, (_,_,UlpSum dist1Err)) = distance2PP (canonicalize $ intersectionOf (outOf node1) (outOf node2)) (canonicalize $ pPointOf node1) - (dist2, (_,_,UlpSum dist2Err)) = distance2PP (canonicalize $ intersectionOf (outOf node1) (outOf node2)) (canonicalize $ pPointOf node2) + (dist1, (_,_,UlpSum dist1Err)) = distance2PP (intersectionOf (outOf node1) (outOf node2)) (pPointOf node1, mempty) + (dist2, (_,_,UlpSum dist2Err)) = distance2PP (intersectionOf (outOf node1) (outOf node2)) (pPointOf node2, mempty) diff --git a/Graphics/Slicer/Math/Skeleton/Definitions.hs b/Graphics/Slicer/Math/Skeleton/Definitions.hs index 51c70e0f7..905943b48 100644 --- a/Graphics/Slicer/Math/Skeleton/Definitions.hs +++ b/Graphics/Slicer/Math/Skeleton/Definitions.hs @@ -55,7 +55,7 @@ import Graphics.Slicer.Math.Definitions (Contour, LineSeg(LineSeg), Point2, mapW import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum), addVecPair) -import Graphics.Slicer.Math.PGA (plinesIntersectIn, PIntersection(IntersectsIn), flipL, PLine2(PLine2), PLine2Err, pLineIsLeft, distance2PP, Pointable(canPoint, pPointOf, ePointOf), Arcable(errOfOut, hasArc, outAndErrOf, outOf), CPPoint2(CPPoint2), PPoint2(PPoint2), canonicalize, eToPL, eToPPoint2, pToEP, vecOfL) +import Graphics.Slicer.Math.PGA (plinesIntersectIn, PIntersection(IntersectsIn), flipL, PLine2(PLine2), PLine2Err, pLineIsLeft, distance2PP, Pointable(canPoint, pPointOf, ePointOf), Arcable(errOfOut, hasArc, outAndErrOf, outOf), CPPoint2(CPPoint2), PPoint2(PPoint2), eToPL, eToPPoint2, pToEP, vecOfL) -- | A point where two lines segments that are part of a contour intersect, emmiting an arc toward the interior of a contour. -- FIXME: a source should have a different UlpSum for it's point and it's output. @@ -126,7 +126,7 @@ instance Pointable INode where where distanceWithinErr a b = res < realToFrac err where - (res, (_,_,UlpSum err)) = distance2PP (canonicalize a) (canonicalize b) + (res, (_,_,UlpSum err)) = distance2PP (a,mempty) (b,mempty) allPLines = if hasArc iNode then slist $ nub $ (outAndErrOf iNode) : firstPLine : secondPLine : rawPLines else slist $ nub $ firstPLine : secondPLine : rawPLines diff --git a/Graphics/Slicer/Math/Skeleton/Line.hs b/Graphics/Slicer/Math/Skeleton/Line.hs index 22268ebcf..29ea1163f 100644 --- a/Graphics/Slicer/Math/Skeleton/Line.hs +++ b/Graphics/Slicer/Math/Skeleton/Line.hs @@ -44,7 +44,7 @@ import Graphics.Slicer.Math.Skeleton.Face (Face(Face)) import Graphics.Slicer.Math.Lossy (eToNPLine2, eToPLine2, distancePPointToPLine, translatePLine2, pToEPoint2) -import Graphics.Slicer.Math.PGA (PLine2, eToPL, pLineIsLeft) +import Graphics.Slicer.Math.PGA (PLine2, distancePPointToPLineWithErr, eToPL, pLineIsLeft) import Graphics.Slicer.Machine.Infill (makeInfill, InfillType) @@ -77,12 +77,12 @@ addLineSegsToFace distance insets face@(Face edge firstArc midArcs@(Slist rawMid linesToRender = maybe linesUntilEnd (min linesUntilEnd) insets -- | The line segments we are placing. - foundLineSegs = [ makeLineSeg (pToEPoint2 $ intersectionOf newSide firstArc) (pToEPoint2 $ intersectionOf newSide lastArc) | newSide <- newSides ] + foundLineSegs = [ makeLineSeg (pToEPoint2 $ fst $ intersectionOf newSide firstArc) (pToEPoint2 $ fst $ intersectionOf newSide lastArc) | newSide <- newSides ] where newSides = [ translatePLine2 (eToPLine2 edge) $ translateDir (-(distance+(distance * fromIntegral segmentNum))) | segmentNum <- [0..linesToRender-1] ] -- | The line where we are no longer able to fill this face. from the firstArc to the lastArc, along the point that the lines we place stop. - finalSide = makeLineSeg (pToEPoint2 $ intersectionOf finalLine firstArc) (pToEPoint2 $ intersectionOf finalLine lastArc) + finalSide = makeLineSeg (pToEPoint2 $ fst $ intersectionOf finalLine firstArc) (pToEPoint2 $ fst $ intersectionOf finalLine lastArc) where finalLine = translatePLine2 (eToPLine2 edge) $ translateDir (distance * fromIntegral linesToRender) @@ -92,10 +92,10 @@ addLineSegsToFace distance insets face@(Face edge firstArc midArcs@(Slist rawMid -- | what is the distance from the edge to the place we can no longer place lines. distanceUntilEnd = case midArcs of - (Slist [] 0) -> distancePPointToPLine (intersectionOf firstArc lastArc) (eToNPLine2 edge) + (Slist [] 0) -> distancePPointToPLine (fst $ intersectionOf firstArc lastArc) (eToNPLine2 edge) (Slist [oneArc] 1) -> if firstArcLonger - then distancePPointToPLine (intersectionOf firstArc oneArc) (eToNPLine2 edge) - else distancePPointToPLine (intersectionOf oneArc lastArc) (eToNPLine2 edge) + then distancePPointToPLine (fst $ intersectionOf firstArc oneArc) (eToNPLine2 edge) + else distancePPointToPLine (fst $ intersectionOf oneArc lastArc) (eToNPLine2 edge) (Slist _ _) -> closestArcDistance ----------------------------------------------------------- @@ -106,7 +106,7 @@ addLineSegsToFace distance insets face@(Face edge firstArc midArcs@(Slist rawMid [] -> error "no remains for an nSideRemainder?" -- | Find the closest point where two of our arcs intersect, relative to our side. - arcIntersections = initSafe $ mapWithFollower (\a b -> (distancePPointToPLine (intersectionOf a b) (eToNPLine2 edge), (a, b))) $ [firstArc] <> rawMidArcs <> [lastArc] + arcIntersections = initSafe $ mapWithFollower (\a b -> (fst $ distancePPointToPLineWithErr (intersectionOf a b) (eToNPLine2 edge, mempty), (a, b))) $ [firstArc] <> rawMidArcs <> [lastArc] findClosestArc :: (ℝ, (PLine2, PLine2)) findClosestArc = case sortOn fst arcIntersections of [] -> error "empty arcIntersections?" @@ -140,13 +140,13 @@ addLineSegsToFace distance insets face@(Face edge firstArc midArcs@(Slist rawMid midArc = case midArcs of (Slist [oneArc] 1) -> oneArc (Slist _ _) -> error $ "evaluated midArc with the wrong insets of items\nd: " <> show distance <> "\nn: " <> show insets <> "\nFace: " <> show face <> "\n" - threeSideRemainder = if distancePPointToPLine (intersectionOf firstArc midArc) (eToNPLine2 edge) /= distancePPointToPLine (intersectionOf midArc lastArc) (eToNPLine2 edge) + threeSideRemainder = if fst (distancePPointToPLineWithErr (intersectionOf firstArc midArc) (eToNPLine2 edge, mempty)) /= fst (distancePPointToPLineWithErr (intersectionOf midArc lastArc) (eToNPLine2 edge, mempty)) then subRemains else Nothing (subSides, subRemains) = if firstArcLonger then addLineSegsToFace distance insets (Face finalSide firstArc (slist []) midArc) else addLineSegsToFace distance insets (Face finalSide midArc (slist []) lastArc) - firstArcLonger = distancePPointToPLine (intersectionOf firstArc midArc) (eToNPLine2 edge) > distancePPointToPLine (intersectionOf midArc lastArc) (eToNPLine2 edge) + firstArcLonger = fst (distancePPointToPLineWithErr (intersectionOf firstArc midArc) (eToNPLine2 edge, mempty)) > fst (distancePPointToPLineWithErr (intersectionOf midArc lastArc) (eToNPLine2 edge, mempty)) ---------------------------------------------- -- functions only used by a three-sided n-gon. ---------------------------------------------- diff --git a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs index f3fdf0465..d47f7a6ee 100644 --- a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs +++ b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs @@ -26,7 +26,7 @@ module Graphics.Slicer.Math.Skeleton.Motorcycles (CollisionType(HeadOn), CrashTree(CrashTree), motorcycleToENode, Collision(Collision), motorcycleIntersectsAt, intersectionSameSide, crashMotorcycles, collisionResult, convexMotorcycles, lastCrashType, motorcyclesAreAntiCollinear, motorcyclesInDivision, motorcycleMightIntersectWith, motorcycleDivisor) where -import Prelude (Bool(True, False), Either(Left,Right), Eq((==)), Show(show), Ordering (EQ, GT, LT), (&&), (<>), ($), (<$>), (<), (>), compare, error, mempty, notElem, null, otherwise, realToFrac, zip) +import Prelude (Bool(True, False), Either(Left,Right), Eq((==)), Show(show), Ordering (EQ, GT, LT), (&&), (<>), ($), (<$>), (<), (>), compare, error, fst, mempty, notElem, null, otherwise, realToFrac, zip) import Prelude as PL (init, last) @@ -50,7 +50,7 @@ import Graphics.Slicer.Math.Intersections (getMotorcycleSegSetIntersections, get import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, pPointBetweenPPoints, distanceBetweenPPoints, eToCPPoint2, eToPLine2, normalizePLine2, pLineFromEndpoints, pToEPoint2) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), PPoint2, Arcable(outAndErrOf, outOf), Pointable(canPoint, ePointOf, pPointOf), ProjectiveLine2(flipL, translateL), eToPL, pLineIsLeft, pPointsOnSameSideOfPLine, PIntersection(IntersectsIn,PAntiCollinear), plinesIntersectIn, angleBetween2PL, outputIntersectsLineSeg) +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), PPoint2, Arcable(outAndErrOf, outOf), Pointable(canPoint, ePointOf, pPointOf), eToPL, flipL, pLineIsLeft, pPointsOnSameSideOfPLine, PIntersection(IntersectsIn,PAntiCollinear), angleBetween2PL, distance2PP, outputIntersectsLineSeg, plinesIntersectIn, translateL) import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle), ENode(ENode), getFirstLineSeg, linePairs, CellDivide(CellDivide), DividingMotorcycles(DividingMotorcycles), MotorcycleIntersection(WithLineSeg, WithENode, WithMotorcycle)) @@ -148,7 +148,7 @@ crashMotorcycles contour holes | intersectionIsBehind mot2 = Nothing -- FIXME: this should be providing a distance to intersectionPPoint along the motorcycle to check. | otherwise = case getMotorcycleContourIntersections mot1 contour of - [] -> case distanceBetweenPPoints (canonicalizePPoint2 $ pPointOf mot1) intersectionPPoint `compare` distanceBetweenPPoints (canonicalizePPoint2 $ pPointOf mot2) intersectionPPoint of + [] -> case fst (distance2PP (pPointOf mot1, mempty) intersectionPPoint) `compare` fst (distance2PP (pPointOf mot2, mempty) intersectionPPoint) of GT -> Just $ Collision (mot1, mot2, slist []) (Just mot2) Normal LT -> Just $ Collision (mot1, mot2, slist []) (Just mot1) Normal EQ -> Just $ Collision (mot1, mot2, slist []) (Just mot1) SideSwipe @@ -158,7 +158,7 @@ crashMotorcycles contour holes intersectionIsBehind m = angleFound < realToFrac (ulpVal angleErr) where (angleFound, (_,_, angleErr)) = angleBetween2PL (outOf m) (eToPLine2 $ lineSegToIntersection m) - lineSegToIntersection m = makeLineSeg (ePointOf m) (pToEPoint2 intersectionPPoint) + lineSegToIntersection m = makeLineSeg (ePointOf m) (pToEPoint2 $ fst intersectionPPoint) -- | Find the non-reflex virtexes of a contour and draw motorcycles from them. Useful for contours that are a 'hole' in a bigger contour. -- This function is meant to be used on the exterior contour. diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index 38073cdf3..df8f62db9 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -59,7 +59,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(GEZero, GEPlu import Graphics.Slicer.Math.Lossy (angleBetween, canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenPLines, distancePPointToPLine, eToCPPoint2, eToPLine2, getFirstArc, join2PPoint2, normalizePLine2, pPointOnPerp) -- Our 2D Projective Geometric Algebra library. -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PLine2Err(PLine2Err), canonicalize, distance2PP, distancePPointToPLineWithErr, eToPL, eToPPoint2, interpolate2PP, intersect2PL, translateL, translateRotatePPoint2WithErr, angleBetween2PL, flipL, join2PP, makePPoint2, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, distancePPointToPLineWithErr, errOfOut, pPointOnPerpWithErr, outOf, pPointOf, outputIntersectsLineSeg) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PLine2Err(PLine2Err), canonicalizeP, distance2PP, distancePPointToPLineWithErr, eToPL, eToPPoint2, interpolate2PP, intersect2PL, translateL, translateRotatePPoint2WithErr, angleBetween2PL, flipL, join2PP, makePPoint2, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, distancePPointToPLineWithErr, errOfOut, pPointOnPerpWithErr, outOf, pPointOf, outputIntersectsLineSeg) -- The primitives of our PGA only library, and error estimation code. @@ -406,7 +406,7 @@ prop_perpAt90Degrees x y rawX2 y2 rawD (angle2, (_,_, angle2Err)) = angleBetween2PL normedPLine3 normedPLine4 (PPoint2 rawBisectorStart, bisectorStartErr) = interpolate2PP sourceStart sourceEnd 0.5 0.5 (bisectorEndRaw, bisectorEndRawErr) = pPointOnPerpWithErr pline4 (PPoint2 rawBisectorStart) d - (bisectorEnd, bisectorEndErr) = canonicalize bisectorEndRaw + (bisectorEnd, bisectorEndErr) = canonicalizeP bisectorEndRaw (pline3, pline3Err) = join2PP (CPPoint2 rawBisectorStart) bisectorEnd (normedPLine3, norm3Err) = normalizeL pline3 sourceStart = makePPoint2 x y @@ -1330,7 +1330,7 @@ prop_eNodeTowardIntersection1 :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> Pos prop_eNodeTowardIntersection1 x y d1 rawR1 d2 rawR2 = l1TowardIntersection --> True where l1TowardIntersection = towardIntersection ((\(CPPoint2 v)-> PPoint2 v) $ eToPPoint2 $ startPoint l1) pl1 eNodePoint - (eNodePoint, _) = canonicalize $ pPointOf eNode + (eNodePoint, _) = canonicalizeP $ pPointOf eNode l1 = getFirstLineSeg eNode pl1 = eToPLine2 l1 eNode = randomENode x y d1 rawR1 d2 rawR2 @@ -1339,7 +1339,7 @@ prop_eNodeAwayFromIntersection2 :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> P prop_eNodeAwayFromIntersection2 x y d1 rawR1 d2 rawR2 = l2TowardIntersection --> False where l2TowardIntersection = towardIntersection ((\(CPPoint2 v)-> PPoint2 v) $ eToPPoint2 $ endPoint l2) pl2 eNodePoint - (eNodePoint, _) = canonicalize $ pPointOf eNode + (eNodePoint, _) = canonicalizeP $ pPointOf eNode l2 = getLastLineSeg eNode pl2 = eToPLine2 l2 eNode = randomENode x y d1 rawR1 d2 rawR2 @@ -1370,7 +1370,7 @@ prop_PLinesIntersectAtOrigin rawX y rawX2 rawY2 (intersectionPPoint2, (_,_,intersectionErr)) = intersect2PL randomPLine1 randomPLine2 (randomPLine1, _) = randomPLineThroughOrigin x y (randomPLine2, _) = randomPLineThroughOrigin x2 y2 - (_, canonicalizationErr) = canonicalize intersectionPPoint2 + (_, canonicalizationErr) = canonicalizeP intersectionPPoint2 errSum = distanceErr -- + canonicalizationErr x,x2,y2 :: ℝ x = coerce rawX @@ -1398,7 +1398,7 @@ prop_PLinesIntersectAtPoint rawX y rawX2 rawY2 targetX targetY (intersectionPPoint2, (_,_, intersectionErr)) = intersect2PL randomPLine1 randomPLine2 (randomPLine1, _) = randomPLineWithErr x y targetX targetY (randomPLine2, _) = randomPLineWithErr x2 y2 targetX targetY - (_, canonicalizationErr) = canonicalize intersectionPPoint2 + (_, canonicalizationErr) = canonicalizeP intersectionPPoint2 errSum = distanceErr -- + canonicalizationErr x,x2,y2 :: ℝ x = coerce rawX From 15f81d39dd6cd5dc5f4b1febc97521f1d3ef2101 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 19 Nov 2022 14:32:15 +0000 Subject: [PATCH 080/206] move outAndErrOf out of the typeclass, and add the Show restriction to all Arcables. --- Graphics/Slicer/Math/PGA.hs | 14 ++++++++----- Graphics/Slicer/Math/Skeleton/Cells.hs | 2 +- Graphics/Slicer/Math/Skeleton/Concave.hs | 22 ++++++++++---------- Graphics/Slicer/Math/Skeleton/Definitions.hs | 7 +------ Graphics/Slicer/Math/Skeleton/Motorcycles.hs | 2 +- 5 files changed, 23 insertions(+), 24 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 7c7488b92..9810e6aa9 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -27,7 +27,6 @@ module Graphics.Slicer.Math.PGA( Arcable( errOfOut, hasArc, - outAndErrOf, outOf ), CPPoint2(CPPoint2), @@ -63,6 +62,7 @@ module Graphics.Slicer.Math.PGA( intersect2PL, join2PP, makePPoint2, + outAndErrOf, outputIntersectsLineSeg, pLineIsLeft, pPointOnPerpWithErr, @@ -277,16 +277,20 @@ translateRotatePPoint2WithErr point d rotation = (res, resErr) ---------------------------------------------------------- -- | Does this node have an output (resulting) line? -class Arcable a where +class (Show a) => Arcable a where -- | Return the error quotent of the output arc, if the output arc exists. errOfOut :: a -> PLine2Err -- | Is there an output arc from this node? hasArc :: a -> Bool - -- | If there is an output arc, return it, along with it's error quotent. - outAndErrOf :: a -> (PLine2, PLine2Err) -- | If there is an output arc, return it. outOf :: a -> PLine2 +-- | If there is an output arc, return it, along with it's error quotent. +outAndErrOf :: (Arcable a) => a -> (PLine2, PLine2Err) +outAndErrOf a + | hasArc a = (outOf a, errOfOut a) + | otherwise = error $ "Asked for out and err of Arcable with no out!\n" <> show a <> "\n" + -- | Typeclass for nodes that may be able to be resolved into a point. class Pointable a where -- | Can this node be resolved into a point in 2d space? @@ -297,7 +301,7 @@ class Pointable a where pPointOf :: a -> PPoint2 -- | Check if/where the arc of a motorcycle, inode, or enode intersect a line segment. -outputIntersectsLineSeg :: (Show a, Arcable a) => a -> LineSeg -> Either Intersection PIntersection +outputIntersectsLineSeg :: (Arcable a) => a -> LineSeg -> Either Intersection PIntersection outputIntersectsLineSeg source l1 -- handle the case where a segment that is an input to the node is checked against. | isNothing canonicalizedIntersection = Right $ plinesIntersectIn (pl1, pl1Err) (pl2, pl2Err) diff --git a/Graphics/Slicer/Math/Skeleton/Cells.hs b/Graphics/Slicer/Math/Skeleton/Cells.hs index 7bb187410..0cf2986a3 100644 --- a/Graphics/Slicer/Math/Skeleton/Cells.hs +++ b/Graphics/Slicer/Math/Skeleton/Cells.hs @@ -58,7 +58,7 @@ import Graphics.Slicer.Math.Intersections (intersectionOf) import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, eToCPPoint2, eToPLine2, pToEPoint2) -import Graphics.Slicer.Math.PGA (Arcable(outAndErrOf, outOf), CPPoint2(CPPoint2), Pointable(canPoint, ePointOf, pPointOf), PIntersection(PAntiCollinear, IntersectsIn), PPoint2(PPoint2), angleBetween2PL, distance2PP, eToPL, eToPPoint2, plinesIntersectIn) +import Graphics.Slicer.Math.PGA (Arcable(outOf), CPPoint2(CPPoint2), Pointable(canPoint, ePointOf, pPointOf), PIntersection(PAntiCollinear, IntersectsIn), PPoint2(PPoint2), angleBetween2PL, distance2PP, eToPL, eToPPoint2, outAndErrOf, plinesIntersectIn) import Graphics.Slicer.Math.PGAPrimitives (join2PP) diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index ecfd67844..279f35e3b 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -62,7 +62,7 @@ import Graphics.Slicer.Math.Intersections (intersectionOf, intersectionBetween, import Graphics.Slicer.Math.Lossy (distancePPointToPLine, eToPLine2, normalizePLine2) -import Graphics.Slicer.Math.PGA (Arcable(errOfOut, hasArc, outAndErrOf, outOf), Pointable(canPoint, pPointOf), PLine2(PLine2), PLine2Err, ProjectivePoint2, CPPoint2(CPPoint2), PPoint2(PPoint2), distance2PP, flipL, pLineIsLeft, angleBetween2PL, distancePPointToPLineWithErr, join2PP, NPLine2(NPLine2)) +import Graphics.Slicer.Math.PGA (Arcable(errOfOut, hasArc, outOf), Pointable(canPoint, pPointOf), PLine2(PLine2), PLine2Err, ProjectivePoint2, CPPoint2(CPPoint2), PPoint2(PPoint2), distance2PP, flipL, outAndErrOf, pLineIsLeft, angleBetween2PL, distancePPointToPLineWithErr, join2PP, NPLine2(NPLine2)) import Graphics.Slicer.Math.Skeleton.Definitions (ENode(ENode), ENodeSet(ENodeSet), INode(INode), INodeSet(INodeSet), NodeTree(NodeTree), concavePLines, getFirstLineSeg, getLastLineSeg, finalOutOf, firstInOf, getPairs, indexPLinesTo, insOf, lastINodeOf, linePairs, makeINode, sortedPLinesWithErr, isLoop) @@ -168,7 +168,7 @@ errorIfLeft (Right val) = val -- | For a given par of nodes, construct a new internal node, where it's parents are the given nodes, and the line leaving it is along the the obtuse bisector. -- Note: this should be hidden in skeletonOfConcaveRegion, but it's exposed here, for testing. -- Note: assumes outOf the two input nodes is already normalized. -averageNodes :: (Arcable a, Pointable a, Show a, Arcable b, Pointable b, Show b) => a -> b -> INode +averageNodes :: (Arcable a, Pointable a, Arcable b, Pointable b) => a -> b -> INode averageNodes n1 n2 | not (hasArc n1) || not (hasArc n2) = error $ "Cannot get the average of nodes if one of the nodes does not have an out!\n" <> dumpInput | not (canPoint n1) || not (canPoint n2) = error $ "Cannot get the average of nodes if we cannot resolve them to a point!\n" <> dumpInput @@ -612,7 +612,7 @@ skeletonOfNodes connectedLoop inSegSets iNodes = eNodes = makeInitialGeneration connectedLoop inSegSets errorLen1 = Left $ PartialNodes (INodeSet $ one iNodes) ("NOMATCH - length 1?\n" <> show eNodes <> "\n" <> show iNodes <> "\n" <> show inSegSets <> "\n") -- Handle the the case of two nodes. - handleTwoNodes :: (Arcable a, Pointable a, Show a, Arcable b, Pointable b, Show b) => a -> b -> Either PartialNodes INodeSet + handleTwoNodes :: (Arcable a, Pointable a, Arcable b, Pointable b) => a -> b -> Either PartialNodes INodeSet handleTwoNodes node1 node2 | isCollinear (outOf node1) (outOf node2) = Left $ PartialNodes (INodeSet $ one iNodes) $ "cannot handle collinear nodes:\n" <> show node1 <> "\n" <> show node2 <> "\n" | nodesAreAntiCollinear node1 node2 && contourLooped = Right $ INodeSet $ one [makeLastPair node1 node2] @@ -781,14 +781,14 @@ skeletonOfNodes connectedLoop inSegSets iNodes = (firstPair:_) -> justToSomething $ uncurry distanceToIntersection firstPair -- | get the list of sorted pairs of intersecting nodes. - shortestPairs :: (Arcable a, Pointable a, Show a, Eq a) => [a] -> [(a, a)] + shortestPairs :: (Arcable a, Pointable a, Eq a) => [a] -> [(a, a)] shortestPairs myNodes = case nodePairsSortedByDistance myNodes of [] -> [] [onePair] -> [onePair] (pair:morePairs) -> filterCommonIns $ pair : takeWhile (\a -> uncurry distanceToIntersection a == uncurry distanceToIntersection pair) morePairs where -- | get the intersection of each node pair, sorted based on which one has the shortest maximum distance of the two line segments from it's ancestor nodes to the intersection point. - nodePairsSortedByDistance :: (Arcable a, Pointable a, Show a) => [a] -> [(a, a)] + nodePairsSortedByDistance :: (Arcable a, Pointable a) => [a] -> [(a, a)] nodePairsSortedByDistance myNodes' = sortBy (\(p1n1, p1n2) (p2n1, p2n2) -> distanceToIntersection p1n1 p1n2 `compare` distanceToIntersection p2n1 p2n2) $ intersectingNodePairsOf myNodes' filterCommonIns :: Eq a => [(a, a)] -> [(a, a)] filterCommonIns pairs = case pairs of @@ -797,14 +797,14 @@ skeletonOfNodes connectedLoop inSegSets iNodes = (x@(node1, node2) :xs) -> x : filterCommonIns (filter (\(myNode1, myNode2) -> node1 /= myNode1 && node2 /= myNode1 && node1 /= myNode2 && node2 /= myNode2) xs) -- | get the list of sorted pairs of intersecting nodes. - shortestNeighboringPairs :: (Arcable a, Pointable a, Show a, Eq a) => [(a,a)] -> [(a, a)] + shortestNeighboringPairs :: (Arcable a, Pointable a, Eq a) => [(a,a)] -> [(a, a)] shortestNeighboringPairs myNodePairs = case nodePairsSortedByDistance myNodePairs of [] -> [] [onePair] -> [onePair] (pair:morePairs) -> filterCommonIns $ pair : takeWhile (\a -> uncurry distanceToIntersection a == uncurry distanceToIntersection pair) morePairs where -- | get the intersection of each node pair, sorted based on which one has the shortest maximum distance of the two line segments from it's ancestor nodes to the intersection point. - nodePairsSortedByDistance :: (Arcable a, Pointable a, Show a) => [(a,a)] -> [(a, a)] + nodePairsSortedByDistance :: (Arcable a, Pointable a) => [(a,a)] -> [(a, a)] nodePairsSortedByDistance myNodesPairs' = sortBy (\(p1n1, p1n2) (p2n1, p2n2) -> distanceToIntersection p1n1 p1n2 `compare` distanceToIntersection p2n1 p2n2) $ intersectingNeighboringNodePairsOf myNodesPairs' filterCommonIns :: Eq a => [(a, a)] -> [(a, a)] filterCommonIns pairs = case pairs of @@ -836,12 +836,12 @@ skeletonOfNodes connectedLoop inSegSets iNodes = getMixedPairs set1 set2 = concat $ (\a -> (a,) <$> set2) <$> set1 -- | find nodes of the same type that can intersect. - intersectingNodePairsOf :: (Arcable a, Pointable a, Show a) => [a] -> [(a, a)] + intersectingNodePairsOf :: (Arcable a, Pointable a) => [a] -> [(a, a)] intersectingNodePairsOf inNodes = catMaybes $ (\(node1, node2) -> if intersectsInPoint node1 node2 then Just (node1, node2) else Nothing) <$> getPairs inNodes -- | find nodes of the same type that can intersect. -- NOTE: accepts node pairs, so that we can ensure we check just following ENodes. - intersectingNeighboringNodePairsOf :: (Arcable a, Pointable a, Show a) => [(a,a)] -> [(a, a)] + intersectingNeighboringNodePairsOf :: (Arcable a, Pointable a) => [(a,a)] -> [(a, a)] intersectingNeighboringNodePairsOf inNodePairs = catMaybes $ (\(node1, node2) -> if intersectsInPoint node1 node2 then Just (node1, node2) else Nothing) <$> inNodePairs -- | find nodes that have output segments that are antiCollinear with one another. @@ -849,7 +849,7 @@ skeletonOfNodes connectedLoop inSegSets iNodes = antiCollinearNodePairsOf inNodes = catMaybes $ (\(node1, node2) -> if nodesAreAntiCollinear node1 node2 then Just (node1, node2) else Nothing) <$> getPairs inNodes -- | for a given pair of nodes, find the longest distance between one of the two nodes and the intersection of the two output plines. - distanceToIntersection :: (Pointable a, Arcable a, Show a, Pointable b, Arcable b, Show b) => a -> b -> Maybe ℝ + distanceToIntersection :: (Pointable a, Arcable a, Pointable b, Arcable b) => a -> b -> Maybe ℝ distanceToIntersection node1 node2 | canPoint node1 && canPoint node2 @@ -859,7 +859,7 @@ skeletonOfNodes connectedLoop inSegSets iNodes = fst (distance2PP (pPointOf node2, mempty) (intersectionOf (outOf node1) (outOf node2))) | otherwise = Nothing -- | Check if the intersection of two nodes results in a point or not. - intersectsInPoint :: (Arcable a, Pointable a, Show a, Arcable b, Pointable b, Show b) => a -> b -> Bool + intersectsInPoint :: (Arcable a, Pointable a, Arcable b, Pointable b) => a -> b -> Bool intersectsInPoint node1 node2 | hasArc node1 && hasArc node2 = not (noIntersection (outOf node1) (outOf node2)) && (dist1 >= realToFrac dist1Err) diff --git a/Graphics/Slicer/Math/Skeleton/Definitions.hs b/Graphics/Slicer/Math/Skeleton/Definitions.hs index 905943b48..6b45e8ffb 100644 --- a/Graphics/Slicer/Math/Skeleton/Definitions.hs +++ b/Graphics/Slicer/Math/Skeleton/Definitions.hs @@ -55,7 +55,7 @@ import Graphics.Slicer.Math.Definitions (Contour, LineSeg(LineSeg), Point2, mapW import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum), addVecPair) -import Graphics.Slicer.Math.PGA (plinesIntersectIn, PIntersection(IntersectsIn), flipL, PLine2(PLine2), PLine2Err, pLineIsLeft, distance2PP, Pointable(canPoint, pPointOf, ePointOf), Arcable(errOfOut, hasArc, outAndErrOf, outOf), CPPoint2(CPPoint2), PPoint2(PPoint2), eToPL, eToPPoint2, pToEP, vecOfL) +import Graphics.Slicer.Math.PGA (plinesIntersectIn, PIntersection(IntersectsIn), flipL, PLine2(PLine2), PLine2Err, pLineIsLeft, distance2PP, Pointable(canPoint, pPointOf, ePointOf), Arcable(errOfOut, hasArc, outOf), CPPoint2(CPPoint2), PPoint2(PPoint2), eToPL, eToPPoint2, outAndErrOf, pToEP, vecOfL) -- | A point where two lines segments that are part of a contour intersect, emmiting an arc toward the interior of a contour. -- FIXME: a source should have a different UlpSum for it's point and it's output. @@ -67,7 +67,6 @@ data ENode = ENode { _inPoints :: !(Point2, Point2, Point2), _arcOut :: !PLine2, instance Arcable ENode where -- an ENode always has an arc. hasArc _ = True - outAndErrOf (ENode _ outArc outErr) = (outArc, outErr) outOf (ENode _ outArc _) = outArc errOfOut (ENode _ _ outErr) = outErr @@ -89,9 +88,6 @@ instance Arcable INode where (Just (_,rawOutArcErr)) -> rawOutArcErr Nothing -> error "tried to get an outArc that has no output arc." hasArc (INode _ _ _ outArc) = isJust outArc - outAndErrOf (INode _ _ _ outArc) = case outArc of - (Just (rawOutArc, rawOutErr)) -> (rawOutArc, rawOutErr) - Nothing -> error "tried to get an outArc that has no output arc." outOf (INode _ _ _ outArc) = case outArc of (Just (rawOutArc,_)) -> rawOutArc Nothing -> error "tried to get an outArc that has no output arc." @@ -155,7 +151,6 @@ data Motorcycle = Motorcycle { _inCSegs :: !(LineSeg, LineSeg), _outPline :: !PL instance Arcable Motorcycle where -- A Motorcycle always has an arc, which is it's path. hasArc _ = True - outAndErrOf (Motorcycle _ outArc outErr) = (outArc, outErr) outOf (Motorcycle _ outArc _) = outArc errOfOut (Motorcycle _ _ outErr) = outErr diff --git a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs index d47f7a6ee..87d3ab7ad 100644 --- a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs +++ b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs @@ -50,7 +50,7 @@ import Graphics.Slicer.Math.Intersections (getMotorcycleSegSetIntersections, get import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, pPointBetweenPPoints, distanceBetweenPPoints, eToCPPoint2, eToPLine2, normalizePLine2, pLineFromEndpoints, pToEPoint2) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), PPoint2, Arcable(outAndErrOf, outOf), Pointable(canPoint, ePointOf, pPointOf), eToPL, flipL, pLineIsLeft, pPointsOnSameSideOfPLine, PIntersection(IntersectsIn,PAntiCollinear), angleBetween2PL, distance2PP, outputIntersectsLineSeg, plinesIntersectIn, translateL) +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), PPoint2, Arcable(outOf), Pointable(canPoint, ePointOf, pPointOf), eToPL, flipL, pLineIsLeft, pPointsOnSameSideOfPLine, PIntersection(IntersectsIn,PAntiCollinear), angleBetween2PL, distance2PP, outAndErrOf, outputIntersectsLineSeg, plinesIntersectIn, translateL) import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle), ENode(ENode), getFirstLineSeg, linePairs, CellDivide(CellDivide), DividingMotorcycles(DividingMotorcycles), MotorcycleIntersection(WithLineSeg, WithENode, WithMotorcycle)) From c1c2e34bda44529d0999e5274bf645a0ca4c75d8 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 19 Nov 2022 16:14:52 +0000 Subject: [PATCH 081/206] make euclidianToProjectiveLine more visible, and minor reorder / variable naming changes. --- Graphics/Slicer/Math/PGA.hs | 34 +++++++++++++++------------------- 1 file changed, 15 insertions(+), 19 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 9810e6aa9..34353e6ba 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -308,11 +308,7 @@ outputIntersectsLineSeg source l1 | otherwise = pLineIntersectsLineSeg (pl1, pl1Err) l1 1 where (pl2, pl2Err) = eToPL l1 - (pl1, pl1Err) - | hasArc source = (outOf source, errOfOut source) - | otherwise = error - $ "no arc from source?\n" - <> show source <> "\n" + (pl1, pl1Err) = outAndErrOf source canonicalizedIntersection = canonicalizedIntersectionOf2PL pl1 pl2 ---------------------------------------------------------- @@ -332,20 +328,20 @@ ulpMultiplier = 570 -- entry point usable for all intersection needs, complete with passed in error values. intersectsWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => Either LineSeg (a, PLine2Err) -> Either LineSeg (b, PLine2Err) -> Either Intersection PIntersection -intersectsWithErr (Left l1) (Left l2) = lineSegIntersectsLineSeg l1 l2 -intersectsWithErr (Right (pl1,pl1Err)) (Right (pl2,pl2Err)) = Right $ plinesIntersectIn (pl1,pl1Err) (pl2,pl2Err) -intersectsWithErr (Left l1@(rawL1)) (Right pl1@(rawPL1, _)) = pLineIntersectsLineSeg pl1 l1 ulpScale +intersectsWithErr (Left l1) (Left l2) = lineSegIntersectsLineSeg l1 l2 +intersectsWithErr (Right pl1) (Right pl2) = Right $ plinesIntersectIn pl1 pl2 +intersectsWithErr (Left l1) (Right pl1@(rawPL1, _)) = pLineIntersectsLineSeg pl1 l1 ulpScale where ulpScale :: ℝ ulpScale = realToFrac $ ulpMultiplier * (abs (realToFrac angle) + angleErr) (angle, (_,_, UlpSum angleErr)) = angleBetween2PL rawPL1 pl2 - (pl2, _) = eToPL rawL1 -intersectsWithErr (Right pl1@(rawPL1, _)) (Left l1@(rawL1)) = pLineIntersectsLineSeg pl1 l1 ulpScale + (pl2, _) = eToPL l1 +intersectsWithErr (Right pl1@(rawPL1, _)) (Left l1) = pLineIntersectsLineSeg pl1 l1 ulpScale where ulpScale :: ℝ ulpScale = realToFrac $ ulpMultiplier * (abs (realToFrac angle) + angleErr) (angle, (_,_, UlpSum angleErr)) = angleBetween2PL rawPL1 pl2 - (pl2, _) = eToPL rawL1 + (pl2, _) = eToPL l1 -- | Check if/where a line segment and a PLine intersect. pLineIntersectsLineSeg :: (ProjectiveLine2 a) => (a, PLine2Err) -> LineSeg -> ℝ -> Either Intersection PIntersection @@ -378,7 +374,7 @@ pLineIntersectsLineSeg (pl1, pl1Err) l1 ulpScale (rawIntersect, (_,_,rawIntersectErr)) = intersect2PL pl1 pl2 (pl2, pl2Err) = eToPL l1 --- | Check if/where two l]ine segments intersect. +-- | Check if/where two line segments intersect. lineSegIntersectsLineSeg :: LineSeg -> LineSeg -> Either Intersection PIntersection lineSegIntersectsLineSeg l1 l2 | plinesIntersectIn (pl1,pl1Err) (pl2,pl2Err) == PParallel = Right PParallel @@ -427,12 +423,12 @@ onSegment ls (i, iErr) startUlp endUlp = || (midDistance <= (lengthOfSegment/2) + midFudgeFactor) || (endDistance <= endFudgeFactor) where - (startDistance, (_,_,UlpSum startDistanceErr)) = distance2PP (start, mempty) (i, iErr) - (midDistance, (_,_,UlpSum midDistanceErr)) = distance2PP (mid, midErr) (i, iErr) - (endDistance, (_,_,UlpSum endDistanceErr)) = distance2PP (end, mempty) (i, iErr) start = eToPPoint2 $ startPoint ls (mid, (_, _, midErr)) = interpolate2PP start end 0.5 0.5 end = eToPPoint2 $ endPoint ls + (startDistance, (_,_,UlpSum startDistanceErr)) = distance2PP (start, mempty) (i, iErr) + (midDistance, (_,_,UlpSum midDistanceErr)) = distance2PP (mid, midErr) (i, iErr) + (endDistance, (_,_,UlpSum endDistanceErr)) = distance2PP (end, mempty) (i, iErr) lengthOfSegment = distance (startPoint ls) (endPoint ls) startFudgeFactor, midFudgeFactor, endFudgeFactor :: ℝ startFudgeFactor = realToFrac $ realToFrac startUlp + startDistanceErr @@ -497,8 +493,8 @@ reverseGVec (GVec vals) = GVec $ foldl' addValWithoutErr [] , GVal (negate $ valOf 0 $ getVal [GEZero 1, GEPlus 1, GEPlus 2] vals) (fromList [GEZero 1, GEPlus 1, GEPlus 2]) ] -eToPL :: LineSeg -> (PLine2, PLine2Err) -eToPL l1 = (res, resErr) +euclidianToProjectiveLine, eToPL :: LineSeg -> (PLine2, PLine2Err) +euclidianToProjectiveLine l = (res, resErr) where - (res, (_,_,resErr)) = join2PP (eToPPoint2 $ startPoint l1) (eToPPoint2 $ endPoint l1) - + (res, (_, _, resErr)) = join2PP (eToPPoint2 $ startPoint l) (eToPPoint2 $ endPoint l) +eToPL l = euclidianToProjectiveLine l From 6f29a712622affa98893e0d795f14ebf8d9f0a60 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 19 Nov 2022 19:55:56 +0000 Subject: [PATCH 082/206] reordering, make noIntersection contain components similar to IntersectsIn, and take the error of converting from a Line to a ProjectiveLine into account. --- Graphics/Slicer/Math/PGA.hs | 54 +++++++++++++++++++------------------ 1 file changed, 28 insertions(+), 26 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 34353e6ba..52f44b03e 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -317,7 +317,7 @@ outputIntersectsLineSeg source l1 -- | Intersection events that can only happen with line segments. data Intersection = - NoIntersection !CPPoint2 !(UlpSum, UlpSum, UlpSum, UlpSum) + NoIntersection !CPPoint2 !(PLine2Err, PLine2Err, UlpSum, PPoint2Err) | HitStartPoint !LineSeg | HitEndPoint !LineSeg deriving Show @@ -354,25 +354,26 @@ pLineIntersectsLineSeg (pl1, pl1Err) l1 ulpScale | hasIntersection && valOf 0 foundVal == 0 = error "intersection, but cannot cannonicalize." | hasIntersection && startDistance <= ulpStartSum = Left $ HitStartPoint l1 | hasIntersection && endDistance <= ulpEndSum = Left $ HitEndPoint l1 - | hasIntersection = Right $ IntersectsIn rawIntersection (mempty, mempty, mempty, mempty) - | hasRawIntersection = Left $ NoIntersection rawIntersection (UlpSum $ realToFrac ulpStartSum, UlpSum $ realToFrac ulpEndSum, mempty, mempty) - | otherwise = Left $ NoIntersection ((\(PPoint2 v) -> CPPoint2 v) rawIntersect) (mempty, mempty, mempty, mempty) + | hasIntersection = Right $ IntersectsIn rawIntersection (pl1Err, pl2Err, mempty, rawIntersectionErr) + | hasRawIntersection = Left $ NoIntersection rawIntersection (pl1Err, pl2Err, mempty, rawIntersectionErr) + | otherwise = Left $ NoIntersection ((\(PPoint2 p) -> CPPoint2 p) rawIntersect) (pl1Err, pl2Err, mempty, rawIntersectErr) where (startDistance, (_,_,UlpSum startDistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (start,mempty) (endDistance, (_,_,UlpSum endDistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (end,mempty) - start = eToPPoint2 $ startPoint l1 - end = eToPPoint2 $ endPoint l1 ulpStartSum, ulpEndSum :: ℝ ulpStartSum = realToFrac $ startDistanceErr ulpEndSum = realToFrac $ endDistanceErr dumpULPs = "pl1Err: " <> show pl1Err <> "\npl2Err: " <> show pl2Err <> "\nrawIntersectErr: " <> show rawIntersectErr <> "\n" hasIntersection = hasRawIntersection && onSegment l1 (rawIntersection, rawIntersectionErr) ulpStartSum ulpEndSum hasRawIntersection = valOf 0 foundVal /= 0 - foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(PPoint2 (GVec vals)) -> vals) rawIntersect rawIntersectionErr = rawIntersectErr <> cRawIntersectErr (rawIntersection, cRawIntersectErr) = canonicalizeP rawIntersect - (rawIntersect, (_,_,rawIntersectErr)) = intersect2PL pl1 pl2 - (pl2, pl2Err) = eToPL l1 + pl2Err = pl2ErrOrigin <> npl2Err + foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(PPoint2 (GVec vals)) -> vals) rawIntersect + (rawIntersect, (_,npl2Err,rawIntersectErr)) = intersect2PL pl1 pl2 + start = eToPPoint2 $ startPoint l1 + end = eToPPoint2 $ endPoint l1 + (pl2, pl2ErrOrigin) = eToPL l1 -- | Check if/where two line segments intersect. lineSegIntersectsLineSeg :: LineSeg -> LineSeg -> Either Intersection PIntersection @@ -388,9 +389,9 @@ lineSegIntersectsLineSeg l1 l2 | hasIntersection && end1Distance <= ulpEndSum1 = Left $ HitEndPoint l1 | hasIntersection && start2Distance <= ulpStartSum2 = Left $ HitStartPoint l2 | hasIntersection && end2Distance <= ulpEndSum2 = Left $ HitEndPoint l2 - | hasIntersection = Right $ IntersectsIn rawIntersection (mempty, mempty, mempty, mempty) - | hasRawIntersection = Left $ NoIntersection rawIntersection (UlpSum $ realToFrac ulpStartSum1, UlpSum $ realToFrac ulpEndSum1, UlpSum $ realToFrac ulpStartSum2, UlpSum $ realToFrac ulpEndSum2) - | otherwise = Left $ NoIntersection ((\(PPoint2 p) -> CPPoint2 p) rawIntersect) (mempty, mempty, mempty, mempty) + | hasIntersection = Right $ IntersectsIn rawIntersection (pl1Err, pl2Err, mempty, rawIntersectionErr) + | hasRawIntersection = Left $ NoIntersection rawIntersection (pl1Err, pl2Err, mempty, rawIntersectionErr) + | otherwise = Left $ NoIntersection ((\(PPoint2 p) -> CPPoint2 p) rawIntersect) (pl1Err, pl2Err, mempty, rawIntersectErr) where ulpStartSum1, ulpEndSum1, ulpStartSum2, ulpEndSum2 :: ℝ ulpStartSum1 = realToFrac $ start1DistanceErr @@ -401,24 +402,25 @@ lineSegIntersectsLineSeg l1 l2 (start2Distance, (_,_,UlpSum start2DistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (start2, mempty) (end1Distance, (_,_,UlpSum end1DistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (end1, mempty) (end2Distance, (_,_,UlpSum end2DistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (end2, mempty) - start1 = eToPPoint2 $ startPoint l1 - end1 = eToPPoint2 $ endPoint l1 - start2 = eToPPoint2 $ startPoint l2 - end2 = eToPPoint2 $ endPoint l2 - (pl1, pl1Err) = eToPL l1 - (pl2, pl2Err) = eToPL l2 dumpULPs = "pl1Err: " <> show pl1Err <> "\npl2Err: " <> show pl2Err <> "\nrawIntersectionErr: " <> show rawIntersectionErr <> "\n" hasIntersection = hasRawIntersection && onSegment l1 (rawIntersection,rawIntersectionErr) ulpStartSum1 ulpEndSum1 && onSegment l2 (rawIntersection,rawIntersectionErr) ulpStartSum2 ulpEndSum2 hasRawIntersection = valOf 0 foundVal /= 0 + (rawIntersection, (_, _, rawIntersectionErr)) = fromJust canonicalizedIntersection + canonicalizedIntersection = canonicalizedIntersectionOf2PL pl1 pl2 + pl1Err = pl1ErrOrigin <> npl1Err + pl2Err = pl2ErrOrigin <> npl2Err foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(PPoint2 (GVec vals)) -> vals) rawIntersect - -- FIXME: remove the canonicalization from this function, moving it to the callers. - rawIntersectionErr = rawIntersectErrRaw <> cRawIntersectErr - (rawIntersection, cRawIntersectErr) = canonicalizeP rawIntersect - (rawIntersect, (_,_,rawIntersectErrRaw)) = intersect2PL pl1 pl2 + (rawIntersect, (npl1Err, npl2Err, rawIntersectErr)) = intersect2PL pl1 pl2 + start1 = eToPPoint2 $ startPoint l1 + end1 = eToPPoint2 $ endPoint l1 + start2 = eToPPoint2 $ startPoint l2 + end2 = eToPPoint2 $ endPoint l2 + (pl1, pl1ErrOrigin) = eToPL l1 + (pl2, pl2ErrOrigin) = eToPL l2 -- | Given the result of intersectionPoint, find out whether this intersection point is on the given segment, or not. onSegment :: LineSeg -> (CPPoint2, PPoint2Err) -> ℝ -> ℝ -> Bool -onSegment ls (i, iErr) startUlp endUlp = +onSegment ls i startUlp endUlp = (startDistance <= startFudgeFactor) || (midDistance <= (lengthOfSegment/2) + midFudgeFactor) || (endDistance <= endFudgeFactor) @@ -426,9 +428,9 @@ onSegment ls (i, iErr) startUlp endUlp = start = eToPPoint2 $ startPoint ls (mid, (_, _, midErr)) = interpolate2PP start end 0.5 0.5 end = eToPPoint2 $ endPoint ls - (startDistance, (_,_,UlpSum startDistanceErr)) = distance2PP (start, mempty) (i, iErr) - (midDistance, (_,_,UlpSum midDistanceErr)) = distance2PP (mid, midErr) (i, iErr) - (endDistance, (_,_,UlpSum endDistanceErr)) = distance2PP (end, mempty) (i, iErr) + (startDistance, (_,_,UlpSum startDistanceErr)) = distance2PP i (start, mempty) + (midDistance, (_,_,UlpSum midDistanceErr)) = distance2PP i (mid, midErr) + (endDistance, (_,_,UlpSum endDistanceErr)) = distance2PP i (end, mempty) lengthOfSegment = distance (startPoint ls) (endPoint ls) startFudgeFactor, midFudgeFactor, endFudgeFactor :: ℝ startFudgeFactor = realToFrac $ realToFrac startUlp + startDistanceErr From a777b62ac2a18518bfb5f42b8772c32d2a38caca Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 19 Nov 2022 21:18:46 +0000 Subject: [PATCH 083/206] use vecOfP instead of hand rolling, move to a single call to plinesIntersectIn, and simplify canonicalization. --- Graphics/Slicer/Math/PGA.hs | 24 +++++++++++++----------- Graphics/Slicer/Math/PGAPrimitives.hs | 11 +---------- 2 files changed, 14 insertions(+), 21 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 52f44b03e..f2c2963d1 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -346,18 +346,19 @@ intersectsWithErr (Right pl1@(rawPL1, _)) (Left l1) = pLineIntersectsLineSeg pl1 -- | Check if/where a line segment and a PLine intersect. pLineIntersectsLineSeg :: (ProjectiveLine2 a) => (a, PLine2Err) -> LineSeg -> ℝ -> Either Intersection PIntersection pLineIntersectsLineSeg (pl1, pl1Err) l1 ulpScale - | plinesIntersectIn (pl1,mempty) (pl2,pl2Err) == PParallel = Right PParallel - | plinesIntersectIn (pl1,mempty) (pl2,pl2Err) == PAntiParallel = Right PAntiParallel - | plinesIntersectIn (pl1,mempty) (pl2,pl2Err) == PCollinear = Right PCollinear - | plinesIntersectIn (pl1,mempty) (pl2,pl2Err) == PAntiCollinear = Right PAntiCollinear + | res == PParallel = Right PParallel + | res == PAntiParallel = Right PAntiParallel + | res == PCollinear = Right PCollinear + | res == PAntiCollinear = Right PAntiCollinear | hasRawIntersection && distance (startPoint l1) (endPoint l1) < realToFrac (startDistanceErr+endDistanceErr) = error $ "cannot resolve endpoints of segment: " <> show l1 <> "\nulpScale: " <> show ulpScale <> "\nrawIntersect" <> show rawIntersect <> dumpULPs | hasIntersection && valOf 0 foundVal == 0 = error "intersection, but cannot cannonicalize." | hasIntersection && startDistance <= ulpStartSum = Left $ HitStartPoint l1 | hasIntersection && endDistance <= ulpEndSum = Left $ HitEndPoint l1 | hasIntersection = Right $ IntersectsIn rawIntersection (pl1Err, pl2Err, mempty, rawIntersectionErr) | hasRawIntersection = Left $ NoIntersection rawIntersection (pl1Err, pl2Err, mempty, rawIntersectionErr) - | otherwise = Left $ NoIntersection ((\(PPoint2 p) -> CPPoint2 p) rawIntersect) (pl1Err, pl2Err, mempty, rawIntersectErr) + | otherwise = Left $ NoIntersection ((\(PPoint2 v) -> CPPoint2 v) rawIntersect) (pl1Err, pl2Err, mempty, rawIntersectErr) where + res = plinesIntersectIn (pl1, pl1Err) (pl2, pl2Err) (startDistance, (_,_,UlpSum startDistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (start,mempty) (endDistance, (_,_,UlpSum endDistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (end,mempty) ulpStartSum, ulpEndSum :: ℝ @@ -378,12 +379,12 @@ pLineIntersectsLineSeg (pl1, pl1Err) l1 ulpScale -- | Check if/where two line segments intersect. lineSegIntersectsLineSeg :: LineSeg -> LineSeg -> Either Intersection PIntersection lineSegIntersectsLineSeg l1 l2 - | plinesIntersectIn (pl1,pl1Err) (pl2,pl2Err) == PParallel = Right PParallel - | plinesIntersectIn (pl1,pl1Err) (pl2,pl2Err) == PAntiParallel = Right PAntiParallel + | res == PParallel = Right PParallel + | res == PAntiParallel = Right PAntiParallel | hasRawIntersection && distance (startPoint l1) (endPoint l1) < realToFrac (start1DistanceErr+end1DistanceErr) = error $ "cannot resolve endpoints of segment: " <> show l1 <> "\nrawIntersection" <> show rawIntersection <> dumpULPs | hasRawIntersection && distance (startPoint l2) (endPoint l2) < realToFrac (start2DistanceErr+end2DistanceErr) = error $ "cannot resolve endpoints of segment: " <> show l1 <> "\nrawIntersection" <> show rawIntersection <> dumpULPs - | hasIntersection && plinesIntersectIn (pl1,pl1Err) (pl2,pl2Err) == PCollinear = Right PCollinear - | hasIntersection && plinesIntersectIn (pl1,pl1Err) (pl2,pl2Err) == PAntiCollinear = Right PAntiCollinear + | hasIntersection && res == PCollinear = Right PCollinear + | hasIntersection && res == PAntiCollinear = Right PAntiCollinear -- FIXME: why do we return a start/endpoint here? | hasIntersection && start1Distance <= ulpStartSum1 = Left $ HitStartPoint l1 | hasIntersection && end1Distance <= ulpEndSum1 = Left $ HitEndPoint l1 @@ -391,8 +392,9 @@ lineSegIntersectsLineSeg l1 l2 | hasIntersection && end2Distance <= ulpEndSum2 = Left $ HitEndPoint l2 | hasIntersection = Right $ IntersectsIn rawIntersection (pl1Err, pl2Err, mempty, rawIntersectionErr) | hasRawIntersection = Left $ NoIntersection rawIntersection (pl1Err, pl2Err, mempty, rawIntersectionErr) - | otherwise = Left $ NoIntersection ((\(PPoint2 p) -> CPPoint2 p) rawIntersect) (pl1Err, pl2Err, mempty, rawIntersectErr) + | otherwise = Left $ NoIntersection ((\(PPoint2 v) -> CPPoint2 v) rawIntersect) (pl1Err, pl2Err, mempty, rawIntersectErr) where + res = plinesIntersectIn (pl1, pl1Err) (pl2, pl2Err) ulpStartSum1, ulpEndSum1, ulpStartSum2, ulpEndSum2 :: ℝ ulpStartSum1 = realToFrac $ start1DistanceErr ulpStartSum2 = realToFrac $ start2DistanceErr @@ -409,7 +411,7 @@ lineSegIntersectsLineSeg l1 l2 canonicalizedIntersection = canonicalizedIntersectionOf2PL pl1 pl2 pl1Err = pl1ErrOrigin <> npl1Err pl2Err = pl2ErrOrigin <> npl2Err - foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(PPoint2 (GVec vals)) -> vals) rawIntersect + foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(GVec vals) -> vals) $ vecOfP rawIntersect (rawIntersect, (npl1Err, npl2Err, rawIntersectErr)) = intersect2PL pl1 pl2 start1 = eToPPoint2 $ startPoint l1 end1 = eToPPoint2 $ endPoint l1 diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index a06eefd87..9af64076c 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -571,16 +571,7 @@ canonicalizeProjectivePoint point | valOf 1 foundVal == 1 = (CPPoint2 $ GVec rawVals, mempty) | otherwise = (res, PPoint2Err mempty scaledErrs mempty mempty mempty mempty mempty) where - res = CPPoint2 $ GVec $ foldl' addValWithoutErr [] - $ ( if isNothing (getVal [GEZero 1, GEPlus 1] scaledVals) - then [] - else [GVal (valOf 0 $ getVal [GEZero 1, GEPlus 1] scaledVals) (fromList [GEZero 1, GEPlus 1])] - ) - <> ( if isNothing (getVal [GEZero 1, GEPlus 2] scaledVals) - then [] - else [GVal (valOf 0 $ getVal [GEZero 1, GEPlus 2] scaledVals) (fromList [GEZero 1, GEPlus 2])] - ) - <> [GVal 1 (fromList [GEPlus 1, GEPlus 2])] + res = CPPoint2 $ GVec $ foldl' addValWithoutErr [GVal 1 (fromList [GEPlus 1, GEPlus 2])] scaledVals (GVec scaledVals, scaledErrs) = divVecScalarWithErr newVec $ valOf 1 foundVal newVec = GVec [GVal (valOf 0 $ getVal [GEZero 1, GEPlus 1] rawVals) (fromList [GEZero 1, GEPlus 1]) ,GVal (valOf 0 $ getVal [GEZero 1, GEPlus 2] rawVals) (fromList [GEZero 1, GEPlus 2])] From 52738baadf231aaff31d8cded5004bfb7ebc0212 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 20 Nov 2022 02:08:17 +0000 Subject: [PATCH 084/206] un and reconstruct UlpSums less. --- Graphics/Slicer/Math/PGA.hs | 55 +++++++++++++++++-------------------- 1 file changed, 25 insertions(+), 30 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index f2c2963d1..a440b8864 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -350,7 +350,7 @@ pLineIntersectsLineSeg (pl1, pl1Err) l1 ulpScale | res == PAntiParallel = Right PAntiParallel | res == PCollinear = Right PCollinear | res == PAntiCollinear = Right PAntiCollinear - | hasRawIntersection && distance (startPoint l1) (endPoint l1) < realToFrac (startDistanceErr+endDistanceErr) = error $ "cannot resolve endpoints of segment: " <> show l1 <> "\nulpScale: " <> show ulpScale <> "\nrawIntersect" <> show rawIntersect <> dumpULPs + | hasRawIntersection && distance (startPoint l1) (endPoint l1) < realToFrac (ulpVal $ startDistanceErr <> endDistanceErr) = error $ "cannot resolve endpoints of segment: " <> show l1 <> "\nulpScale: " <> show ulpScale <> "\nrawIntersect" <> show rawIntersect <> dumpULPs | hasIntersection && valOf 0 foundVal == 0 = error "intersection, but cannot cannonicalize." | hasIntersection && startDistance <= ulpStartSum = Left $ HitStartPoint l1 | hasIntersection && endDistance <= ulpEndSum = Left $ HitEndPoint l1 @@ -359,18 +359,18 @@ pLineIntersectsLineSeg (pl1, pl1Err) l1 ulpScale | otherwise = Left $ NoIntersection ((\(PPoint2 v) -> CPPoint2 v) rawIntersect) (pl1Err, pl2Err, mempty, rawIntersectErr) where res = plinesIntersectIn (pl1, pl1Err) (pl2, pl2Err) - (startDistance, (_,_,UlpSum startDistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (start,mempty) - (endDistance, (_,_,UlpSum endDistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (end,mempty) + (startDistance, (_,_, startDistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (start,mempty) + (endDistance, (_,_, endDistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (end,mempty) ulpStartSum, ulpEndSum :: ℝ - ulpStartSum = realToFrac $ startDistanceErr - ulpEndSum = realToFrac $ endDistanceErr + ulpStartSum = realToFrac $ ulpVal startDistanceErr + ulpEndSum = realToFrac $ ulpVal endDistanceErr dumpULPs = "pl1Err: " <> show pl1Err <> "\npl2Err: " <> show pl2Err <> "\nrawIntersectErr: " <> show rawIntersectErr <> "\n" - hasIntersection = hasRawIntersection && onSegment l1 (rawIntersection, rawIntersectionErr) ulpStartSum ulpEndSum + hasIntersection = hasRawIntersection && onSegment l1 (rawIntersection, rawIntersectionErr) startDistanceErr endDistanceErr hasRawIntersection = valOf 0 foundVal /= 0 rawIntersectionErr = rawIntersectErr <> cRawIntersectErr (rawIntersection, cRawIntersectErr) = canonicalizeP rawIntersect pl2Err = pl2ErrOrigin <> npl2Err - foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(PPoint2 (GVec vals)) -> vals) rawIntersect + foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(GVec vals) -> vals) $ vecOfP rawIntersect (rawIntersect, (_,npl2Err,rawIntersectErr)) = intersect2PL pl1 pl2 start = eToPPoint2 $ startPoint l1 end = eToPPoint2 $ endPoint l1 @@ -381,31 +381,26 @@ lineSegIntersectsLineSeg :: LineSeg -> LineSeg -> Either Intersection PIntersect lineSegIntersectsLineSeg l1 l2 | res == PParallel = Right PParallel | res == PAntiParallel = Right PAntiParallel - | hasRawIntersection && distance (startPoint l1) (endPoint l1) < realToFrac (start1DistanceErr+end1DistanceErr) = error $ "cannot resolve endpoints of segment: " <> show l1 <> "\nrawIntersection" <> show rawIntersection <> dumpULPs - | hasRawIntersection && distance (startPoint l2) (endPoint l2) < realToFrac (start2DistanceErr+end2DistanceErr) = error $ "cannot resolve endpoints of segment: " <> show l1 <> "\nrawIntersection" <> show rawIntersection <> dumpULPs + | hasRawIntersection && distance (startPoint l1) (endPoint l1) < realToFrac (ulpVal $ start1DistanceErr <> end1DistanceErr) = error $ "cannot resolve endpoints of segment: " <> show l1 <> "\nrawIntersection" <> show rawIntersection <> dumpULPs + | hasRawIntersection && distance (startPoint l2) (endPoint l2) < realToFrac (ulpVal $ start2DistanceErr <> end2DistanceErr) = error $ "cannot resolve endpoints of segment: " <> show l1 <> "\nrawIntersection" <> show rawIntersection <> dumpULPs | hasIntersection && res == PCollinear = Right PCollinear | hasIntersection && res == PAntiCollinear = Right PAntiCollinear -- FIXME: why do we return a start/endpoint here? - | hasIntersection && start1Distance <= ulpStartSum1 = Left $ HitStartPoint l1 - | hasIntersection && end1Distance <= ulpEndSum1 = Left $ HitEndPoint l1 - | hasIntersection && start2Distance <= ulpStartSum2 = Left $ HitStartPoint l2 - | hasIntersection && end2Distance <= ulpEndSum2 = Left $ HitEndPoint l2 + | hasIntersection && start1Distance <= realToFrac (ulpVal start1DistanceErr) = Left $ HitStartPoint l1 + | hasIntersection && end1Distance <= realToFrac (ulpVal end1DistanceErr) = Left $ HitEndPoint l1 + | hasIntersection && start2Distance <= realToFrac (ulpVal start2DistanceErr) = Left $ HitStartPoint l2 + | hasIntersection && end2Distance <= realToFrac (ulpVal end2DistanceErr) = Left $ HitEndPoint l2 | hasIntersection = Right $ IntersectsIn rawIntersection (pl1Err, pl2Err, mempty, rawIntersectionErr) | hasRawIntersection = Left $ NoIntersection rawIntersection (pl1Err, pl2Err, mempty, rawIntersectionErr) | otherwise = Left $ NoIntersection ((\(PPoint2 v) -> CPPoint2 v) rawIntersect) (pl1Err, pl2Err, mempty, rawIntersectErr) where res = plinesIntersectIn (pl1, pl1Err) (pl2, pl2Err) - ulpStartSum1, ulpEndSum1, ulpStartSum2, ulpEndSum2 :: ℝ - ulpStartSum1 = realToFrac $ start1DistanceErr - ulpStartSum2 = realToFrac $ start2DistanceErr - ulpEndSum1 = 0 - ulpEndSum2 = 0 - (start1Distance, (_,_,UlpSum start1DistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (start1, mempty) - (start2Distance, (_,_,UlpSum start2DistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (start2, mempty) - (end1Distance, (_,_,UlpSum end1DistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (end1, mempty) - (end2Distance, (_,_,UlpSum end2DistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (end2, mempty) + (start1Distance, (_,_, start1DistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (start1, mempty) + (start2Distance, (_,_, start2DistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (start2, mempty) + (end1Distance, (_,_, end1DistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (end1, mempty) + (end2Distance, (_,_, end2DistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (end2, mempty) dumpULPs = "pl1Err: " <> show pl1Err <> "\npl2Err: " <> show pl2Err <> "\nrawIntersectionErr: " <> show rawIntersectionErr <> "\n" - hasIntersection = hasRawIntersection && onSegment l1 (rawIntersection,rawIntersectionErr) ulpStartSum1 ulpEndSum1 && onSegment l2 (rawIntersection,rawIntersectionErr) ulpStartSum2 ulpEndSum2 + hasIntersection = hasRawIntersection && onSegment l1 (rawIntersection,rawIntersectionErr) start1DistanceErr end1DistanceErr && onSegment l2 (rawIntersection,rawIntersectionErr) start2DistanceErr end1DistanceErr hasRawIntersection = valOf 0 foundVal /= 0 (rawIntersection, (_, _, rawIntersectionErr)) = fromJust canonicalizedIntersection canonicalizedIntersection = canonicalizedIntersectionOf2PL pl1 pl2 @@ -421,7 +416,7 @@ lineSegIntersectsLineSeg l1 l2 (pl2, pl2ErrOrigin) = eToPL l2 -- | Given the result of intersectionPoint, find out whether this intersection point is on the given segment, or not. -onSegment :: LineSeg -> (CPPoint2, PPoint2Err) -> ℝ -> ℝ -> Bool +onSegment :: LineSeg -> (CPPoint2, PPoint2Err) -> UlpSum -> UlpSum -> Bool onSegment ls i startUlp endUlp = (startDistance <= startFudgeFactor) || (midDistance <= (lengthOfSegment/2) + midFudgeFactor) @@ -430,14 +425,14 @@ onSegment ls i startUlp endUlp = start = eToPPoint2 $ startPoint ls (mid, (_, _, midErr)) = interpolate2PP start end 0.5 0.5 end = eToPPoint2 $ endPoint ls - (startDistance, (_,_,UlpSum startDistanceErr)) = distance2PP i (start, mempty) - (midDistance, (_,_,UlpSum midDistanceErr)) = distance2PP i (mid, midErr) - (endDistance, (_,_,UlpSum endDistanceErr)) = distance2PP i (end, mempty) + (startDistance, (_,_, startDistanceErr)) = distance2PP i (start, mempty) + (midDistance, (_,_, midDistanceErr)) = distance2PP i (mid, midErr) + (endDistance, (_,_, endDistanceErr)) = distance2PP i (end, mempty) lengthOfSegment = distance (startPoint ls) (endPoint ls) startFudgeFactor, midFudgeFactor, endFudgeFactor :: ℝ - startFudgeFactor = realToFrac $ realToFrac startUlp + startDistanceErr - midFudgeFactor = realToFrac $ abs (realToFrac $ doubleUlp lengthOfSegment) + midDistanceErr - endFudgeFactor = realToFrac $ realToFrac endUlp + endDistanceErr + startFudgeFactor = realToFrac $ ulpVal $ startDistanceErr <> startUlp + midFudgeFactor = realToFrac $ ulpVal $ midDistanceErr <> UlpSum (realToFrac $ doubleUlp lengthOfSegment) + endFudgeFactor = realToFrac $ ulpVal $ endDistanceErr <> endUlp -- | Combine consecutive line segments. expects line segments with their end points connecting, EG, a contour generated by makeContours. combineConsecutiveLineSegs :: [LineSeg] -> [LineSeg] From b92b6bfa5f88422dce70babb0e1b49cc11e74987 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 20 Nov 2022 02:59:08 +0000 Subject: [PATCH 085/206] skip valOf 0, use isJust instead. --- Graphics/Slicer/Math/PGA.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index a440b8864..34926c5bf 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -73,7 +73,7 @@ module Graphics.Slicer.Math.PGA( translateRotatePPoint2WithErr ) where -import Prelude (Bool, Eq((==),(/=)), Monoid(mempty), Semigroup((<>)), Show(show), ($), (*), (-), (>=), (&&), (<$>), otherwise, signum, (>), (<=), (+), negate, (/), (||), (<), abs, error, sin, cos, realToFrac) +import Prelude (Bool, Eq((==)), Monoid(mempty), Semigroup((<>)), Show(show), ($), (*), (-), (>=), (&&), (<$>), otherwise, signum, (>), (<=), (+), negate, (/), (||), (<), abs, error, sin, cos, realToFrac) import Data.Bits.Floating.Ulp (doubleUlp) @@ -83,7 +83,7 @@ import Data.List (foldl') import Data.List.Ordered (foldt) -import Data.Maybe (Maybe(Just, Nothing), fromJust, isNothing, maybeToList) +import Data.Maybe (Maybe(Just, Nothing), fromJust, isJust, isNothing, maybeToList) import Data.Set (singleton, fromList) @@ -366,7 +366,7 @@ pLineIntersectsLineSeg (pl1, pl1Err) l1 ulpScale ulpEndSum = realToFrac $ ulpVal endDistanceErr dumpULPs = "pl1Err: " <> show pl1Err <> "\npl2Err: " <> show pl2Err <> "\nrawIntersectErr: " <> show rawIntersectErr <> "\n" hasIntersection = hasRawIntersection && onSegment l1 (rawIntersection, rawIntersectionErr) startDistanceErr endDistanceErr - hasRawIntersection = valOf 0 foundVal /= 0 + hasRawIntersection = isJust foundVal rawIntersectionErr = rawIntersectErr <> cRawIntersectErr (rawIntersection, cRawIntersectErr) = canonicalizeP rawIntersect pl2Err = pl2ErrOrigin <> npl2Err @@ -401,7 +401,7 @@ lineSegIntersectsLineSeg l1 l2 (end2Distance, (_,_, end2DistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (end2, mempty) dumpULPs = "pl1Err: " <> show pl1Err <> "\npl2Err: " <> show pl2Err <> "\nrawIntersectionErr: " <> show rawIntersectionErr <> "\n" hasIntersection = hasRawIntersection && onSegment l1 (rawIntersection,rawIntersectionErr) start1DistanceErr end1DistanceErr && onSegment l2 (rawIntersection,rawIntersectionErr) start2DistanceErr end1DistanceErr - hasRawIntersection = valOf 0 foundVal /= 0 + hasRawIntersection = isJust foundVal (rawIntersection, (_, _, rawIntersectionErr)) = fromJust canonicalizedIntersection canonicalizedIntersection = canonicalizedIntersectionOf2PL pl1 pl2 pl1Err = pl1ErrOrigin <> npl1Err From 08d5061b038aebd09b963904f4adb81e167e2d36 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 20 Nov 2022 13:02:57 +0000 Subject: [PATCH 086/206] move ulpScale haanndling into pLineIntersectsLineSeg. --- Graphics/Slicer/Math/PGA.hs | 27 ++++++++++----------------- 1 file changed, 10 insertions(+), 17 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 34926c5bf..fdeb3206a 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -305,7 +305,7 @@ outputIntersectsLineSeg :: (Arcable a) => a -> LineSeg -> Either Intersection PI outputIntersectsLineSeg source l1 -- handle the case where a segment that is an input to the node is checked against. | isNothing canonicalizedIntersection = Right $ plinesIntersectIn (pl1, pl1Err) (pl2, pl2Err) - | otherwise = pLineIntersectsLineSeg (pl1, pl1Err) l1 1 + | otherwise = pLineIntersectsLineSeg (pl1, pl1Err) l1 where (pl2, pl2Err) = eToPL l1 (pl1, pl1Err) = outAndErrOf source @@ -328,24 +328,14 @@ ulpMultiplier = 570 -- entry point usable for all intersection needs, complete with passed in error values. intersectsWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => Either LineSeg (a, PLine2Err) -> Either LineSeg (b, PLine2Err) -> Either Intersection PIntersection -intersectsWithErr (Left l1) (Left l2) = lineSegIntersectsLineSeg l1 l2 -intersectsWithErr (Right pl1) (Right pl2) = Right $ plinesIntersectIn pl1 pl2 -intersectsWithErr (Left l1) (Right pl1@(rawPL1, _)) = pLineIntersectsLineSeg pl1 l1 ulpScale - where - ulpScale :: ℝ - ulpScale = realToFrac $ ulpMultiplier * (abs (realToFrac angle) + angleErr) - (angle, (_,_, UlpSum angleErr)) = angleBetween2PL rawPL1 pl2 - (pl2, _) = eToPL l1 -intersectsWithErr (Right pl1@(rawPL1, _)) (Left l1) = pLineIntersectsLineSeg pl1 l1 ulpScale - where - ulpScale :: ℝ - ulpScale = realToFrac $ ulpMultiplier * (abs (realToFrac angle) + angleErr) - (angle, (_,_, UlpSum angleErr)) = angleBetween2PL rawPL1 pl2 - (pl2, _) = eToPL l1 +intersectsWithErr (Left l1) (Left l2) = lineSegIntersectsLineSeg l1 l2 +intersectsWithErr (Right pl1) (Right pl2) = Right $ plinesIntersectIn pl1 pl2 +intersectsWithErr (Left l1) (Right pl1) = pLineIntersectsLineSeg pl1 l1 +intersectsWithErr (Right pl1) (Left l1) = pLineIntersectsLineSeg pl1 l1 -- | Check if/where a line segment and a PLine intersect. -pLineIntersectsLineSeg :: (ProjectiveLine2 a) => (a, PLine2Err) -> LineSeg -> ℝ -> Either Intersection PIntersection -pLineIntersectsLineSeg (pl1, pl1Err) l1 ulpScale +pLineIntersectsLineSeg :: (ProjectiveLine2 a) => (a, PLine2Err) -> LineSeg -> Either Intersection PIntersection +pLineIntersectsLineSeg (pl1, pl1Err) l1 | res == PParallel = Right PParallel | res == PAntiParallel = Right PAntiParallel | res == PCollinear = Right PCollinear @@ -369,6 +359,9 @@ pLineIntersectsLineSeg (pl1, pl1Err) l1 ulpScale hasRawIntersection = isJust foundVal rawIntersectionErr = rawIntersectErr <> cRawIntersectErr (rawIntersection, cRawIntersectErr) = canonicalizeP rawIntersect + ulpScale :: ℝ + ulpScale = realToFrac $ ulpMultiplier * (abs (realToFrac angle) + angleErr) + (angle, (_,_, UlpSum angleErr)) = angleBetween2PL pl1 pl2 pl2Err = pl2ErrOrigin <> npl2Err foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(GVec vals) -> vals) $ vecOfP rawIntersect (rawIntersect, (_,npl2Err,rawIntersectErr)) = intersect2PL pl1 pl2 From be9a70f34391444ca4a1e8a834411f505c9df571 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 20 Nov 2022 14:47:55 +0000 Subject: [PATCH 087/206] add normalization error to pl1Err, and remove test for logically impossible condition. --- Graphics/Slicer/Math/PGA.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index fdeb3206a..90c682159 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -335,13 +335,12 @@ intersectsWithErr (Right pl1) (Left l1) = pLineIntersectsLineSeg pl1 l -- | Check if/where a line segment and a PLine intersect. pLineIntersectsLineSeg :: (ProjectiveLine2 a) => (a, PLine2Err) -> LineSeg -> Either Intersection PIntersection -pLineIntersectsLineSeg (pl1, pl1Err) l1 +pLineIntersectsLineSeg (pl1, pl1ErrOrigin) l1 | res == PParallel = Right PParallel | res == PAntiParallel = Right PAntiParallel | res == PCollinear = Right PCollinear | res == PAntiCollinear = Right PAntiCollinear | hasRawIntersection && distance (startPoint l1) (endPoint l1) < realToFrac (ulpVal $ startDistanceErr <> endDistanceErr) = error $ "cannot resolve endpoints of segment: " <> show l1 <> "\nulpScale: " <> show ulpScale <> "\nrawIntersect" <> show rawIntersect <> dumpULPs - | hasIntersection && valOf 0 foundVal == 0 = error "intersection, but cannot cannonicalize." | hasIntersection && startDistance <= ulpStartSum = Left $ HitStartPoint l1 | hasIntersection && endDistance <= ulpEndSum = Left $ HitEndPoint l1 | hasIntersection = Right $ IntersectsIn rawIntersection (pl1Err, pl2Err, mempty, rawIntersectionErr) @@ -362,9 +361,10 @@ pLineIntersectsLineSeg (pl1, pl1Err) l1 ulpScale :: ℝ ulpScale = realToFrac $ ulpMultiplier * (abs (realToFrac angle) + angleErr) (angle, (_,_, UlpSum angleErr)) = angleBetween2PL pl1 pl2 + pl1Err = pl1ErrOrigin <> npl1Err pl2Err = pl2ErrOrigin <> npl2Err foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(GVec vals) -> vals) $ vecOfP rawIntersect - (rawIntersect, (_,npl2Err,rawIntersectErr)) = intersect2PL pl1 pl2 + (rawIntersect, (npl1Err, npl2Err, rawIntersectErr)) = intersect2PL pl1 pl2 start = eToPPoint2 $ startPoint l1 end = eToPPoint2 $ endPoint l1 (pl2, pl2ErrOrigin) = eToPL l1 From 6b22be859c483f6eab95a92ccf559acd9c043ad9 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 20 Nov 2022 22:23:29 +0000 Subject: [PATCH 088/206] reduce the number of values returned as part of an IntersectsIn, or a NoIntersection. --- Graphics/Slicer/Math/Contour.hs | 2 +- Graphics/Slicer/Math/Intersections.hs | 4 ++-- Graphics/Slicer/Math/PGA.hs | 27 ++++++++++++++------------- Graphics/Slicer/Math/PGAPrimitives.hs | 24 ++++++++++++++---------- 4 files changed, 31 insertions(+), 26 deletions(-) diff --git a/Graphics/Slicer/Math/Contour.hs b/Graphics/Slicer/Math/Contour.hs index 8360418f0..d38309132 100644 --- a/Graphics/Slicer/Math/Contour.hs +++ b/Graphics/Slicer/Math/Contour.hs @@ -52,7 +52,7 @@ import Graphics.Slicer.Math.Intersections (contourIntersectionCount, noIntersect import Graphics.Slicer.Math.Lossy (join2PPoint2, pPointBetweenPPoints, pToEPoint2) -import Graphics.Slicer.Math.PGA (ProjectivePoint2, PPoint2, eToPPoint2, eToPL, join2PP, pLineIsLeft, pPointOnPerpWithErr) +import Graphics.Slicer.Math.PGA (PPoint2, eToPPoint2, eToPL, join2PP, pLineIsLeft, pPointOnPerpWithErr) -- Unapologetically ripped from ImplicitCAD. -- Added the ability to look at line segments backwards. diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index 8f44597b9..ae9df4294 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -188,7 +188,7 @@ intersectionOf pl1 pl2 = saneIntersection $ plinesIntersectIn (pl1,mempty) (pl2, saneIntersection PCollinear = error $ "cannot get the intersection of collinear lines.\npl1: " <> show pl1 <> "\npl2: " <> show pl2 <> "\n" saneIntersection PParallel = error $ "cannot get the intersection of parallel lines.\npl1: " <> show pl1 <> "\npl2: " <> show pl2 <> "\n" saneIntersection PAntiParallel = error $ "cannot get the intersection of antiparallel lines.\npl1: " <> show pl1 <> "\npl2: " <> show pl2 <> "\n" - saneIntersection (IntersectsIn p (_,_,_,pErr)) = (p,pErr) + saneIntersection (IntersectsIn p (_,_, pErr)) = (p,pErr) -- | Get the intersection point of two lines. intersectionBetween :: PLine2 -> PLine2 -> Maybe (Either PLine2 (CPPoint2, PPoint2Err)) @@ -203,7 +203,7 @@ intersectionBetween pl1 pl2 = saneIntersection $ plinesIntersectIn (pl1,mempty) saneIntersection PAntiParallel = if foundDistance < realToFrac foundErr then Just $ Left pl1 else Nothing - saneIntersection (IntersectsIn p (_,_,_,pErr)) = Just $ Right (p,pErr) + saneIntersection (IntersectsIn p (_,_, pErr)) = Just $ Right (p,pErr) -- | check if two lines cannot intersect. noIntersection :: PLine2 -> PLine2 -> Bool diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 90c682159..8e300e681 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -113,7 +113,7 @@ data PIntersection = | PAntiCollinear | PParallel | PAntiParallel - | IntersectsIn !CPPoint2 !(PLine2Err, PLine2Err, UlpSum, PPoint2Err) + | IntersectsIn !CPPoint2 !(PLine2Err, PLine2Err, PPoint2Err) deriving (Show, Eq) -- | Determine the intersection point of two projective lines, if applicable. Otherwise, classify the relationship between the two line segments. @@ -131,7 +131,7 @@ plinesIntersectIn (pl1, pl1Err) (pl2, pl2Err) | oppositeDirection pl1 pl2 = if d < parallelFuzziness then PAntiCollinear else PAntiParallel - | otherwise = IntersectsIn res (pl1Err <> npl1Err, pl2Err <> npl2Err, idnErr, resErr) + | otherwise = IntersectsIn res (pl1Err <> npl1Err, pl2Err <> npl2Err, resErr) where -- | The distance within which we consider (anti)parallel lines to be (anti)colinear. parallelFuzziness :: ℝ @@ -317,7 +317,7 @@ outputIntersectsLineSeg source l1 -- | Intersection events that can only happen with line segments. data Intersection = - NoIntersection !CPPoint2 !(PLine2Err, PLine2Err, UlpSum, PPoint2Err) + NoIntersection !CPPoint2 !(PLine2Err, PLine2Err, PPoint2Err) | HitStartPoint !LineSeg | HitEndPoint !LineSeg deriving Show @@ -326,7 +326,7 @@ data Intersection = ulpMultiplier :: Rounded 'TowardInf ℝ ulpMultiplier = 570 --- entry point usable for all intersection needs, complete with passed in error values. +-- | Entry point usable for common intersection needs, complete with passed in error values. intersectsWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => Either LineSeg (a, PLine2Err) -> Either LineSeg (b, PLine2Err) -> Either Intersection PIntersection intersectsWithErr (Left l1) (Left l2) = lineSegIntersectsLineSeg l1 l2 intersectsWithErr (Right pl1) (Right pl2) = Right $ plinesIntersectIn pl1 pl2 @@ -343,9 +343,9 @@ pLineIntersectsLineSeg (pl1, pl1ErrOrigin) l1 | hasRawIntersection && distance (startPoint l1) (endPoint l1) < realToFrac (ulpVal $ startDistanceErr <> endDistanceErr) = error $ "cannot resolve endpoints of segment: " <> show l1 <> "\nulpScale: " <> show ulpScale <> "\nrawIntersect" <> show rawIntersect <> dumpULPs | hasIntersection && startDistance <= ulpStartSum = Left $ HitStartPoint l1 | hasIntersection && endDistance <= ulpEndSum = Left $ HitEndPoint l1 - | hasIntersection = Right $ IntersectsIn rawIntersection (pl1Err, pl2Err, mempty, rawIntersectionErr) - | hasRawIntersection = Left $ NoIntersection rawIntersection (pl1Err, pl2Err, mempty, rawIntersectionErr) - | otherwise = Left $ NoIntersection ((\(PPoint2 v) -> CPPoint2 v) rawIntersect) (pl1Err, pl2Err, mempty, rawIntersectErr) + | hasIntersection = Right $ IntersectsIn rawIntersection (pl1Err, pl2Err, rawIntersectionErr) + | hasRawIntersection = Left $ NoIntersection rawIntersection (pl1Err, pl2Err, rawIntersectionErr) + | otherwise = Left $ NoIntersection ((\(PPoint2 v) -> CPPoint2 v) rawIntersect) (pl1Err, pl2Err, rawIntersectErr) where res = plinesIntersectIn (pl1, pl1Err) (pl2, pl2Err) (startDistance, (_,_, startDistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (start,mempty) @@ -353,7 +353,6 @@ pLineIntersectsLineSeg (pl1, pl1ErrOrigin) l1 ulpStartSum, ulpEndSum :: ℝ ulpStartSum = realToFrac $ ulpVal startDistanceErr ulpEndSum = realToFrac $ ulpVal endDistanceErr - dumpULPs = "pl1Err: " <> show pl1Err <> "\npl2Err: " <> show pl2Err <> "\nrawIntersectErr: " <> show rawIntersectErr <> "\n" hasIntersection = hasRawIntersection && onSegment l1 (rawIntersection, rawIntersectionErr) startDistanceErr endDistanceErr hasRawIntersection = isJust foundVal rawIntersectionErr = rawIntersectErr <> cRawIntersectErr @@ -368,6 +367,7 @@ pLineIntersectsLineSeg (pl1, pl1ErrOrigin) l1 start = eToPPoint2 $ startPoint l1 end = eToPPoint2 $ endPoint l1 (pl2, pl2ErrOrigin) = eToPL l1 + dumpULPs = "pl1Err: " <> show pl1Err <> "\npl2Err: " <> show pl2Err <> "\nrawIntersectErr: " <> show rawIntersectErr <> "\n" -- | Check if/where two line segments intersect. lineSegIntersectsLineSeg :: LineSeg -> LineSeg -> Either Intersection PIntersection @@ -383,17 +383,17 @@ lineSegIntersectsLineSeg l1 l2 | hasIntersection && end1Distance <= realToFrac (ulpVal end1DistanceErr) = Left $ HitEndPoint l1 | hasIntersection && start2Distance <= realToFrac (ulpVal start2DistanceErr) = Left $ HitStartPoint l2 | hasIntersection && end2Distance <= realToFrac (ulpVal end2DistanceErr) = Left $ HitEndPoint l2 - | hasIntersection = Right $ IntersectsIn rawIntersection (pl1Err, pl2Err, mempty, rawIntersectionErr) - | hasRawIntersection = Left $ NoIntersection rawIntersection (pl1Err, pl2Err, mempty, rawIntersectionErr) - | otherwise = Left $ NoIntersection ((\(PPoint2 v) -> CPPoint2 v) rawIntersect) (pl1Err, pl2Err, mempty, rawIntersectErr) + | hasIntersection = Right $ IntersectsIn rawIntersection (pl1Err, pl2Err, rawIntersectionErr) + | hasRawIntersection = Left $ NoIntersection rawIntersection (pl1Err, pl2Err, rawIntersectionErr) + | otherwise = Left $ NoIntersection ((\(PPoint2 v) -> CPPoint2 v) rawIntersect) (pl1Err, pl2Err, rawIntersectErr) where res = plinesIntersectIn (pl1, pl1Err) (pl2, pl2Err) (start1Distance, (_,_, start1DistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (start1, mempty) (start2Distance, (_,_, start2DistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (start2, mempty) (end1Distance, (_,_, end1DistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (end1, mempty) (end2Distance, (_,_, end2DistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (end2, mempty) - dumpULPs = "pl1Err: " <> show pl1Err <> "\npl2Err: " <> show pl2Err <> "\nrawIntersectionErr: " <> show rawIntersectionErr <> "\n" - hasIntersection = hasRawIntersection && onSegment l1 (rawIntersection,rawIntersectionErr) start1DistanceErr end1DistanceErr && onSegment l2 (rawIntersection,rawIntersectionErr) start2DistanceErr end1DistanceErr + hasIntersection = hasRawIntersection && hitSegment + hitSegment = onSegment l1 (rawIntersection,rawIntersectionErr) start1DistanceErr end1DistanceErr && onSegment l2 (rawIntersection,rawIntersectionErr) start2DistanceErr end1DistanceErr hasRawIntersection = isJust foundVal (rawIntersection, (_, _, rawIntersectionErr)) = fromJust canonicalizedIntersection canonicalizedIntersection = canonicalizedIntersectionOf2PL pl1 pl2 @@ -407,6 +407,7 @@ lineSegIntersectsLineSeg l1 l2 end2 = eToPPoint2 $ endPoint l2 (pl1, pl1ErrOrigin) = eToPL l1 (pl2, pl2ErrOrigin) = eToPL l2 + dumpULPs = "pl1Err: " <> show pl1Err <> "\npl2Err: " <> show pl2Err <> "\nrawIntersectionErr: " <> show rawIntersectionErr <> "\n" -- | Given the result of intersectionPoint, find out whether this intersection point is on the given segment, or not. onSegment :: LineSeg -> (CPPoint2, PPoint2Err) -> UlpSum -> UlpSum -> Bool diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index 9af64076c..d75dc0c78 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -366,17 +366,17 @@ translateL l d = translateProjectiveLine l d ----------------------------------------- -- | When given a projective line, return the maximum distance between a projective point known to be on the line and the equivalent point on the 'real' line, which is to say, the projective line without floating point error. --- FIXME: accept a error on the projectivePoint, and return an error estimate. +-- Note: We do not add fuzzinessOfL (nPLine, nPLineErr) here, so you have to add it to this result to get a full value. pLineErrAtPPoint :: (ProjectiveLine2 a, ProjectivePoint2 b) => (a, PLine2Err) -> b -> UlpSum pLineErrAtPPoint (line, lineErr) errPoint -- Both intercepts are real. This line is not parallel or collinear to X or Y axises, and does not pass through the origin. - | xInterceptIsRight && yInterceptIsRight = tFuzz <> xInterceptFuzz <> yInterceptFuzz + | xInterceptIsRight && yInterceptIsRight = xInterceptFuzz <> yInterceptFuzz -- Only the xIntercept is real. This line is parallel to the Y axis. - | xInterceptIsRight = tFuzz <> rawXInterceptFuzz + | xInterceptIsRight = rawXInterceptFuzz -- Only the yIntercept is real. This line is parallel to the X axis. - | yInterceptIsRight = tFuzz <> rawYInterceptFuzz + | yInterceptIsRight = rawYInterceptFuzz -- This line passes through the origin (0,0). - | otherwise = tFuzz + | otherwise = mempty where xInterceptIsRight = isJust (xIntercept (nPLine, nPLineErr)) && isRight (fst $ fromJust $ xIntercept (nPLine, nPLineErr)) @@ -384,13 +384,17 @@ pLineErrAtPPoint (line, lineErr) errPoint yInterceptIsRight = isJust (yIntercept (nPLine, nPLineErr)) && isRight (fst $ fromJust $ yIntercept (nPLine, nPLineErr)) && fromRight 0 (fst $ fromJust $ yIntercept (nPLine, nPLineErr)) /= 0 - xInterceptFuzz = UlpSum $ ulpVal rawXInterceptFuzz * ((realToFrac xInterceptDistance + ulpVal rawXInterceptFuzz) / realToFrac yInterceptDistance) * realToFrac (abs xPos) - yInterceptFuzz = UlpSum $ ulpVal rawYInterceptFuzz * ((realToFrac yInterceptDistance + ulpVal rawYInterceptFuzz) / realToFrac xInterceptDistance) * realToFrac (abs yPos) + xInterceptFuzz = UlpSum $ ulpVal rawXInterceptFuzz * ( realToFrac $ xMax / (sqrt (xMin*xMin*yMax*yMax))) * realToFrac (abs xPos) + yInterceptFuzz = UlpSum $ ulpVal rawYInterceptFuzz * ( realToFrac $ yMax / (sqrt (xMax*xMax*yMin*yMin))) * realToFrac (abs yPos) + xMin, xMax, yMin, yMax :: ℝ + xMax = xInterceptDistance + realToFrac (ulpVal rawXInterceptFuzz) + yMax = yInterceptDistance + realToFrac (ulpVal rawYInterceptFuzz) + xMin = xInterceptDistance + yMin = yInterceptDistance rawYInterceptFuzz = snd $ fromJust $ yIntercept (nPLine, nPLineErr) rawXInterceptFuzz = snd $ fromJust $ xIntercept (nPLine, nPLineErr) - yInterceptDistance = fromRight 0 $ fst $ fromJust $ xIntercept (nPLine, nPLineErr) - xInterceptDistance = fromRight 0 $ fst $ fromJust $ xIntercept (nPLine, nPLineErr) - tFuzz = fuzzinessOfL (nPLine, nPLineErr) + yInterceptDistance = abs $ fromRight 0 $ fst $ fromJust $ xIntercept (nPLine, nPLineErr) + xInterceptDistance = abs $ fromRight 0 $ fst $ fromJust $ xIntercept (nPLine, nPLineErr) -- FIXME: collect this error, and take it into account. (Point2 (xPos,yPos),_) = pToEP errPoint nPLineErr = nPLineErrRaw <> lineErr From 12af1cc2ad272aef20675d628f18a8b692949ad7 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 20 Nov 2022 22:48:05 +0000 Subject: [PATCH 089/206] break hitSegment into a separate test, and take fuzzinessOfL into account in more places. --- Graphics/Slicer/Math/PGA.hs | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 8e300e681..7948d1ab8 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -99,7 +99,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (ErrVal, GNum(G0, GEPlus, GEZero), import Graphics.Slicer.Math.Line (combineLineSegs, makeLineSeg) -import Graphics.Slicer.Math.PGAPrimitives(CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(normalizeL, vecOfL), ProjectivePoint2(canonicalizeP, isIdealP, vecOfP), angleBetween2PL, angleCosBetween2PL, canonicalizedIntersectionOf2PL, distance2PL, distance2PP, flipL, forceBasisOfL, forceBasisOfP, fuzzinessOfP, idealNormOfP, interpolate2PP, intersect2PL, join2PP, pLineErrAtPPoint, pToEP, translateL) +import Graphics.Slicer.Math.PGAPrimitives(CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(normalizeL, vecOfL), ProjectivePoint2(canonicalizeP, isIdealP, vecOfP), angleBetween2PL, angleCosBetween2PL, canonicalizedIntersectionOf2PL, distance2PL, distance2PP, flipL, forceBasisOfL, forceBasisOfP, fuzzinessOfL, fuzzinessOfP, idealNormOfP, interpolate2PP, intersect2PL, join2PP, pLineErrAtPPoint, pToEP, translateL) -- Our 2D plane coresponds to a Clifford algebra of 2,0,1. @@ -340,7 +340,7 @@ pLineIntersectsLineSeg (pl1, pl1ErrOrigin) l1 | res == PAntiParallel = Right PAntiParallel | res == PCollinear = Right PCollinear | res == PAntiCollinear = Right PAntiCollinear - | hasRawIntersection && distance (startPoint l1) (endPoint l1) < realToFrac (ulpVal $ startDistanceErr <> endDistanceErr) = error $ "cannot resolve endpoints of segment: " <> show l1 <> "\nulpScale: " <> show ulpScale <> "\nrawIntersect" <> show rawIntersect <> dumpULPs + | hasRawIntersection && hitSegment && distance (startPoint l1) (endPoint l1) < realToFrac (ulpVal $ startDistanceErr <> endDistanceErr <> tFuzz) = error $ "cannot resolve endpoints of segment: " <> show l1 <> "\nulpScale: " <> show ulpScale <> "\nrawIntersect" <> show rawIntersect <> dumpULPs | hasIntersection && startDistance <= ulpStartSum = Left $ HitStartPoint l1 | hasIntersection && endDistance <= ulpEndSum = Left $ HitEndPoint l1 | hasIntersection = Right $ IntersectsIn rawIntersection (pl1Err, pl2Err, rawIntersectionErr) @@ -348,12 +348,14 @@ pLineIntersectsLineSeg (pl1, pl1ErrOrigin) l1 | otherwise = Left $ NoIntersection ((\(PPoint2 v) -> CPPoint2 v) rawIntersect) (pl1Err, pl2Err, rawIntersectErr) where res = plinesIntersectIn (pl1, pl1Err) (pl2, pl2Err) - (startDistance, (_,_, startDistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (start,mempty) - (endDistance, (_,_, endDistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (end,mempty) ulpStartSum, ulpEndSum :: ℝ ulpStartSum = realToFrac $ ulpVal startDistanceErr ulpEndSum = realToFrac $ ulpVal endDistanceErr - hasIntersection = hasRawIntersection && onSegment l1 (rawIntersection, rawIntersectionErr) startDistanceErr endDistanceErr + (startDistance, (_,_, startDistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (start, mempty) + (endDistance, (_,_, endDistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (end, mempty) + tFuzz = fuzzinessOfL (pl2, pl2Err) + hasIntersection = hasRawIntersection && hitSegment + hitSegment = onSegment l1 (rawIntersection, rawIntersectionErr) startDistanceErr endDistanceErr hasRawIntersection = isJust foundVal rawIntersectionErr = rawIntersectErr <> cRawIntersectErr (rawIntersection, cRawIntersectErr) = canonicalizeP rawIntersect @@ -422,11 +424,12 @@ onSegment ls i startUlp endUlp = (startDistance, (_,_, startDistanceErr)) = distance2PP i (start, mempty) (midDistance, (_,_, midDistanceErr)) = distance2PP i (mid, midErr) (endDistance, (_,_, endDistanceErr)) = distance2PP i (end, mempty) + tFuzz = fuzzinessOfL $ eToPL ls lengthOfSegment = distance (startPoint ls) (endPoint ls) startFudgeFactor, midFudgeFactor, endFudgeFactor :: ℝ - startFudgeFactor = realToFrac $ ulpVal $ startDistanceErr <> startUlp - midFudgeFactor = realToFrac $ ulpVal $ midDistanceErr <> UlpSum (realToFrac $ doubleUlp lengthOfSegment) - endFudgeFactor = realToFrac $ ulpVal $ endDistanceErr <> endUlp + startFudgeFactor = realToFrac $ ulpVal $ startDistanceErr <> tFuzz <> startUlp + midFudgeFactor = realToFrac $ ulpVal $ midDistanceErr <> tFuzz <> UlpSum (realToFrac $ doubleUlp lengthOfSegment) + endFudgeFactor = realToFrac $ ulpVal $ endDistanceErr <> tFuzz <> endUlp -- | Combine consecutive line segments. expects line segments with their end points connecting, EG, a contour generated by makeContours. combineConsecutiveLineSegs :: [LineSeg] -> [LineSeg] From 823f7a873ea594d2167a9e5e77190ee473de8138 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 20 Nov 2022 23:47:28 +0000 Subject: [PATCH 090/206] remove ulpMultiplier, rely on pLineErrAtPPoint, and debugging changes. --- Graphics/Slicer/Math/PGA.hs | 65 ++++++++++++++++++++++++++----------- 1 file changed, 46 insertions(+), 19 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 7948d1ab8..10cce5617 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -73,7 +73,7 @@ module Graphics.Slicer.Math.PGA( translateRotatePPoint2WithErr ) where -import Prelude (Bool, Eq((==)), Monoid(mempty), Semigroup((<>)), Show(show), ($), (*), (-), (>=), (&&), (<$>), otherwise, signum, (>), (<=), (+), negate, (/), (||), (<), abs, error, sin, cos, realToFrac) +import Prelude (Bool, Eq((==)), Monoid(mempty), Semigroup((<>)), Show(show), ($), (-), (>=), (&&), (<$>), otherwise, signum, (>), (<=), (+), negate, (/), (||), (<), abs, error, sin, cos, realToFrac) import Data.Bits.Floating.Ulp (doubleUlp) @@ -99,7 +99,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (ErrVal, GNum(G0, GEPlus, GEZero), import Graphics.Slicer.Math.Line (combineLineSegs, makeLineSeg) -import Graphics.Slicer.Math.PGAPrimitives(CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(normalizeL, vecOfL), ProjectivePoint2(canonicalizeP, isIdealP, vecOfP), angleBetween2PL, angleCosBetween2PL, canonicalizedIntersectionOf2PL, distance2PL, distance2PP, flipL, forceBasisOfL, forceBasisOfP, fuzzinessOfL, fuzzinessOfP, idealNormOfP, interpolate2PP, intersect2PL, join2PP, pLineErrAtPPoint, pToEP, translateL) +import Graphics.Slicer.Math.PGAPrimitives(CPPoint2(CPPoint2), NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), PPoint2(PPoint2), PPoint2Err, ProjectiveLine2(normalizeL, vecOfL), ProjectivePoint2(canonicalizeP, isIdealP, vecOfP), angleBetween2PL, angleCosBetween2PL, canonicalizedIntersectionOf2PL, distance2PL, distance2PP, flipL, forceBasisOfL, forceBasisOfP, fuzzinessOfL, fuzzinessOfP, idealNormOfP, interpolate2PP, intersect2PL, join2PP, pLineErrAtPPoint, pToEP, translateL, xIntercept, yIntercept) -- Our 2D plane coresponds to a Clifford algebra of 2,0,1. @@ -322,10 +322,6 @@ data Intersection = | HitEndPoint !LineSeg deriving Show --- FIXME: as long as this is required, we're not accounting for ULP correctly everywhere. -ulpMultiplier :: Rounded 'TowardInf ℝ -ulpMultiplier = 570 - -- | Entry point usable for common intersection needs, complete with passed in error values. intersectsWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => Either LineSeg (a, PLine2Err) -> Either LineSeg (b, PLine2Err) -> Either Intersection PIntersection intersectsWithErr (Left l1) (Left l2) = lineSegIntersectsLineSeg l1 l2 @@ -340,7 +336,7 @@ pLineIntersectsLineSeg (pl1, pl1ErrOrigin) l1 | res == PAntiParallel = Right PAntiParallel | res == PCollinear = Right PCollinear | res == PAntiCollinear = Right PAntiCollinear - | hasRawIntersection && hitSegment && distance (startPoint l1) (endPoint l1) < realToFrac (ulpVal $ startDistanceErr <> endDistanceErr <> tFuzz) = error $ "cannot resolve endpoints of segment: " <> show l1 <> "\nulpScale: " <> show ulpScale <> "\nrawIntersect" <> show rawIntersect <> dumpULPs + | hasRawIntersection && hitSegment && distance (startPoint l1) (endPoint l1) < realToFrac (ulpVal $ startDistanceErr <> endDistanceErr <> tFuzz) = error $ "cannot resolve endpoints of segment: " <> show l1 <> "\n." <> dumpMiss | hasIntersection && startDistance <= ulpStartSum = Left $ HitStartPoint l1 | hasIntersection && endDistance <= ulpEndSum = Left $ HitEndPoint l1 | hasIntersection = Right $ IntersectsIn rawIntersection (pl1Err, pl2Err, rawIntersectionErr) @@ -353,15 +349,16 @@ pLineIntersectsLineSeg (pl1, pl1ErrOrigin) l1 ulpEndSum = realToFrac $ ulpVal endDistanceErr (startDistance, (_,_, startDistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (start, mempty) (endDistance, (_,_, endDistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (end, mempty) + startFudgeFactor = startDistanceErr <> startErr + endFudgeFactor = endDistanceErr <> endErr + startErr = pLineErrAtPPoint (pl2, pl2Err) start + endErr = pLineErrAtPPoint (pl2, pl2Err) end tFuzz = fuzzinessOfL (pl2, pl2Err) hasIntersection = hasRawIntersection && hitSegment hitSegment = onSegment l1 (rawIntersection, rawIntersectionErr) startDistanceErr endDistanceErr hasRawIntersection = isJust foundVal rawIntersectionErr = rawIntersectErr <> cRawIntersectErr (rawIntersection, cRawIntersectErr) = canonicalizeP rawIntersect - ulpScale :: ℝ - ulpScale = realToFrac $ ulpMultiplier * (abs (realToFrac angle) + angleErr) - (angle, (_,_, UlpSum angleErr)) = angleBetween2PL pl1 pl2 pl1Err = pl1ErrOrigin <> npl1Err pl2Err = pl2ErrOrigin <> npl2Err foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(GVec vals) -> vals) $ vecOfP rawIntersect @@ -369,31 +366,53 @@ pLineIntersectsLineSeg (pl1, pl1ErrOrigin) l1 start = eToPPoint2 $ startPoint l1 end = eToPPoint2 $ endPoint l1 (pl2, pl2ErrOrigin) = eToPL l1 - dumpULPs = "pl1Err: " <> show pl1Err <> "\npl2Err: " <> show pl2Err <> "\nrawIntersectErr: " <> show rawIntersectErr <> "\n" + dumpMiss = "startFudgeFactor: " <> show startFudgeFactor <> "\n" + <> "endFudgeFactor: " <> show endFudgeFactor <> "\n" + <> "startDistanceErr: " <> show startDistanceErr <> "\n" + <> "endDistanceErr: " <> show endDistanceErr <> "\n" + <> "startErr: " <> show startErr <> "\n" + <> "endErr: " <> show endErr <> "\n" + <> "pl2: " <> show pl2 <> "\n" + <> "pl2Err: " <> show pl2Err <> "\n" + <> "xIntercept: " <> show (xIntercept (pl2,pl2Err)) <> "\n" + <> "yIntercept: " <> show (yIntercept (pl2,pl2Err)) <> "\n" + <> "tfuzz: " <> show tFuzz <> "\n" -- | Check if/where two line segments intersect. lineSegIntersectsLineSeg :: LineSeg -> LineSeg -> Either Intersection PIntersection lineSegIntersectsLineSeg l1 l2 | res == PParallel = Right PParallel | res == PAntiParallel = Right PAntiParallel - | hasRawIntersection && distance (startPoint l1) (endPoint l1) < realToFrac (ulpVal $ start1DistanceErr <> end1DistanceErr) = error $ "cannot resolve endpoints of segment: " <> show l1 <> "\nrawIntersection" <> show rawIntersection <> dumpULPs - | hasRawIntersection && distance (startPoint l2) (endPoint l2) < realToFrac (ulpVal $ start2DistanceErr <> end2DistanceErr) = error $ "cannot resolve endpoints of segment: " <> show l1 <> "\nrawIntersection" <> show rawIntersection <> dumpULPs + | hasRawIntersection && distance (startPoint l1) (endPoint l1) < realToFrac (ulpVal $ start1FudgeFactor <> end1FudgeFactor <> tFuzz1) = error $ "cannot resolve endpoints of segment: " <> show l1 <> "\n." <> dumpMiss + | hasRawIntersection && distance (startPoint l2) (endPoint l2) < realToFrac (ulpVal $ start2FudgeFactor <> end2FudgeFactor <> tFuzz2) = error $ "cannot resolve endpoints of segment: " <> show l2 <> "\n." <> dumpMiss | hasIntersection && res == PCollinear = Right PCollinear | hasIntersection && res == PAntiCollinear = Right PAntiCollinear - -- FIXME: why do we return a start/endpoint here? - | hasIntersection && start1Distance <= realToFrac (ulpVal start1DistanceErr) = Left $ HitStartPoint l1 - | hasIntersection && end1Distance <= realToFrac (ulpVal end1DistanceErr) = Left $ HitEndPoint l1 - | hasIntersection && start2Distance <= realToFrac (ulpVal start2DistanceErr) = Left $ HitStartPoint l2 - | hasIntersection && end2Distance <= realToFrac (ulpVal end2DistanceErr) = Left $ HitEndPoint l2 + -- FIXME: why do we return a start/endpoi nt here? + | hasIntersection && start1Distance <= ulpStart1Sum = Left $ HitStartPoint l1 + | hasIntersection && end1Distance <= ulpEnd1Sum = Left $ HitEndPoint l1 + | hasIntersection && start2Distance <= ulpStart2Sum = Left $ HitStartPoint l2 + | hasIntersection && end2Distance <= ulpEnd2Sum = Left $ HitEndPoint l2 | hasIntersection = Right $ IntersectsIn rawIntersection (pl1Err, pl2Err, rawIntersectionErr) | hasRawIntersection = Left $ NoIntersection rawIntersection (pl1Err, pl2Err, rawIntersectionErr) | otherwise = Left $ NoIntersection ((\(PPoint2 v) -> CPPoint2 v) rawIntersect) (pl1Err, pl2Err, rawIntersectErr) where res = plinesIntersectIn (pl1, pl1Err) (pl2, pl2Err) + start1FudgeFactor = start1DistanceErr <> pLineErrAtPPoint (pl1,pl1Err) start1 + end1FudgeFactor = end1DistanceErr <> pLineErrAtPPoint (pl1,pl1Err) end1 + start2FudgeFactor = start2DistanceErr <> pLineErrAtPPoint (pl2,pl2Err) start2 + end2FudgeFactor = end2DistanceErr <> pLineErrAtPPoint (pl2,pl2Err) end2 + ulpStart1Sum, ulpEnd1Sum :: ℝ + ulpStart1Sum = realToFrac $ ulpVal start1DistanceErr + ulpEnd1Sum = realToFrac $ ulpVal end1DistanceErr + ulpStart2Sum, ulpEnd2Sum :: ℝ + ulpStart2Sum = realToFrac $ ulpVal start2DistanceErr + ulpEnd2Sum = realToFrac $ ulpVal end2DistanceErr (start1Distance, (_,_, start1DistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (start1, mempty) (start2Distance, (_,_, start2DistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (start2, mempty) (end1Distance, (_,_, end1DistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (end1, mempty) (end2Distance, (_,_, end2DistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (end2, mempty) + tFuzz1 = fuzzinessOfL (pl1, pl1Err) + tFuzz2 = fuzzinessOfL (pl2, pl2Err) hasIntersection = hasRawIntersection && hitSegment hitSegment = onSegment l1 (rawIntersection,rawIntersectionErr) start1DistanceErr end1DistanceErr && onSegment l2 (rawIntersection,rawIntersectionErr) start2DistanceErr end1DistanceErr hasRawIntersection = isJust foundVal @@ -409,7 +428,15 @@ lineSegIntersectsLineSeg l1 l2 end2 = eToPPoint2 $ endPoint l2 (pl1, pl1ErrOrigin) = eToPL l1 (pl2, pl2ErrOrigin) = eToPL l2 - dumpULPs = "pl1Err: " <> show pl1Err <> "\npl2Err: " <> show pl2Err <> "\nrawIntersectionErr: " <> show rawIntersectionErr <> "\n" + dumpMiss = "start2FudgeFactor: " <> show start2FudgeFactor <> "\n" + <> "end2FudgeFactor: " <> show end2FudgeFactor <> "\n" + <> "start2DistanceErr: " <> show start2DistanceErr <> "\n" + <> "end2DistanceErr: " <> show end2DistanceErr <> "\n" + <> "pl2: " <> show pl2 <> "\n" + <> "pl2Err: " <> show pl2Err <> "\n" + <> "xIntercept2: " <> show (xIntercept (pl2,pl2Err)) <> "\n" + <> "yIntercept2: " <> show (yIntercept (pl2,pl2Err)) <> "\n" + <> "tfuzz2: " <> show tFuzz2 <> "\n" -- | Given the result of intersectionPoint, find out whether this intersection point is on the given segment, or not. onSegment :: LineSeg -> (CPPoint2, PPoint2Err) -> UlpSum -> UlpSum -> Bool From 58ed189d09920697a26892c916d264ee2d25b0cd Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Mon, 21 Nov 2022 21:55:00 +0000 Subject: [PATCH 091/206] move distance checking to later, to allow faster paths to complete first. --- Graphics/Slicer/Math/PGA.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 10cce5617..d53789429 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -336,7 +336,7 @@ pLineIntersectsLineSeg (pl1, pl1ErrOrigin) l1 | res == PAntiParallel = Right PAntiParallel | res == PCollinear = Right PCollinear | res == PAntiCollinear = Right PAntiCollinear - | hasRawIntersection && hitSegment && distance (startPoint l1) (endPoint l1) < realToFrac (ulpVal $ startDistanceErr <> endDistanceErr <> tFuzz) = error $ "cannot resolve endpoints of segment: " <> show l1 <> "\n." <> dumpMiss + | hasIntersection && distance (startPoint l1) (endPoint l1) < realToFrac (ulpVal $ startFudgeFactor <> endFudgeFactor <> tFuzz) = error $ "cannot resolve endpoints of segment: " <> show l1 <> ".\n" <> dumpMiss | hasIntersection && startDistance <= ulpStartSum = Left $ HitStartPoint l1 | hasIntersection && endDistance <= ulpEndSum = Left $ HitEndPoint l1 | hasIntersection = Right $ IntersectsIn rawIntersection (pl1Err, pl2Err, rawIntersectionErr) @@ -357,8 +357,8 @@ pLineIntersectsLineSeg (pl1, pl1ErrOrigin) l1 hasIntersection = hasRawIntersection && hitSegment hitSegment = onSegment l1 (rawIntersection, rawIntersectionErr) startDistanceErr endDistanceErr hasRawIntersection = isJust foundVal - rawIntersectionErr = rawIntersectErr <> cRawIntersectErr - (rawIntersection, cRawIntersectErr) = canonicalizeP rawIntersect + (rawIntersection, (_, _, rawIntersectionErr)) = fromJust canonicalizedIntersection + canonicalizedIntersection = canonicalizedIntersectionOf2PL pl1 pl2 pl1Err = pl1ErrOrigin <> npl1Err pl2Err = pl2ErrOrigin <> npl2Err foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(GVec vals) -> vals) $ vecOfP rawIntersect @@ -383,13 +383,12 @@ lineSegIntersectsLineSeg :: LineSeg -> LineSeg -> Either Intersection PIntersect lineSegIntersectsLineSeg l1 l2 | res == PParallel = Right PParallel | res == PAntiParallel = Right PAntiParallel - | hasRawIntersection && distance (startPoint l1) (endPoint l1) < realToFrac (ulpVal $ start1FudgeFactor <> end1FudgeFactor <> tFuzz1) = error $ "cannot resolve endpoints of segment: " <> show l1 <> "\n." <> dumpMiss - | hasRawIntersection && distance (startPoint l2) (endPoint l2) < realToFrac (ulpVal $ start2FudgeFactor <> end2FudgeFactor <> tFuzz2) = error $ "cannot resolve endpoints of segment: " <> show l2 <> "\n." <> dumpMiss | hasIntersection && res == PCollinear = Right PCollinear | hasIntersection && res == PAntiCollinear = Right PAntiCollinear - -- FIXME: why do we return a start/endpoi nt here? + | hasIntersection && distance (startPoint l1) (endPoint l1) < realToFrac (ulpVal $ start1FudgeFactor <> end1FudgeFactor <> tFuzz1) = error $ "cannot resolve endpoints of segment: " <> show l1 <> ".\n" <> dumpMiss | hasIntersection && start1Distance <= ulpStart1Sum = Left $ HitStartPoint l1 | hasIntersection && end1Distance <= ulpEnd1Sum = Left $ HitEndPoint l1 + | hasIntersection && distance (startPoint l2) (endPoint l2) < realToFrac (ulpVal $ start2FudgeFactor <> end2FudgeFactor <> tFuzz2) = error $ "cannot resolve endpoints of segment: " <> show l2 <> ".\n" <> dumpMiss | hasIntersection && start2Distance <= ulpStart2Sum = Left $ HitStartPoint l2 | hasIntersection && end2Distance <= ulpEnd2Sum = Left $ HitEndPoint l2 | hasIntersection = Right $ IntersectsIn rawIntersection (pl1Err, pl2Err, rawIntersectionErr) From 5c7a889d4c42a2f3ed75e664a734feb3dda2329d Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Mon, 21 Nov 2022 22:06:25 +0000 Subject: [PATCH 092/206] use pLineErrAtPPoint in onSegment. --- Graphics/Slicer/Math/PGA.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index d53789429..cbd296afb 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -355,7 +355,7 @@ pLineIntersectsLineSeg (pl1, pl1ErrOrigin) l1 endErr = pLineErrAtPPoint (pl2, pl2Err) end tFuzz = fuzzinessOfL (pl2, pl2Err) hasIntersection = hasRawIntersection && hitSegment - hitSegment = onSegment l1 (rawIntersection, rawIntersectionErr) startDistanceErr endDistanceErr + hitSegment = onSegment l1 (rawIntersection, rawIntersectionErr) hasRawIntersection = isJust foundVal (rawIntersection, (_, _, rawIntersectionErr)) = fromJust canonicalizedIntersection canonicalizedIntersection = canonicalizedIntersectionOf2PL pl1 pl2 @@ -413,7 +413,7 @@ lineSegIntersectsLineSeg l1 l2 tFuzz1 = fuzzinessOfL (pl1, pl1Err) tFuzz2 = fuzzinessOfL (pl2, pl2Err) hasIntersection = hasRawIntersection && hitSegment - hitSegment = onSegment l1 (rawIntersection,rawIntersectionErr) start1DistanceErr end1DistanceErr && onSegment l2 (rawIntersection,rawIntersectionErr) start2DistanceErr end1DistanceErr + hitSegment = onSegment l1 (rawIntersection, rawIntersectionErr) && onSegment l2 (rawIntersection, rawIntersectionErr) hasRawIntersection = isJust foundVal (rawIntersection, (_, _, rawIntersectionErr)) = fromJust canonicalizedIntersection canonicalizedIntersection = canonicalizedIntersectionOf2PL pl1 pl2 @@ -438,8 +438,8 @@ lineSegIntersectsLineSeg l1 l2 <> "tfuzz2: " <> show tFuzz2 <> "\n" -- | Given the result of intersectionPoint, find out whether this intersection point is on the given segment, or not. -onSegment :: LineSeg -> (CPPoint2, PPoint2Err) -> UlpSum -> UlpSum -> Bool -onSegment ls i startUlp endUlp = +onSegment :: LineSeg -> (CPPoint2, PPoint2Err) -> Bool +onSegment ls i = (startDistance <= startFudgeFactor) || (midDistance <= (lengthOfSegment/2) + midFudgeFactor) || (endDistance <= endFudgeFactor) @@ -453,9 +453,9 @@ onSegment ls i startUlp endUlp = tFuzz = fuzzinessOfL $ eToPL ls lengthOfSegment = distance (startPoint ls) (endPoint ls) startFudgeFactor, midFudgeFactor, endFudgeFactor :: ℝ - startFudgeFactor = realToFrac $ ulpVal $ startDistanceErr <> tFuzz <> startUlp - midFudgeFactor = realToFrac $ ulpVal $ midDistanceErr <> tFuzz <> UlpSum (realToFrac $ doubleUlp lengthOfSegment) - endFudgeFactor = realToFrac $ ulpVal $ endDistanceErr <> tFuzz <> endUlp + startFudgeFactor = realToFrac $ ulpVal $ startDistanceErr <> tFuzz <> pLineErrAtPPoint (eToPL ls) start + midFudgeFactor = realToFrac $ ulpVal $ midDistanceErr <> tFuzz <> pLineErrAtPPoint (eToPL ls) mid + endFudgeFactor = realToFrac $ ulpVal $ endDistanceErr <> tFuzz <> pLineErrAtPPoint (eToPL ls) end -- | Combine consecutive line segments. expects line segments with their end points connecting, EG, a contour generated by makeContours. combineConsecutiveLineSegs :: [LineSeg] -> [LineSeg] From abd4f977227f0e806045e07f2b40747fa9850169 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Mon, 21 Nov 2022 23:04:04 +0000 Subject: [PATCH 093/206] label language pragmas better, remove an unused one. re-order and re-format our exports. --- Graphics/Slicer/Math/GeometricAlgebra.hs | 48 ++++++++++++++++++++++-- 1 file changed, 45 insertions(+), 3 deletions(-) diff --git a/Graphics/Slicer/Math/GeometricAlgebra.hs b/Graphics/Slicer/Math/GeometricAlgebra.hs index 3e5f84fe4..aca67746b 100644 --- a/Graphics/Slicer/Math/GeometricAlgebra.hs +++ b/Graphics/Slicer/Math/GeometricAlgebra.hs @@ -16,16 +16,58 @@ - along with this program. If not, see . -} --- for adding Generic and NFData to our types. -{-# LANGUAGE DeriveGeneric, DeriveAnyClass, FlexibleInstances #-} +-- For adding Generic and NFData to our types. +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +-- For TowardInf. {-# LANGUAGE DataKinds #-} -- So we can map applying (,mempty) to a list. {-# LANGUAGE TupleSections #-} -- | Our geometric algebra library. -module Graphics.Slicer.Math.GeometricAlgebra(ErrVal(ErrVal), GNum(G0, GEMinus, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎣+), (⎣), (⎤+), (⎤), (⨅+), (⨅), (•+), (•), (⋅+), (⋅), (∧+), (∧), addErr, addValPairWithErr, addValWithErr, addValWithoutErr, addVecPair, addVecPairWithErr, addVecPairWithoutErr, eValOf, getVal, mulScalarVecWithErr, subVal, subValPairWithErr, subVecPair, sumErrVals, valOf, divVecScalarWithErr, scalarPart, ulpVal, vectorPart, hpDivVecScalar, reduceVecPair, unlikeVecPair) where +module Graphics.Slicer.Math.GeometricAlgebra( + ErrVal(ErrVal), + GNum(G0, GEMinus, GEPlus, GEZero), + GVal(GVal), + GVec(GVec), + UlpSum(UlpSum), + (⎣+), + (⎣), + (⎤+), + (⎤), + (⨅+), + (⨅), + (•+), + (•), + (⋅+), + (⋅), + (∧+), + (∧), + addErr, + addValPairWithErr, + addValWithErr, + addValWithoutErr, + addVecPair, + addVecPairWithErr, + addVecPairWithoutErr, + divVecScalarWithErr, + eValOf, + getVal, + hpDivVecScalar, + mulScalarVecWithErr, + reduceVecPair, + subVal, + subValPairWithErr, + subVecPair, + sumErrVals, + valOf, + scalarPart, + ulpVal, + unlikeVecPair, + vectorPart + ) where import Prelude (Eq, Monoid(mempty), Ord(compare), Semigroup((<>)), Show(show), (==), (/=), (+), fst, otherwise, snd, ($), not, (>), (*), concatMap, (<$>), sum, (&&), (/), Bool(True, False), error, flip, (&&), not, null, realToFrac, abs, (.), realToFrac) From dff7bd4cfb0279bc3fe7bf1697a45ea997bf67ff Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Tue, 22 Nov 2022 22:52:59 +0000 Subject: [PATCH 094/206] make noIntersection and isCollinear accept error quotents, and make noIntersection, isCollinear, isAntiCollinear, isParallel, and isAntiParallel use the ProjectiveLine2 typeclass. --- Graphics/Slicer/Machine/Contour.hs | 6 ++-- Graphics/Slicer/Math/Contour.hs | 30 ++++++++++---------- Graphics/Slicer/Math/Intersections.hs | 22 +++++++------- Graphics/Slicer/Math/PGA.hs | 23 ++++++++------- Graphics/Slicer/Math/Skeleton/Concave.hs | 12 ++++---- Graphics/Slicer/Math/Skeleton/Face.hs | 4 +-- Graphics/Slicer/Math/Skeleton/Motorcycles.hs | 20 +++++++------ 7 files changed, 61 insertions(+), 56 deletions(-) diff --git a/Graphics/Slicer/Machine/Contour.hs b/Graphics/Slicer/Machine/Contour.hs index 726c7a3c7..688541db6 100644 --- a/Graphics/Slicer/Machine/Contour.hs +++ b/Graphics/Slicer/Machine/Contour.hs @@ -19,7 +19,7 @@ module Graphics.Slicer.Machine.Contour (cleanContour, shrinkContour, expandContour) where -import Prelude (($), fst, otherwise, Eq, (<>), show, error, (==), (&&), Bool(True, False), Show) +import Prelude (($), otherwise, Eq, (<>), show, error, (==), (&&), Bool(True, False), Show) import Data.List (null, foldl') @@ -92,13 +92,13 @@ modifyContour pathWidth contour direction [l1,l2] -> [l1,l2] (firstSeg:moreSegs) -> case unsnoc moreSegs of Nothing -> error "impossible." - (Just (middleSegs,lastSeg)) -> if noIntersection (fst $ inwardAdjust lastSeg) (fst $ inwardAdjust firstSeg) + (Just (middleSegs,lastSeg)) -> if noIntersection (inwardAdjust lastSeg) (inwardAdjust firstSeg) then middleSegs <> maybeToList (combineLineSegs lastSeg firstSeg) else inSegs concatDegenerates :: [LineSeg] -> LineSeg -> [LineSeg] concatDegenerates inSegs oneSeg = case unsnoc inSegs of Nothing -> [oneSeg] - (Just (middleSegs,lastSeg)) -> middleSegs <> if noIntersection (fst $ inwardAdjust lastSeg) (fst $ inwardAdjust oneSeg) + (Just (middleSegs,lastSeg)) -> middleSegs <> if noIntersection (inwardAdjust lastSeg) (inwardAdjust oneSeg) then maybeToList (combineLineSegs lastSeg oneSeg) else [lastSeg,oneSeg] inwardAdjust l1 = translateL (eToPLine2 l1) (if direction == Inward then pathWidth else (-pathWidth)) diff --git a/Graphics/Slicer/Math/Contour.hs b/Graphics/Slicer/Math/Contour.hs index d38309132..18d441889 100644 --- a/Graphics/Slicer/Math/Contour.hs +++ b/Graphics/Slicer/Math/Contour.hs @@ -260,17 +260,17 @@ innerContourPoint contour -- | Find a point that is guaranteed to be outside of the given contour, and is not on the same line as the first line segment of the contour. pointFarOutsideContour :: Contour -> Point2 pointFarOutsideContour contour - | not (noIntersection pline1 firstPLine) = outsidePoint1 - | not (noIntersection pline2 firstPLine) = outsidePoint2 - | not (noIntersection pline3 firstPLine) = outsidePoint3 + | not (noIntersection (pLine1, pLine1Err) (firstPLine, firstPLineErr)) = outsidePoint1 + | not (noIntersection (pLine2, pLine2Err) (firstPLine, firstPLineErr)) = outsidePoint2 + | not (noIntersection (pLine3, pLine3Err) (firstPLine, firstPLineErr)) = outsidePoint3 | otherwise = error "cannot get here." where minPoint = fst (minMaxPoints contour) (p1, p2) = firstPointPairOfContour contour - firstPLine = join2PPoint2 (eToPPoint2 p1) (eToPPoint2 p2) - pline1 = join2PPoint2 (eToPPoint2 p1) (eToPPoint2 outsidePoint1) - pline2 = join2PPoint2 (eToPPoint2 p1) (eToPPoint2 outsidePoint2) - pline3 = join2PPoint2 (eToPPoint2 p1) (eToPPoint2 outsidePoint3) + (firstPLine, (_,_,firstPLineErr)) = join2PP (eToPPoint2 p1) (eToPPoint2 p2) + (pLine1, (_,_, pLine1Err)) = join2PP (eToPPoint2 p1) (eToPPoint2 outsidePoint1) + (pLine2, (_,_, pLine2Err)) = join2PP (eToPPoint2 p1) (eToPPoint2 outsidePoint2) + (pLine3, (_,_, pLine3Err)) = join2PP (eToPPoint2 p1) (eToPPoint2 outsidePoint3) outsidePoint1 = Point2 (xOf minPoint - 0.1 , yOf minPoint - 0.1) outsidePoint2 = Point2 (xOf minPoint - 0.2 , yOf minPoint - 0.1) outsidePoint3 = Point2 (xOf minPoint - 0.1 , yOf minPoint - 0.2) @@ -278,9 +278,9 @@ pointFarOutsideContour contour -- | Find a point that is guaranteed to be outside of the given contour, and is not on the same line as the first line segment of the contour. pointFarOutsideContours :: Contour -> Contour -> Point2 pointFarOutsideContours contour1 contour2 - | not (noIntersection pline1 firstPLine) && not (noIntersection pline1 secondPLine) = outsidePoint1 - | not (noIntersection pline2 firstPLine) && not (noIntersection pline2 secondPLine) = outsidePoint2 - | not (noIntersection pline3 firstPLine) && not (noIntersection pline3 secondPLine) = outsidePoint3 + | not (noIntersection (pLine1, pLine1Err) (firstPLine, firstPLineErr)) && not (noIntersection (pLine1, pLine1Err) (secondPLine, secondPLineErr)) = outsidePoint1 + | not (noIntersection (pLine2, pLine2Err) (firstPLine, firstPLineErr)) && not (noIntersection (pLine2, pLine2Err) (secondPLine, secondPLineErr)) = outsidePoint2 + | not (noIntersection (pLine3, pLine3Err) (firstPLine, firstPLineErr)) && not (noIntersection (pLine3, pLine3Err) (secondPLine, secondPLineErr)) = outsidePoint3 | otherwise = error "cannot get here...?" where minPoint1 = fst $ minMaxPoints contour1 @@ -288,11 +288,11 @@ pointFarOutsideContours contour1 contour2 minPoint = Point2 (min (xOf minPoint1) (xOf minPoint2),min (yOf minPoint1) (yOf minPoint2)) (p1, p2) = firstPointPairOfContour contour1 (p3, p4) = firstPointPairOfContour contour2 - firstPLine = join2PPoint2 (eToPPoint2 p1) (eToPPoint2 p2) - secondPLine = join2PPoint2 (eToPPoint2 p3) (eToPPoint2 p4) - pline1 = join2PPoint2 (eToPPoint2 p1) (eToPPoint2 outsidePoint1) - pline2 = join2PPoint2 (eToPPoint2 p1) (eToPPoint2 outsidePoint2) - pline3 = join2PPoint2 (eToPPoint2 p1) (eToPPoint2 outsidePoint3) + (firstPLine, (_,_,firstPLineErr)) = join2PP (eToPPoint2 p1) (eToPPoint2 p2) + (secondPLine, (_,_,secondPLineErr)) = join2PP (eToPPoint2 p3) (eToPPoint2 p4) + (pLine1, (_,_, pLine1Err)) = join2PP (eToPPoint2 p1) (eToPPoint2 outsidePoint1) + (pLine2, (_,_, pLine2Err)) = join2PP (eToPPoint2 p1) (eToPPoint2 outsidePoint2) + (pLine3, (_,_, pLine3Err)) = join2PP (eToPPoint2 p1) (eToPPoint2 outsidePoint3) outsidePoint1 = Point2 (xOf minPoint - 0.1 , yOf minPoint - 0.1) outsidePoint2 = Point2 (xOf minPoint - 0.2 , yOf minPoint - 0.1) outsidePoint3 = Point2 (xOf minPoint - 0.1 , yOf minPoint - 0.2) diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index ae9df4294..bfb309c63 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -36,7 +36,7 @@ import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, mapWithNeighb import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum)) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), Intersection(HitEndPoint, HitStartPoint, NoIntersection), PLine2, PLine2Err, PPoint2Err, distance2PL, intersectsWithErr, outputIntersectsLineSeg, plinesIntersectIn, pToEP) +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), Intersection(HitEndPoint, HitStartPoint, NoIntersection), PLine2, PLine2Err, PPoint2Err, ProjectiveLine2, distance2PL, intersectsWithErr, outputIntersectsLineSeg, plinesIntersectIn, pToEP) import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle)) @@ -206,21 +206,21 @@ intersectionBetween pl1 pl2 = saneIntersection $ plinesIntersectIn (pl1,mempty) saneIntersection (IntersectsIn p (_,_, pErr)) = Just $ Right (p,pErr) -- | check if two lines cannot intersect. -noIntersection :: PLine2 -> PLine2 -> Bool -noIntersection pline1 pline2 = isCollinear pline1 pline2 || isParallel pline1 pline2 || isAntiCollinear pline1 pline2 || isAntiParallel pline1 pline2 +noIntersection :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a,PLine2Err) -> (b,PLine2Err) -> Bool +noIntersection pline1@(pl1,_) pline2@(pl2,_) = isCollinear pline1 pline2 || isParallel pl1 pl2 || isAntiCollinear pl1 pl2 || isAntiParallel pl1 pl2 -- | check if two lines are really the same line. -isCollinear :: PLine2 -> PLine2 -> Bool -isCollinear pline1 pline2 = plinesIntersectIn (pline1,mempty) (pline2,mempty) == PCollinear +isCollinear :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b,PLine2Err) -> Bool +isCollinear pline1 pline2 = plinesIntersectIn pline1 pline2 == PCollinear -- | check if two lines are really the same line. -isAntiCollinear :: PLine2 -> PLine2 -> Bool -isAntiCollinear pline1 pline2 = plinesIntersectIn (pline1,mempty) (pline2,mempty) == PAntiCollinear +isAntiCollinear :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Bool +isAntiCollinear pline1 pline2 = plinesIntersectIn (pline1, mempty) (pline2, mempty) == PAntiCollinear -- | check if two lines are parallel. -isParallel :: PLine2 -> PLine2 -> Bool -isParallel pline1 pline2 = plinesIntersectIn (pline1,mempty) (pline2,mempty) == PParallel +isParallel :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Bool +isParallel pline1 pline2 = plinesIntersectIn (pline1, mempty) (pline2, mempty) == PParallel -- | check if two lines are anti-parallel. -isAntiParallel :: PLine2 -> PLine2 -> Bool -isAntiParallel pline1 pline2 = plinesIntersectIn (pline1,mempty) (pline2,mempty) == PAntiParallel +isAntiParallel :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Bool +isAntiParallel pline1 pline2 = plinesIntersectIn (pline1, mempty) (pline2, mempty) == PAntiParallel diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index cbd296afb..57f663f6f 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -55,6 +55,7 @@ module Graphics.Slicer.Math.PGA( distance2PP, distance2PL, eToPL, + eToPP, eToPPoint2, flipL, interpolate2PP, @@ -363,8 +364,8 @@ pLineIntersectsLineSeg (pl1, pl1ErrOrigin) l1 pl2Err = pl2ErrOrigin <> npl2Err foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(GVec vals) -> vals) $ vecOfP rawIntersect (rawIntersect, (npl1Err, npl2Err, rawIntersectErr)) = intersect2PL pl1 pl2 - start = eToPPoint2 $ startPoint l1 - end = eToPPoint2 $ endPoint l1 + start = eToPP $ startPoint l1 + end = eToPP $ endPoint l1 (pl2, pl2ErrOrigin) = eToPL l1 dumpMiss = "startFudgeFactor: " <> show startFudgeFactor <> "\n" <> "endFudgeFactor: " <> show endFudgeFactor <> "\n" @@ -421,10 +422,10 @@ lineSegIntersectsLineSeg l1 l2 pl2Err = pl2ErrOrigin <> npl2Err foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(GVec vals) -> vals) $ vecOfP rawIntersect (rawIntersect, (npl1Err, npl2Err, rawIntersectErr)) = intersect2PL pl1 pl2 - start1 = eToPPoint2 $ startPoint l1 - end1 = eToPPoint2 $ endPoint l1 - start2 = eToPPoint2 $ startPoint l2 - end2 = eToPPoint2 $ endPoint l2 + start1 = eToPP $ startPoint l1 + end1 = eToPP $ endPoint l1 + start2 = eToPP $ startPoint l2 + end2 = eToPP $ endPoint l2 (pl1, pl1ErrOrigin) = eToPL l1 (pl2, pl2ErrOrigin) = eToPL l2 dumpMiss = "start2FudgeFactor: " <> show start2FudgeFactor <> "\n" @@ -444,9 +445,9 @@ onSegment ls i = || (midDistance <= (lengthOfSegment/2) + midFudgeFactor) || (endDistance <= endFudgeFactor) where - start = eToPPoint2 $ startPoint ls + start = eToPP $ startPoint ls (mid, (_, _, midErr)) = interpolate2PP start end 0.5 0.5 - end = eToPPoint2 $ endPoint ls + end = eToPP $ endPoint ls (startDistance, (_,_, startDistanceErr)) = distance2PP i (start, mempty) (midDistance, (_,_, midDistanceErr)) = distance2PP i (mid, midErr) (endDistance, (_,_, endDistanceErr)) = distance2PP i (end, mempty) @@ -490,10 +491,12 @@ combineConsecutiveLineSegs lines = case lines of ----- And now draw the rest of the algebra ----- ------------------------------------------------ -eToPPoint2 :: Point2 -> CPPoint2 +-- | Create a canonical projective point from the given euclidian point. +eToPPoint2, eToPP :: Point2 -> CPPoint2 eToPPoint2 (Point2 (x,y)) = res where res = makePPoint2 x y +eToPP = eToPPoint2 -- | Create a canonical euclidian projective point from the given coordinates. makePPoint2 :: ℝ -> ℝ -> CPPoint2 @@ -518,5 +521,5 @@ reverseGVec (GVec vals) = GVec $ foldl' addValWithoutErr [] euclidianToProjectiveLine, eToPL :: LineSeg -> (PLine2, PLine2Err) euclidianToProjectiveLine l = (res, resErr) where - (res, (_, _, resErr)) = join2PP (eToPPoint2 $ startPoint l) (eToPPoint2 $ endPoint l) + (res, (_, _, resErr)) = join2PP (eToPP $ startPoint l) (eToPP $ endPoint l) eToPL l = euclidianToProjectiveLine l diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index 279f35e3b..bc78fe3c4 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -173,14 +173,14 @@ averageNodes n1 n2 | not (hasArc n1) || not (hasArc n2) = error $ "Cannot get the average of nodes if one of the nodes does not have an out!\n" <> dumpInput | not (canPoint n1) || not (canPoint n2) = error $ "Cannot get the average of nodes if we cannot resolve them to a point!\n" <> dumpInput | isParallel (outOf n1) (outOf n2) = error $ "Cannot get the average of nodes if their outputs never intersect!\n" <> dumpInput - | isCollinear (outOf n1) (outOf n2) = error $ "Cannot (yet) handle two input plines that are collinear.\n" <> dumpInput + | isCollinear (outAndErrOf n1) (outAndErrOf n2) = error $ "Cannot (yet) handle two input plines that are collinear.\n" <> dumpInput | nodesAreAntiCollinear n1 n2 = error $ "Cannot (yet) handle two input plines that are collinear.\n" <> dumpInput | n1Distance < getRounded n1Err = error $ "intersection is AT the point of n1!\n" <> dumpInput | n2Distance < getRounded n2Err = error $ "intersection is AT the point of n2!\n" <> dumpInput | otherwise = makeINode (sortedPair n1 n2) $ Just $ getOutsideArc (pPointOf n1) (normalizePLine2 $ outOf n1) (pPointOf n2) (normalizePLine2 $ outOf n2) where - (n1Distance, (_,_,UlpSum n1Err)) = distance2PP (intersectionOf (outOf n1) (outOf n2)) (pPointOf n1, mempty) - (n2Distance, (_,_,UlpSum n2Err)) = distance2PP (intersectionOf (outOf n1) (outOf n2)) (pPointOf n2, mempty) + (n1Distance, (_,_, UlpSum n1Err)) = distance2PP (intersectionOf (outOf n1) (outOf n2)) (pPointOf n1, mempty) + (n2Distance, (_,_, UlpSum n2Err)) = distance2PP (intersectionOf (outOf n1) (outOf n2)) (pPointOf n2, mempty) dumpInput = "Node1: " <> show n1 <> "\nNode2: " <> show n2 <> "\nNode1Out: " <> show (outOf n1) @@ -198,7 +198,7 @@ sortedPair n1 n2 = sortedPLinesWithErr [outAndErrOf n1, outAndErrOf n2] getOutsideArc :: (ProjectivePoint2 a) => a -> NPLine2 -> a -> NPLine2 -> (PLine2, PLine2Err) getOutsideArc ppoint1 npline1 ppoint2 npline2 | npline1 == npline2 = error "need to be able to return two PLines." - | noIntersection pline1 pline2 = error $ "no intersection between pline " <> show pline1 <> " and " <> show pline2 <> ".\n" + | noIntersection (pline1, mempty) (pline2, mempty) = error $ "no intersection between pline " <> show pline1 <> " and " <> show pline2 <> ".\n" | l1TowardPoint && l2TowardPoint = (flipL resFlipped, resFlippedErr) | l1TowardPoint = (flipL resNormal, resNormalErr) | l2TowardPoint = (resNormal, resNormalErr) @@ -614,7 +614,7 @@ skeletonOfNodes connectedLoop inSegSets iNodes = -- Handle the the case of two nodes. handleTwoNodes :: (Arcable a, Pointable a, Arcable b, Pointable b) => a -> b -> Either PartialNodes INodeSet handleTwoNodes node1 node2 - | isCollinear (outOf node1) (outOf node2) = Left $ PartialNodes (INodeSet $ one iNodes) $ "cannot handle collinear nodes:\n" <> show node1 <> "\n" <> show node2 <> "\n" + | isCollinear (outAndErrOf node1) (outAndErrOf node2) = Left $ PartialNodes (INodeSet $ one iNodes) $ "cannot handle collinear nodes:\n" <> show node1 <> "\n" <> show node2 <> "\n" | nodesAreAntiCollinear node1 node2 && contourLooped = Right $ INodeSet $ one [makeLastPair node1 node2] | contourLooped = -- this is a complete loop, so this last INode will be re-written in sortINodesByENodes anyways. Right $ INodeSet $ one [makeINode (sortedPLinesWithErr [outAndErrOf node1,outAndErrOf node2]) Nothing] @@ -861,7 +861,7 @@ skeletonOfNodes connectedLoop inSegSets iNodes = -- | Check if the intersection of two nodes results in a point or not. intersectsInPoint :: (Arcable a, Pointable a, Arcable b, Pointable b) => a -> b -> Bool intersectsInPoint node1 node2 - | hasArc node1 && hasArc node2 = not (noIntersection (outOf node1) (outOf node2)) + | hasArc node1 && hasArc node2 = not (noIntersection (outAndErrOf node1) (outAndErrOf node2)) && (dist1 >= realToFrac dist1Err) && (dist2 >= realToFrac dist2Err) | otherwise = error $ "cannot intersect a node with no output:\nNode1: " <> show node1 <> "\nNode2: " <> show node2 <> "\nnodes: " <> show iNodes <> "\n" diff --git a/Graphics/Slicer/Math/Skeleton/Face.hs b/Graphics/Slicer/Math/Skeleton/Face.hs index 1b7682509..16bfdcaa9 100644 --- a/Graphics/Slicer/Math/Skeleton/Face.hs +++ b/Graphics/Slicer/Math/Skeleton/Face.hs @@ -22,7 +22,7 @@ -- | This file contains code for creating a series of Faces, covering a straight skeleton. module Graphics.Slicer.Math.Skeleton.Face (Face(Face), orderedFacesOf, facesOf) where -import Prelude ((==), fst, otherwise, (<$>), ($), length, error, (<>), show, Eq, Show, (<>), Bool(True), null, not, and, snd, (&&), (>), (/=)) +import Prelude ((==), fst, otherwise, (<$>), ($), length, error, (<>), show, Eq, Show, (<>), Bool(True), null, not, and, snd, (&&), (>), (/=), mempty) import Data.List (uncons) @@ -214,7 +214,7 @@ intraNodeFace nodeTree1 nodeTree2 where errNodesNotNeighbors = error $ "cannot make a face from nodes that are not neighbors: \n" <> show nodeTree1 <> "\n" <> show nodeTree2 <> "\n" follows :: NodeTree -> NodeTree -> Bool - follows nt1 nt2 = isCollinear (last $ firstPLinesOf nt1) (last $ lastPLinesOf nt2) + follows nt1 nt2 = isCollinear (last $ firstPLinesOf nt1, mempty) (last $ lastPLinesOf nt2, mempty) isLeftOf :: NodeTree -> NodeTree -> Bool isLeftOf nt1 nt2 = firstSegOf nt1 == lastSegOf nt2 isRightOf :: NodeTree -> NodeTree -> Bool diff --git a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs index 87d3ab7ad..18d8d0f0f 100644 --- a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs +++ b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs @@ -48,9 +48,9 @@ import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, mapWithNeighb import Graphics.Slicer.Math.Intersections (getMotorcycleSegSetIntersections, getMotorcycleContourIntersections, intersectionOf, isAntiCollinear, noIntersection) -import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, pPointBetweenPPoints, distanceBetweenPPoints, eToCPPoint2, eToPLine2, normalizePLine2, pLineFromEndpoints, pToEPoint2) +import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, pPointBetweenPPoints, distanceBetweenPPoints, eToCPPoint2, eToPLine2, normalizePLine2, pToEPoint2) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), PPoint2, Arcable(outOf), Pointable(canPoint, ePointOf, pPointOf), eToPL, flipL, pLineIsLeft, pPointsOnSameSideOfPLine, PIntersection(IntersectsIn,PAntiCollinear), angleBetween2PL, distance2PP, outAndErrOf, outputIntersectsLineSeg, plinesIntersectIn, translateL) +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), PPoint2, Arcable(outOf), Pointable(canPoint, ePointOf, pPointOf), eToPL, flipL, pLineIsLeft, pPointsOnSameSideOfPLine, PIntersection(IntersectsIn,PAntiCollinear), angleBetween2PL, distance2PP, eToPP, join2PP, outAndErrOf, outputIntersectsLineSeg, plinesIntersectIn, translateL) import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle), ENode(ENode), getFirstLineSeg, linePairs, CellDivide(CellDivide), DividingMotorcycles(DividingMotorcycles), MotorcycleIntersection(WithLineSeg, WithENode, WithMotorcycle)) @@ -143,7 +143,7 @@ crashMotorcycles contour holes crashOf mot1 mot2@(Motorcycle (inSeg2, _) _ _) -- If we have a clear path between mot1 and the origin of mot2 | isAntiCollinear (outOf mot1) (outOf mot2) && motorcycleIntersectsAt contour mot1 == (inSeg2, Left $ endPoint inSeg2) = Just $ Collision (mot1,mot2, slist []) Nothing HeadOn - | noIntersection (outOf mot1) (outOf mot2) = Nothing + | noIntersection (outAndErrOf mot1) (outAndErrOf mot2) = Nothing | intersectionIsBehind mot1 = Nothing | intersectionIsBehind mot2 = Nothing -- FIXME: this should be providing a distance to intersectionPPoint along the motorcycle to check. @@ -183,22 +183,24 @@ convexMotorcycles contour = catMaybes $ onlyMotorcycles <$> zip (rotateLeft $ li -- | generate the un-normalized PLine2 of a motorcycle created by the three points given. motorcycleFromPoints :: Point2 -> Point2 -> Point2 -> (PLine2, PLine2Err) -motorcycleFromPoints p1 p2 p3 = getOutsideArc (pLineFromEndpoints p1 p2) (pLineFromEndpoints p2 p3) +motorcycleFromPoints p1 p2 p3 = getOutsideArc (firstArc, firstArcErr) (secondArc, secondArcErr) where + (firstArc, (_,_, firstArcErr)) = join2PP (eToPP p1) (eToPP p2) + (secondArc, (_,_, secondArcErr)) = join2PP (eToPP p2) (eToPP p3) -- | Get a PLine along the angle bisector of the intersection of the two given line segments, pointing in the 'obtuse' direction. -- Note that we do not normalize our output, or require normalized inputs, but we normalize our values before adding them. - getOutsideArc :: PLine2 -> PLine2 -> (PLine2, PLine2Err) - getOutsideArc pline1 pline2 + getOutsideArc :: (PLine2, PLine2Err) -> (PLine2, PLine2Err) -> (PLine2, PLine2Err) + getOutsideArc pline1@(pl1, _) pline2@(pl2, _) | noIntersection pline1 pline2 = error $ "not collinear, but not intersecting?\n" <> "PLine1: " <> show pline1 <> "\n" <> "PLine2: " <> show pline2 <> "\n" - <> "result: " <> show (plinesIntersectIn (pline1,mempty) (pline2,mempty)) <> "\n" + <> "result: " <> show (plinesIntersectIn pline1 pline2) <> "\n" | otherwise = (flipL $ PLine2 newPLine, PLine2Err newPLineErrVals mempty mempty mempty mempty mempty) where (newPLine, newPLineErrVals) = addVecPairWithErr flippedNPV1 npv2 - (PLine2 flippedNPV1) = flipL $ (\(NPLine2 a) -> PLine2 a) $ normalizePLine2 pline1 - (NPLine2 npv2) = normalizePLine2 pline2 + (PLine2 flippedNPV1) = flipL $ (\(NPLine2 a) -> PLine2 a) $ normalizePLine2 pl1 + (NPLine2 npv2) = normalizePLine2 pl2 -- | Find the non-reflex virtexes of a contour and draw motorcycles from them. -- A reflex virtex is any point where the line in and the line out are convex, when looked at from inside of the contour. From 86c5b65d9b0033fd3e8cff9975d056e98bf3ac07 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Thu, 24 Nov 2022 19:01:10 +0000 Subject: [PATCH 095/206] use loss preserving functions, but make it clear we are losing through all the cases of fst. --- Graphics/Slicer/Machine/Contour.hs | 27 +++++---------------------- 1 file changed, 5 insertions(+), 22 deletions(-) diff --git a/Graphics/Slicer/Machine/Contour.hs b/Graphics/Slicer/Machine/Contour.hs index 688541db6..5347980f9 100644 --- a/Graphics/Slicer/Machine/Contour.hs +++ b/Graphics/Slicer/Machine/Contour.hs @@ -19,7 +19,7 @@ module Graphics.Slicer.Machine.Contour (cleanContour, shrinkContour, expandContour) where -import Prelude (($), otherwise, Eq, (<>), show, error, (==), (&&), Bool(True, False), Show) +import Prelude (($), Eq((==)), (<>), (&&), Show(show), error, fst, not, otherwise) import Data.List (null, foldl') @@ -31,13 +31,13 @@ import Graphics.Slicer.Math.Contour (lineSegsOfContour, makeLineSegContour) import Graphics.Slicer.Math.Definitions (Contour, LineSeg, mapWithNeighbors, makeLineSeg) -import Graphics.Slicer.Math.Intersections (noIntersection) +import Graphics.Slicer.Math.Intersections (noIntersection, intersectionOf) import Graphics.Slicer.Math.Line (combineLineSegs) import Graphics.Slicer.Math.Lossy (eToPLine2, pToEPoint2) -import Graphics.Slicer.Math.PGA (combineConsecutiveLineSegs, PIntersection(IntersectsIn), plinesIntersectIn, translateL) +import Graphics.Slicer.Math.PGA (combineConsecutiveLineSegs, eToPL, translateL) import Graphics.Slicer.Definitions(ℝ) @@ -106,24 +106,7 @@ modifyContour pathWidth contour direction findLineSeg previousln ln nextln -- The ideal case. | isIntersection previousln ln && - isIntersection ln nextln = Just $ makeLineSeg (intersectionPoint (inwardAdjust previousln) (inwardAdjust ln)) (intersectionPoint (inwardAdjust ln) (inwardAdjust nextln)) + isIntersection ln nextln = Just $ makeLineSeg (pToEPoint2 $ fst $ intersectionOf (fst $ inwardAdjust previousln) (fst $ inwardAdjust ln)) (pToEPoint2 $ fst $ intersectionOf (fst $ inwardAdjust ln) (fst $ inwardAdjust nextln)) | otherwise = error $ "no intersection?\n" <> show (isIntersection previousln ln) <> "\n" <> show (isIntersection ln nextln) <> "\n" <> show previousln <> "\n" <> show ln <> "\n" <> show nextln <> "\n" where - isIntersection l1 l2 = case plinesIntersectIn (inwardAdjust l1) (inwardAdjust l2) of - IntersectsIn _ _ -> True - _other -> False - intersectionPoint pl1 pl2 = case plinesIntersectIn pl1 pl2 of - IntersectsIn p2 _ -> pToEPoint2 p2 - a -> error $ "impossible result!\nresult: " <> show a <> "\npline 1: " <> show pl1 - <> "\npline 2: " <> show pl2 - <> "\nEvaluating line intersections between:\nFirst: " <> show previousln - <> "\nSecond: " <> show ln - <> "\nThird: " <> show nextln <> "\n"<> show (inwardAdjust previousln) - <> "\n" <> show (eToPLine2 previousln) - <> "\n" <> show (inwardAdjust ln) - <> "\n" <> show (eToPLine2 ln) - <> "\n" <> show (inwardAdjust nextln) - <> "\n" <> show (eToPLine2 nextln) - <> "\n" <> show direction - <> "\n" <> show contour - <> "\n" + isIntersection l1 l2 = not $ noIntersection (eToPL l1) (eToPL l2) From 2a2082b95219406f979a3025fd34601ddc1606d5 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Thu, 24 Nov 2022 19:41:58 +0000 Subject: [PATCH 096/206] make intersectionOf accept error quotents. --- Graphics/Slicer/Machine/Contour.hs | 2 +- Graphics/Slicer/Math/Intersections.hs | 4 ++-- Graphics/Slicer/Math/PGAPrimitives.hs | 2 +- Graphics/Slicer/Math/Skeleton/Cells.hs | 2 +- Graphics/Slicer/Math/Skeleton/Concave.hs | 14 +++++++------- Graphics/Slicer/Math/Skeleton/Line.hs | 16 ++++++++-------- Graphics/Slicer/Math/Skeleton/Motorcycles.hs | 2 +- 7 files changed, 21 insertions(+), 21 deletions(-) diff --git a/Graphics/Slicer/Machine/Contour.hs b/Graphics/Slicer/Machine/Contour.hs index 5347980f9..0adffc56e 100644 --- a/Graphics/Slicer/Machine/Contour.hs +++ b/Graphics/Slicer/Machine/Contour.hs @@ -106,7 +106,7 @@ modifyContour pathWidth contour direction findLineSeg previousln ln nextln -- The ideal case. | isIntersection previousln ln && - isIntersection ln nextln = Just $ makeLineSeg (pToEPoint2 $ fst $ intersectionOf (fst $ inwardAdjust previousln) (fst $ inwardAdjust ln)) (pToEPoint2 $ fst $ intersectionOf (fst $ inwardAdjust ln) (fst $ inwardAdjust nextln)) + isIntersection ln nextln = Just $ makeLineSeg (pToEPoint2 $ fst $ intersectionOf (inwardAdjust previousln) (inwardAdjust ln)) (pToEPoint2 $ fst $ intersectionOf (inwardAdjust ln) (inwardAdjust nextln)) | otherwise = error $ "no intersection?\n" <> show (isIntersection previousln ln) <> "\n" <> show (isIntersection ln nextln) <> "\n" <> show previousln <> "\n" <> show ln <> "\n" <> show nextln <> "\n" where isIntersection l1 l2 = not $ noIntersection (eToPL l1) (eToPL l2) diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index bfb309c63..76ae510bf 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -181,8 +181,8 @@ filterIntersections l1 l2 l3 = error lineLength (mySeg, _) = distance (startPoint mySeg) (endPoint mySeg) -- | Get the intersection point of two lines we know have an intersection point. -intersectionOf :: PLine2 -> PLine2 -> (CPPoint2, PPoint2Err) -intersectionOf pl1 pl2 = saneIntersection $ plinesIntersectIn (pl1,mempty) (pl2,mempty) +intersectionOf :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> (CPPoint2, PPoint2Err) +intersectionOf pl1 pl2 = saneIntersection $ plinesIntersectIn pl1 pl2 where saneIntersection PAntiCollinear = error $ "cannot get the intersection of anti-collinear lines.\npl1: " <> show pl1 <> "\npl2: " <> show pl2 <> "\n" saneIntersection PCollinear = error $ "cannot get the intersection of collinear lines.\npl1: " <> show pl1 <> "\npl2: " <> show pl2 <> "\n" diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index d75dc0c78..dee793de3 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -146,7 +146,7 @@ newtype NPLine2 = NPLine2 GVec deriving (Eq, Generic, NFData, Show) -- | The typeclass definition. functions that must be implemented for any projective line type. -class ProjectiveLine2 a where +class (Show a) => ProjectiveLine2 a where consLikeL :: a -> (GVec -> a) normalizeL :: a -> (NPLine2, PLine2Err) vecOfL :: a -> GVec diff --git a/Graphics/Slicer/Math/Skeleton/Cells.hs b/Graphics/Slicer/Math/Skeleton/Cells.hs index 0cf2986a3..c27a59b06 100644 --- a/Graphics/Slicer/Math/Skeleton/Cells.hs +++ b/Graphics/Slicer/Math/Skeleton/Cells.hs @@ -115,7 +115,7 @@ findDivisions contour crashTree = case motorcyclesIn crashTree of where (angleFound, (_,_, angleErr)) = angleBetween2PL (outOf m) (eToPLine2 $ lineSegToIntersection m) lineSegToIntersection m = makeLineSeg (ePointOf m) (pToEPoint2 intersectionPPoint) - intersectionPPoint = fst $ intersectionOf (outOf firstMC) (outOf secondMC) + intersectionPPoint = fst $ intersectionOf (outAndErrOf firstMC) (outAndErrOf secondMC) (Slist (_:_) _) -> error "too many motorcycles." motorcyclesIn (CrashTree motorcycles _ _) = motorcycles -- | find where the last motorcycle of a divide lands diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index bc78fe3c4..8b02e1a6e 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -179,8 +179,8 @@ averageNodes n1 n2 | n2Distance < getRounded n2Err = error $ "intersection is AT the point of n2!\n" <> dumpInput | otherwise = makeINode (sortedPair n1 n2) $ Just $ getOutsideArc (pPointOf n1) (normalizePLine2 $ outOf n1) (pPointOf n2) (normalizePLine2 $ outOf n2) where - (n1Distance, (_,_, UlpSum n1Err)) = distance2PP (intersectionOf (outOf n1) (outOf n2)) (pPointOf n1, mempty) - (n2Distance, (_,_, UlpSum n2Err)) = distance2PP (intersectionOf (outOf n1) (outOf n2)) (pPointOf n2, mempty) + (n1Distance, (_,_, UlpSum n1Err)) = distance2PP (intersectionOf (outAndErrOf n1) (outAndErrOf n2)) (pPointOf n1, mempty) + (n2Distance, (_,_, UlpSum n2Err)) = distance2PP (intersectionOf (outAndErrOf n1) (outAndErrOf n2)) (pPointOf n2, mempty) dumpInput = "Node1: " <> show n1 <> "\nNode2: " <> show n2 <> "\nNode1Out: " <> show (outOf n1) @@ -208,7 +208,7 @@ getOutsideArc ppoint1 npline1 ppoint2 npline2 (resFlipped, resFlippedErr) = getInsideArcWithErr pline1 (flipL pline2) pline1 = (\(NPLine2 v) -> PLine2 v) npline1 pline2 = (\(NPLine2 v) -> PLine2 v) npline2 - intersectionPoint = fst $ intersectionOf pline1 pline2 + intersectionPoint = fst $ intersectionOf (pline1, mempty) (pline2, mempty) l1TowardPoint = towardIntersection ppoint1 pline1 intersectionPoint l2TowardPoint = towardIntersection ppoint2 pline2 intersectionPoint @@ -854,9 +854,9 @@ skeletonOfNodes connectedLoop inSegSets iNodes = | canPoint node1 && canPoint node2 && intersectsInPoint node1 node2 = - Just $ fst (distance2PP (pPointOf node1, mempty) (intersectionOf (outOf node1) (outOf node2))) + Just $ fst (distance2PP (pPointOf node1, mempty) (intersectionOf (outAndErrOf node1) (outAndErrOf node2))) `max` - fst (distance2PP (pPointOf node2, mempty) (intersectionOf (outOf node1) (outOf node2))) + fst (distance2PP (pPointOf node2, mempty) (intersectionOf (outAndErrOf node1) (outAndErrOf node2))) | otherwise = Nothing -- | Check if the intersection of two nodes results in a point or not. intersectsInPoint :: (Arcable a, Pointable a, Arcable b, Pointable b) => a -> b -> Bool @@ -866,5 +866,5 @@ skeletonOfNodes connectedLoop inSegSets iNodes = && (dist2 >= realToFrac dist2Err) | otherwise = error $ "cannot intersect a node with no output:\nNode1: " <> show node1 <> "\nNode2: " <> show node2 <> "\nnodes: " <> show iNodes <> "\n" where - (dist1, (_,_,UlpSum dist1Err)) = distance2PP (intersectionOf (outOf node1) (outOf node2)) (pPointOf node1, mempty) - (dist2, (_,_,UlpSum dist2Err)) = distance2PP (intersectionOf (outOf node1) (outOf node2)) (pPointOf node2, mempty) + (dist1, (_,_,UlpSum dist1Err)) = distance2PP (pPointOf node1, mempty) (intersectionOf (outAndErrOf node1) (outAndErrOf node2)) + (dist2, (_,_,UlpSum dist2Err)) = distance2PP (pPointOf node2, mempty) (intersectionOf (outAndErrOf node1) (outAndErrOf node2)) diff --git a/Graphics/Slicer/Math/Skeleton/Line.hs b/Graphics/Slicer/Math/Skeleton/Line.hs index 29ea1163f..4b7c37ac0 100644 --- a/Graphics/Slicer/Math/Skeleton/Line.hs +++ b/Graphics/Slicer/Math/Skeleton/Line.hs @@ -77,12 +77,12 @@ addLineSegsToFace distance insets face@(Face edge firstArc midArcs@(Slist rawMid linesToRender = maybe linesUntilEnd (min linesUntilEnd) insets -- | The line segments we are placing. - foundLineSegs = [ makeLineSeg (pToEPoint2 $ fst $ intersectionOf newSide firstArc) (pToEPoint2 $ fst $ intersectionOf newSide lastArc) | newSide <- newSides ] + foundLineSegs = [ makeLineSeg (pToEPoint2 $ fst $ intersectionOf (newSide, mempty) (firstArc, mempty)) (pToEPoint2 $ fst $ intersectionOf (newSide, mempty) (lastArc, mempty)) | newSide <- newSides ] where newSides = [ translatePLine2 (eToPLine2 edge) $ translateDir (-(distance+(distance * fromIntegral segmentNum))) | segmentNum <- [0..linesToRender-1] ] -- | The line where we are no longer able to fill this face. from the firstArc to the lastArc, along the point that the lines we place stop. - finalSide = makeLineSeg (pToEPoint2 $ fst $ intersectionOf finalLine firstArc) (pToEPoint2 $ fst $ intersectionOf finalLine lastArc) + finalSide = makeLineSeg (pToEPoint2 $ fst $ intersectionOf (finalLine, mempty) (firstArc, mempty)) (pToEPoint2 $ fst $ intersectionOf (finalLine, mempty) (lastArc, mempty)) where finalLine = translatePLine2 (eToPLine2 edge) $ translateDir (distance * fromIntegral linesToRender) @@ -92,10 +92,10 @@ addLineSegsToFace distance insets face@(Face edge firstArc midArcs@(Slist rawMid -- | what is the distance from the edge to the place we can no longer place lines. distanceUntilEnd = case midArcs of - (Slist [] 0) -> distancePPointToPLine (fst $ intersectionOf firstArc lastArc) (eToNPLine2 edge) + (Slist [] 0) -> distancePPointToPLine (fst $ intersectionOf (firstArc, mempty) (lastArc, mempty)) (eToNPLine2 edge) (Slist [oneArc] 1) -> if firstArcLonger - then distancePPointToPLine (fst $ intersectionOf firstArc oneArc) (eToNPLine2 edge) - else distancePPointToPLine (fst $ intersectionOf oneArc lastArc) (eToNPLine2 edge) + then distancePPointToPLine (fst $ intersectionOf (firstArc, mempty) (oneArc, mempty)) (eToNPLine2 edge) + else distancePPointToPLine (fst $ intersectionOf (oneArc, mempty) (lastArc, mempty)) (eToNPLine2 edge) (Slist _ _) -> closestArcDistance ----------------------------------------------------------- @@ -106,7 +106,7 @@ addLineSegsToFace distance insets face@(Face edge firstArc midArcs@(Slist rawMid [] -> error "no remains for an nSideRemainder?" -- | Find the closest point where two of our arcs intersect, relative to our side. - arcIntersections = initSafe $ mapWithFollower (\a b -> (fst $ distancePPointToPLineWithErr (intersectionOf a b) (eToNPLine2 edge, mempty), (a, b))) $ [firstArc] <> rawMidArcs <> [lastArc] + arcIntersections = initSafe $ mapWithFollower (\a b -> (fst $ distancePPointToPLineWithErr (intersectionOf (a, mempty) (b, mempty)) (eToNPLine2 edge, mempty), (a, b))) $ [firstArc] <> rawMidArcs <> [lastArc] findClosestArc :: (ℝ, (PLine2, PLine2)) findClosestArc = case sortOn fst arcIntersections of [] -> error "empty arcIntersections?" @@ -140,13 +140,13 @@ addLineSegsToFace distance insets face@(Face edge firstArc midArcs@(Slist rawMid midArc = case midArcs of (Slist [oneArc] 1) -> oneArc (Slist _ _) -> error $ "evaluated midArc with the wrong insets of items\nd: " <> show distance <> "\nn: " <> show insets <> "\nFace: " <> show face <> "\n" - threeSideRemainder = if fst (distancePPointToPLineWithErr (intersectionOf firstArc midArc) (eToNPLine2 edge, mempty)) /= fst (distancePPointToPLineWithErr (intersectionOf midArc lastArc) (eToNPLine2 edge, mempty)) + threeSideRemainder = if fst (distancePPointToPLineWithErr (intersectionOf (firstArc, mempty) (midArc, mempty)) (eToNPLine2 edge, mempty)) /= fst (distancePPointToPLineWithErr (intersectionOf (midArc, mempty) (lastArc, mempty)) (eToNPLine2 edge, mempty)) then subRemains else Nothing (subSides, subRemains) = if firstArcLonger then addLineSegsToFace distance insets (Face finalSide firstArc (slist []) midArc) else addLineSegsToFace distance insets (Face finalSide midArc (slist []) lastArc) - firstArcLonger = fst (distancePPointToPLineWithErr (intersectionOf firstArc midArc) (eToNPLine2 edge, mempty)) > fst (distancePPointToPLineWithErr (intersectionOf midArc lastArc) (eToNPLine2 edge, mempty)) + firstArcLonger = fst (distancePPointToPLineWithErr (intersectionOf (firstArc, mempty) (midArc, mempty)) (eToNPLine2 edge, mempty)) > fst (distancePPointToPLineWithErr (intersectionOf (midArc,mempty) (lastArc, mempty)) (eToNPLine2 edge, mempty)) ---------------------------------------------- -- functions only used by a three-sided n-gon. ---------------------------------------------- diff --git a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs index 18d8d0f0f..d43b70388 100644 --- a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs +++ b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs @@ -154,7 +154,7 @@ crashMotorcycles contour holes EQ -> Just $ Collision (mot1, mot2, slist []) (Just mot1) SideSwipe _ -> Nothing where - intersectionPPoint = intersectionOf (outOf mot1) (outOf mot2) + intersectionPPoint = intersectionOf (outAndErrOf mot1) (outAndErrOf mot2) intersectionIsBehind m = angleFound < realToFrac (ulpVal angleErr) where (angleFound, (_,_, angleErr)) = angleBetween2PL (outOf m) (eToPLine2 $ lineSegToIntersection m) From a28b1558d9b20b03ecf8187d17245f5084b17531 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Thu, 24 Nov 2022 23:27:04 +0000 Subject: [PATCH 097/206] use concatMap. --- Graphics/Slicer/Machine/Infill.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/Graphics/Slicer/Machine/Infill.hs b/Graphics/Slicer/Machine/Infill.hs index b7a764f3c..24c942d61 100644 --- a/Graphics/Slicer/Machine/Infill.hs +++ b/Graphics/Slicer/Machine/Infill.hs @@ -23,7 +23,9 @@ module Graphics.Slicer.Machine.Infill (makeInfill, InfillType(Diag1, Diag2, Vert, Horiz), infillLineSegInside, coveringPLinesVertical) where -import Prelude ((+), (<$>), ($), (.), (*), sqrt, (-), Ordering(EQ, GT, LT), otherwise, (==), length, concat, not, null, (!!), fromIntegral, ceiling, (/), floor, Integer, compare) +import Prelude ((+), (<$>), ($), (.), (*), sqrt, (-), Ordering(EQ, GT, LT), otherwise, (==), length, not, null, (!!), fromIntegral, ceiling, (/), floor, Integer, compare) + +import Data.List (concatMap) import Data.List.Ordered (sort) @@ -64,7 +66,7 @@ infillLineSegInside contour childContours line allLines :: [LineSeg] allLines = makeLineSegs allPoints where - allPoints = filterTooShort . sort . concat $ getPLine2Intersections line <$> contour:childContours + allPoints = (filterTooShort . sort) $ concatMap (getPLine2Intersections line) (contour:childContours) filterTooShort :: [Point2] -> [Point2] filterTooShort [] = [] filterTooShort [a] = [a] From d251ff012ccb683929490285157fde92ee7e1733 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Fri, 25 Nov 2022 18:35:06 +0000 Subject: [PATCH 098/206] use mapMaybe. --- Graphics/Slicer/Machine/Infill.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Graphics/Slicer/Machine/Infill.hs b/Graphics/Slicer/Machine/Infill.hs index 24c942d61..6c4682810 100644 --- a/Graphics/Slicer/Machine/Infill.hs +++ b/Graphics/Slicer/Machine/Infill.hs @@ -29,7 +29,7 @@ import Data.List (concatMap) import Data.List.Ordered (sort) -import Data.Maybe (Maybe(Just, Nothing), catMaybes) +import Data.Maybe (Maybe(Just, Nothing), mapMaybe) import Graphics.Slicer.Definitions (ℝ) @@ -50,7 +50,7 @@ data InfillType = Diag1 | Diag2 | Vert | Horiz -- Basically, cover the build plane in lines, then remove the portions of those lines that are not inside of the target contour. -- The target contour should be pre-shrunk to the innermost parameter, and the target inside contours should also be the outermost parameters. makeInfill :: Contour -> [Contour] -> ℝ -> InfillType -> [[LineSeg]] -makeInfill contour insideContours ls layerType = catMaybes $ infillLineSegInside contour insideContours <$> infillCover layerType +makeInfill contour insideContours ls layerType = mapMaybe (infillLineSegInside contour insideContours) $ infillCover layerType where infillCover Vert = coveringPLinesVertical contour ls infillCover Horiz = coveringPLinesHorizontal contour ls From 6c92a9c3ccf45638eca1000f66c2bfa3ba261802 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Fri, 25 Nov 2022 20:05:01 +0000 Subject: [PATCH 099/206] use mapMaybe instead of catMaybes <$>. --- Graphics/Slicer/Math/Ganja.hs | 2 +- Graphics/Slicer/Math/Skeleton/Concave.hs | 14 +++++++------- Graphics/Slicer/Math/Skeleton/Definitions.hs | 4 ++-- Graphics/Slicer/Math/Skeleton/Line.hs | 4 ++-- Graphics/Slicer/Math/Skeleton/Motorcycles.hs | 10 +++++----- 5 files changed, 17 insertions(+), 17 deletions(-) diff --git a/Graphics/Slicer/Math/Ganja.hs b/Graphics/Slicer/Math/Ganja.hs index 362cfec00..a860e3115 100644 --- a/Graphics/Slicer/Math/Ganja.hs +++ b/Graphics/Slicer/Math/Ganja.hs @@ -91,7 +91,7 @@ import Data.List (sort) import Data.List.Unique (allUnique) -import Data.Maybe (Maybe(Nothing, Just), maybeToList, catMaybes, fromMaybe) +import Data.Maybe (Maybe(Nothing, Just), catMaybes, fromMaybe, maybeToList) import Math.Tau (tau) diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index 8b02e1a6e..489b0f063 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -34,7 +34,7 @@ import Prelude as PL (head, last, tail, init) import Data.Either (lefts,rights) -import Data.Maybe( Maybe(Just,Nothing), catMaybes, isJust, isNothing, fromMaybe) +import Data.Maybe( Maybe(Just,Nothing), catMaybes, fromMaybe, isJust, isNothing, mapMaybe) import Data.List (takeWhile, dropWhile, sortBy, nub) @@ -241,7 +241,7 @@ makeENodes segs = case segs of -- | Find the non-reflex virtexes of a contour, and create ENodes from them. -- This function is meant to be used on an exterior contour. eNodesOfOutsideContour :: Contour -> [ENode] -eNodesOfOutsideContour contour = catMaybes $ onlyNodes <$> zip (linePairs contour) (mapWithFollower concavePLines $ lineSegsOfContour contour) +eNodesOfOutsideContour contour = mapMaybe onlyNodes $ zip (linePairs contour) (mapWithFollower concavePLines $ lineSegsOfContour contour) where onlyNodes :: ((LineSeg, LineSeg), Maybe PLine2) -> Maybe ENode onlyNodes ((seg1, seg2), Just _) = Just $ makeENode (startPoint seg1) (startPoint seg2) (endPoint seg2) @@ -715,7 +715,7 @@ skeletonOfNodes connectedLoop inSegSets iNodes = (Slist [] _) -> [lineSegs] (Slist (oneENode:moreENodes) _) -> concat $ removeENodeFromSegList oneENode <$> removeENodesFromSegList (slist moreENodes) lineSegs where - filterTooShorts sets = catMaybes $ isTooShort <$> sets + filterTooShorts sets = mapMaybe isTooShort sets isTooShort set = case set of [] -> Nothing [val] -> Just [val] @@ -830,23 +830,23 @@ skeletonOfNodes connectedLoop inSegSets iNodes = -- | find nodes of two different types that can intersect. intersectingMixedNodePairs :: [(ENode, INode)] - intersectingMixedNodePairs = catMaybes $ (\(node1, node2) -> if intersectsInPoint node1 node2 then Just (node1, node2) else Nothing) <$> getMixedPairs eNodes iNodes + intersectingMixedNodePairs = mapMaybe (\(node1, node2) -> if intersectsInPoint node1 node2 then Just (node1, node2) else Nothing) $ getMixedPairs eNodes iNodes where getMixedPairs :: [a] -> [b] -> [(a, b)] getMixedPairs set1 set2 = concat $ (\a -> (a,) <$> set2) <$> set1 -- | find nodes of the same type that can intersect. intersectingNodePairsOf :: (Arcable a, Pointable a) => [a] -> [(a, a)] - intersectingNodePairsOf inNodes = catMaybes $ (\(node1, node2) -> if intersectsInPoint node1 node2 then Just (node1, node2) else Nothing) <$> getPairs inNodes + intersectingNodePairsOf inNodes = mapMaybe (\(node1, node2) -> if intersectsInPoint node1 node2 then Just (node1, node2) else Nothing) $ getPairs inNodes -- | find nodes of the same type that can intersect. -- NOTE: accepts node pairs, so that we can ensure we check just following ENodes. intersectingNeighboringNodePairsOf :: (Arcable a, Pointable a) => [(a,a)] -> [(a, a)] - intersectingNeighboringNodePairsOf inNodePairs = catMaybes $ (\(node1, node2) -> if intersectsInPoint node1 node2 then Just (node1, node2) else Nothing) <$> inNodePairs + intersectingNeighboringNodePairsOf inNodePairs = mapMaybe (\(node1, node2) -> if intersectsInPoint node1 node2 then Just (node1, node2) else Nothing) $ inNodePairs -- | find nodes that have output segments that are antiCollinear with one another. antiCollinearNodePairsOf :: (Pointable a, Arcable a) => [a] -> [(a, a)] - antiCollinearNodePairsOf inNodes = catMaybes $ (\(node1, node2) -> if nodesAreAntiCollinear node1 node2 then Just (node1, node2) else Nothing) <$> getPairs inNodes + antiCollinearNodePairsOf inNodes = mapMaybe (\(node1, node2) -> if nodesAreAntiCollinear node1 node2 then Just (node1, node2) else Nothing) $ getPairs inNodes -- | for a given pair of nodes, find the longest distance between one of the two nodes and the intersection of the two output plines. distanceToIntersection :: (Pointable a, Arcable a, Pointable b, Arcable b) => a -> b -> Maybe ℝ diff --git a/Graphics/Slicer/Math/Skeleton/Definitions.hs b/Graphics/Slicer/Math/Skeleton/Definitions.hs index 6b45e8ffb..4b0f7dde4 100644 --- a/Graphics/Slicer/Math/Skeleton/Definitions.hs +++ b/Graphics/Slicer/Math/Skeleton/Definitions.hs @@ -43,7 +43,7 @@ import Data.List.NonEmpty (NonEmpty) import Data.List.Unique (count_) -import Data.Maybe (Maybe(Just,Nothing), catMaybes, isJust) +import Data.Maybe (Maybe(Just,Nothing), isJust, mapMaybe) import Slist (len, cons, slist, isEmpty, safeLast) @@ -126,7 +126,7 @@ instance Pointable INode where allPLines = if hasArc iNode then slist $ nub $ (outAndErrOf iNode) : firstPLine : secondPLine : rawPLines else slist $ nub $ firstPLine : secondPLine : rawPLines - intersectionsOfPairs (Slist pLines _) = catMaybes $ (\(pl1, pl2) -> saneIntersect $ plinesIntersectIn pl1 pl2) <$> getPairs pLines + intersectionsOfPairs (Slist pLines _) = mapMaybe (\(pl1, pl2) -> saneIntersect $ plinesIntersectIn pl1 pl2) $ getPairs pLines where saneIntersect (IntersectsIn a _) = Just $ (\(CPPoint2 v) -> PPoint2 v) a saneIntersect _ = Nothing diff --git a/Graphics/Slicer/Math/Skeleton/Line.hs b/Graphics/Slicer/Math/Skeleton/Line.hs index 4b7c37ac0..5cef1785b 100644 --- a/Graphics/Slicer/Math/Skeleton/Line.hs +++ b/Graphics/Slicer/Math/Skeleton/Line.hs @@ -26,7 +26,7 @@ import Prelude ((==), concat, otherwise, (<$>), ($), (/=), error, (<>), show, (< import Data.List (sortOn, dropWhile, takeWhile, transpose) -import Data.Maybe (Maybe(Just,Nothing), catMaybes, fromMaybe) +import Data.Maybe (Maybe(Just,Nothing), fromMaybe, mapMaybe) import Safe (lastMay, initSafe) @@ -175,7 +175,7 @@ addInset insets distance faceSet | otherwise = error $ "out of order lineSegs generated from faces: " <> show faceSet <> "\n" <> show lineSegSets <> "\n" averagePoints p1 p2 = scalePoint 0.5 $ addPoints p1 p2 lineSegSets = fst <$> res - remainingFaces = concat $ catMaybes $ snd <$> res + remainingFaces = concat $ mapMaybe snd res res = addLineSegsToFace distance (Just 1) <$> (\(Slist a _) -> a) faceSet -- | Add infill to the area of a set of faces that was not covered in lines. diff --git a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs index d43b70388..e27301f5f 100644 --- a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs +++ b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs @@ -26,11 +26,11 @@ module Graphics.Slicer.Math.Skeleton.Motorcycles (CollisionType(HeadOn), CrashTree(CrashTree), motorcycleToENode, Collision(Collision), motorcycleIntersectsAt, intersectionSameSide, crashMotorcycles, collisionResult, convexMotorcycles, lastCrashType, motorcyclesAreAntiCollinear, motorcyclesInDivision, motorcycleMightIntersectWith, motorcycleDivisor) where -import Prelude (Bool(True, False), Either(Left,Right), Eq((==)), Show(show), Ordering (EQ, GT, LT), (&&), (<>), ($), (<$>), (<), (>), compare, error, fst, mempty, notElem, null, otherwise, realToFrac, zip) +import Prelude (Bool(True, False), Either(Left,Right), Eq((==)), Show(show), Ordering (EQ, GT, LT), (&&), (<>), ($), (<), (>), compare, error, fst, mempty, notElem, null, otherwise, realToFrac, zip) import Prelude as PL (init, last) -import Data.Maybe( Maybe(Just,Nothing), catMaybes, fromMaybe) +import Data.Maybe( Maybe(Just,Nothing), fromMaybe, mapMaybe) import Data.List (sortBy) @@ -163,7 +163,7 @@ crashMotorcycles contour holes -- | Find the non-reflex virtexes of a contour and draw motorcycles from them. Useful for contours that are a 'hole' in a bigger contour. -- This function is meant to be used on the exterior contour. convexMotorcycles :: Contour -> [Motorcycle] -convexMotorcycles contour = catMaybes $ onlyMotorcycles <$> zip (rotateLeft $ linePairs contour) (mapWithNeighbors convexPLines $ pointsOfContour contour) +convexMotorcycles contour = mapMaybe onlyMotorcycles $ zip (rotateLeft $ linePairs contour) (mapWithNeighbors convexPLines $ pointsOfContour contour) where rotateLeft a = PL.last a : PL.init a onlyMotorcycles :: ((LineSeg, LineSeg), Maybe (PLine2, PLine2Err)) -> Maybe Motorcycle @@ -229,7 +229,7 @@ motorcycleMightIntersectWith lineSegs motorcycle where intersections = getMotorcycleSegSetIntersections motorcycle lineSegs results :: Slist (LineSeg, Either Point2 CPPoint2) - results = slist $ sortByDistance $ catMaybes $ filterIntersection <$> intersections + results = slist $ sortByDistance $ mapMaybe filterIntersection intersections sortByDistance :: [(LineSeg, Either Point2 CPPoint2)] -> [(LineSeg, Either Point2 CPPoint2)] sortByDistance = sortBy compareDistances motorcyclePoint = canonicalizePPoint2 $ pPointOf motorcycle @@ -273,7 +273,7 @@ motorcycleIntersectsAt contour motorcycle = case intersections of ) $ filterIntersection a manyIntersections@(_:_) -> if len res > 0 then head res else error $ "no options: " <> show (len res) <> "\n" <> show res <> "\n" where - res = slist $ sortBy compareDistances $ catMaybes $ filterIntersection <$> manyIntersections + res = slist $ sortBy compareDistances $ mapMaybe filterIntersection manyIntersections compareDistances :: (LineSeg, Either Point2 CPPoint2) -> (LineSeg, Either Point2 CPPoint2) -> Ordering compareDistances i1 i2 = case i1 of (_, Right intersectionPPoint1) -> From f31594091fe9396d80af55a343ca4dec332c78df Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 26 Nov 2022 19:10:19 +0000 Subject: [PATCH 100/206] move getOutsideArc and towardIntersection into Arcs.hs. --- Graphics/Slicer/Math/Arcs.hs | 43 +++++++++++++++++++++--- Graphics/Slicer/Math/Ganja.hs | 4 ++- Graphics/Slicer/Math/Skeleton/Concave.hs | 42 +++-------------------- tests/Math/PGA.hs | 3 +- 4 files changed, 49 insertions(+), 43 deletions(-) diff --git a/Graphics/Slicer/Math/Arcs.hs b/Graphics/Slicer/Math/Arcs.hs index 3dac508a3..13b090690 100644 --- a/Graphics/Slicer/Math/Arcs.hs +++ b/Graphics/Slicer/Math/Arcs.hs @@ -20,15 +20,50 @@ This file contains code for calculating the inside and outside bisectors of two lines. -} -module Graphics.Slicer.Math.Arcs (getFirstArcWithErr, getInsideArcWithErr) where +module Graphics.Slicer.Math.Arcs (getFirstArcWithErr, getInsideArcWithErr, getOutsideArc, towardIntersection) where -import Prelude (($), (<>), (==), mempty, otherwise) +import Prelude (Bool, ($), (<>), (==), (>), (<=), (&&), error, fst, mempty, otherwise, realToFrac, show) import Graphics.Slicer.Math.Definitions (Point2, addPoints, distance, makeLineSeg, scalePoint) -import Graphics.Slicer.Math.GeometricAlgebra (addVecPairWithErr) +import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum), addVecPairWithErr, ulpVal) + +import Graphics.Slicer.Math.Intersections (intersectionOf, noIntersection) + +import Graphics.Slicer.Math.PGA (CPPoint2, ProjectiveLine2, ProjectivePoint2, PLine2(PLine2), PLine2Err(PLine2Err), angleBetween2PL, distance2PP, eToPL, flipL, join2PP, normalizeL, vecOfL) + +-- | Get a PLine along the angle bisector of the intersection of the two given line segments, pointing in the 'obtuse' direction. +-- Note: we normalize our output lines. +-- FIXME: the outer PLine returned by two PLines in the same direction should be two PLines, whch are the same line in both directions. +getOutsideArc :: (ProjectivePoint2 a, ProjectiveLine2 b, ProjectivePoint2 c, ProjectiveLine2 d) => a -> b -> c -> d -> (PLine2, PLine2Err) +getOutsideArc ppoint1 pline1 ppoint2 pline2 + | npline1 == npline2 = error "need to be able to return two PLines." + | noIntersection (pline1, mempty) (pline2, mempty) = error $ "no intersection between pline " <> show pline1 <> " and " <> show pline2 <> ".\n" + | l1TowardPoint && l2TowardPoint = (flipL resFlipped, resFlippedErr) + | l1TowardPoint = (flipL resNormal, resNormalErr) + | l2TowardPoint = (resNormal, resNormalErr) + | otherwise = (resFlipped, resFlippedErr) + where + (resNormal, resNormalErr) = getInsideArcWithErr pline1 pline2 + (resFlipped, resFlippedErr) = getInsideArcWithErr pline1 (flipL pline2) + npline1 = normalizeL pline1 + npline2 = normalizeL pline2 + intersectionPoint = fst $ intersectionOf (pline1, mempty) (pline2, mempty) + l1TowardPoint = towardIntersection ppoint1 pline1 intersectionPoint + l2TowardPoint = towardIntersection ppoint2 pline2 intersectionPoint + +-- | Determine if the line segment formed by the two given points starts with the first point, or the second. +-- Note: Due to numeric uncertainty, we cannot rely on Eq here, and must check the sign of the angle. +-- FIXME: shouldn't we be given an error component in our inputs? +towardIntersection :: (ProjectivePoint2 a, ProjectiveLine2 b) => a -> b -> CPPoint2 -> Bool +towardIntersection pp1 pl1 pp2 + | d <= realToFrac dErr = error $ "cannot resolve points finely enough.\nPPoint1: " <> show pp1 <> "\nPPoint2: " <> show pp2 <> "\nPLineIn: " <> show pl1 <> "\nnewPLine: " <> show newPLine <> "\n" + | otherwise = angleFound > realToFrac (ulpVal angleErr) + where + (angleFound, (_,_, angleErr)) = angleBetween2PL newPLine pl1 + (d, (_,_,UlpSum dErr)) = distance2PP (pp1, mempty) (pp2, mempty) + newPLine = fst $ join2PP pp1 pp2 -import Graphics.Slicer.Math.PGA (ProjectiveLine2, PLine2(PLine2), PLine2Err(PLine2Err), eToPL, flipL, normalizeL, vecOfL) -- | Get a PLine in the direction of the inside of the contour, at the angle bisector of the intersection of the line segment, and another segment from the end of the given line segment, toward the given point. -- Note that we normalize our output, but return it as a PLine2. this is safe, because double normalization (if it happens) only raises the ULP. diff --git a/Graphics/Slicer/Math/Ganja.hs b/Graphics/Slicer/Math/Ganja.hs index a860e3115..26286435f 100644 --- a/Graphics/Slicer/Math/Ganja.hs +++ b/Graphics/Slicer/Math/Ganja.hs @@ -106,6 +106,8 @@ import Test.QuickCheck (Arbitrary, Positive(Positive), NonZero(NonZero), arbitra -- The numeric type in HSlice. import Graphics.Slicer (ℝ) +import Graphics.Slicer.Math.Arcs (getOutsideArc) + import Graphics.Slicer.Math.Contour (makePointContour, maybeFlipContour, pointsOfContour, firstPointPairOfContour, pointFarOutsideContour) import Graphics.Slicer.Math.Definitions (Contour, Point2(Point2), LineSeg, endPoint, mapWithFollower, startPoint, makeLineSeg) @@ -116,7 +118,7 @@ import Graphics.Slicer.Math.Lossy (eToPLine2, join2PPoint2, normalizePLine2, pPo import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), PLine2(PLine2), PPoint2(PPoint2), PLine2Err, eToPL, eToPPoint2, flipL, normalizeL, translateRotatePPoint2WithErr, outOf, pPointOf, NPLine2(NPLine2)) -import Graphics.Slicer.Math.Skeleton.Concave (makeENode, getOutsideArc) +import Graphics.Slicer.Math.Skeleton.Concave (makeENode) import Graphics.Slicer.Math.Skeleton.Definitions(Cell(Cell), ENode, ENodeSet(ENodeSet), INode(INode), INodeSet(INodeSet), Motorcycle(Motorcycle), NodeTree(NodeTree), StraightSkeleton(StraightSkeleton), RemainingContour(RemainingContour), CellDivide(CellDivide), DividingMotorcycles(DividingMotorcycles), getFirstLineSeg, getLastLineSeg, makeINode) diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index 489b0f063..d24411ec2 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -26,9 +26,9 @@ -- So we can section tuples {-# LANGUAGE TupleSections #-} -module Graphics.Slicer.Math.Skeleton.Concave (skeletonOfConcaveRegion, findINodes, getOutsideArc, makeENode, makeENodes, averageNodes, eNodesOfOutsideContour, towardIntersection) where +module Graphics.Slicer.Math.Skeleton.Concave (skeletonOfConcaveRegion, findINodes, makeENode, makeENodes, averageNodes, eNodesOfOutsideContour) where -import Prelude (Eq, Show, Bool(True, False), Either(Left, Right), String, Ord, Ordering(GT,LT), notElem, otherwise, ($), (>), (<), (<$>), (==), (/=), (>=), error, (&&), fst, and, (<>), show, not, max, concat, compare, uncurry, null, (||), min, snd, filter, zip, any, (*), (+), Int, (.), (<=), (-), mempty, realToFrac) +import Prelude (Eq, Show, Bool(True, False), Either(Left, Right), String, Ord, Ordering(GT,LT), notElem, otherwise, ($), (>), (<), (<$>), (==), (/=), (>=), error, (&&), fst, and, (<>), show, not, max, concat, compare, uncurry, null, (||), min, snd, filter, zip, any, (*), (+), Int, (.), (-), mempty, realToFrac) import Prelude as PL (head, last, tail, init) @@ -50,19 +50,19 @@ import Slist as SL (head, last, tail) import Graphics.Implicit.Definitions (ℝ) -import Graphics.Slicer.Math.Arcs (getFirstArcWithErr, getInsideArcWithErr) +import Graphics.Slicer.Math.Arcs (getFirstArcWithErr, getInsideArcWithErr, getOutsideArc) import Graphics.Slicer.Math.Contour (lineSegsOfContour) import Graphics.Slicer.Math.Definitions (Contour, LineSeg(LineSeg), Point2, endPoint, mapWithFollower, fudgeFactor, startPoint) -import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum), ulpVal) +import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum)) import Graphics.Slicer.Math.Intersections (intersectionOf, intersectionBetween, isCollinear, isParallel, isAntiCollinear, noIntersection) import Graphics.Slicer.Math.Lossy (distancePPointToPLine, eToPLine2, normalizePLine2) -import Graphics.Slicer.Math.PGA (Arcable(errOfOut, hasArc, outOf), Pointable(canPoint, pPointOf), PLine2(PLine2), PLine2Err, ProjectivePoint2, CPPoint2(CPPoint2), PPoint2(PPoint2), distance2PP, flipL, outAndErrOf, pLineIsLeft, angleBetween2PL, distancePPointToPLineWithErr, join2PP, NPLine2(NPLine2)) +import Graphics.Slicer.Math.PGA (Arcable(errOfOut, hasArc, outOf), Pointable(canPoint, pPointOf), PLine2, PLine2Err, CPPoint2(CPPoint2), PPoint2(PPoint2), distance2PP, flipL, outAndErrOf, pLineIsLeft, distancePPointToPLineWithErr) import Graphics.Slicer.Math.Skeleton.Definitions (ENode(ENode), ENodeSet(ENodeSet), INode(INode), INodeSet(INodeSet), NodeTree(NodeTree), concavePLines, getFirstLineSeg, getLastLineSeg, finalOutOf, firstInOf, getPairs, indexPLinesTo, insOf, lastINodeOf, linePairs, makeINode, sortedPLinesWithErr, isLoop) @@ -192,38 +192,6 @@ averageNodes n1 n2 sortedPair :: (Arcable a, Arcable b) => a -> b -> [(PLine2, PLine2Err)] sortedPair n1 n2 = sortedPLinesWithErr [outAndErrOf n1, outAndErrOf n2] --- | Get a PLine along the angle bisector of the intersection of the two given line segments, pointing in the 'obtuse' direction. --- Note: we normalize our output lines. --- FIXME: the outer PLine returned by two PLines in the same direction should be two PLines, whch are the same line in both directions. -getOutsideArc :: (ProjectivePoint2 a) => a -> NPLine2 -> a -> NPLine2 -> (PLine2, PLine2Err) -getOutsideArc ppoint1 npline1 ppoint2 npline2 - | npline1 == npline2 = error "need to be able to return two PLines." - | noIntersection (pline1, mempty) (pline2, mempty) = error $ "no intersection between pline " <> show pline1 <> " and " <> show pline2 <> ".\n" - | l1TowardPoint && l2TowardPoint = (flipL resFlipped, resFlippedErr) - | l1TowardPoint = (flipL resNormal, resNormalErr) - | l2TowardPoint = (resNormal, resNormalErr) - | otherwise = (resFlipped, resFlippedErr) - where - (resNormal, resNormalErr) = getInsideArcWithErr pline1 pline2 - (resFlipped, resFlippedErr) = getInsideArcWithErr pline1 (flipL pline2) - pline1 = (\(NPLine2 v) -> PLine2 v) npline1 - pline2 = (\(NPLine2 v) -> PLine2 v) npline2 - intersectionPoint = fst $ intersectionOf (pline1, mempty) (pline2, mempty) - l1TowardPoint = towardIntersection ppoint1 pline1 intersectionPoint - l2TowardPoint = towardIntersection ppoint2 pline2 intersectionPoint - --- | Determine if the line segment formed by the two given points starts with the first point, or the second. --- Note: Due to numeric uncertainty, we cannot rely on Eq here, and must check the sign of the angle. --- FIXME: shouldn't we be given an error component in our inputs? -towardIntersection :: (ProjectivePoint2 a) => a -> PLine2 -> CPPoint2 -> Bool -towardIntersection pp1 pl1 pp2 - | d <= realToFrac dErr = error $ "cannot resolve points finely enough.\nPPoint1: " <> show pp1 <> "\nPPoint2: " <> show pp2 <> "\nPLineIn: " <> show pl1 <> "\nnewPLine: " <> show newPLine <> "\n" - | otherwise = angleFound > realToFrac (ulpVal angleErr) - where - (angleFound, (_,_, angleErr)) = angleBetween2PL newPLine pl1 - (d, (_,_,UlpSum dErr)) = distance2PP (pp1, mempty) (pp2, mempty) - newPLine = fst $ join2PP pp1 pp2 - -- | Make a first generation node. makeENode :: Point2 -> Point2 -> Point2 -> ENode makeENode p1 p2 p3 = ENode (p1,p2,p3) arc arcErr diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index df8f62db9..026a585ab 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -75,8 +75,9 @@ import Graphics.Slicer.Machine.Contour (shrinkContour, expandContour) import Graphics.Slicer.Machine.Infill (InfillType(Horiz, Vert), makeInfill) -- Our Facet library. +import Graphics.Slicer.Math.Arcs (getOutsideArc, towardIntersection) import Graphics.Slicer.Math.Skeleton.Cells (findFirstCellOfContour, findDivisions, findNextCell) -import Graphics.Slicer.Math.Skeleton.Concave (makeENode, makeENodes, averageNodes, getOutsideArc, towardIntersection) +import Graphics.Slicer.Math.Skeleton.Concave (makeENode, makeENodes, averageNodes) import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle), RemainingContour(RemainingContour), INode(INode), Cell(Cell), getFirstLineSeg, getLastLineSeg) import Graphics.Slicer.Math.Skeleton.Face (Face(Face), facesOf, orderedFacesOf) import Graphics.Slicer.Math.Skeleton.Line (addInset) From 31b3eda4d88eb47ba292ae93bd76f12be47fc8ab Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 27 Nov 2022 00:27:50 +0000 Subject: [PATCH 101/206] remove WithErr from names of Arc functions, and reorder Arcs.hs alphabetically. --- Graphics/Slicer/Math/Arcs.hs | 80 ++++++++++++------------ Graphics/Slicer/Math/Lossy.hs | 6 +- Graphics/Slicer/Math/Skeleton/Concave.hs | 8 +-- 3 files changed, 47 insertions(+), 47 deletions(-) diff --git a/Graphics/Slicer/Math/Arcs.hs b/Graphics/Slicer/Math/Arcs.hs index 13b090690..22fd0b8f3 100644 --- a/Graphics/Slicer/Math/Arcs.hs +++ b/Graphics/Slicer/Math/Arcs.hs @@ -20,7 +20,7 @@ This file contains code for calculating the inside and outside bisectors of two lines. -} -module Graphics.Slicer.Math.Arcs (getFirstArcWithErr, getInsideArcWithErr, getOutsideArc, towardIntersection) where +module Graphics.Slicer.Math.Arcs (getFirstArc, getInsideArc, getOutsideArc, towardIntersection) where import Prelude (Bool, ($), (<>), (==), (>), (<=), (&&), error, fst, mempty, otherwise, realToFrac, show) @@ -32,43 +32,10 @@ import Graphics.Slicer.Math.Intersections (intersectionOf, noIntersection) import Graphics.Slicer.Math.PGA (CPPoint2, ProjectiveLine2, ProjectivePoint2, PLine2(PLine2), PLine2Err(PLine2Err), angleBetween2PL, distance2PP, eToPL, flipL, join2PP, normalizeL, vecOfL) --- | Get a PLine along the angle bisector of the intersection of the two given line segments, pointing in the 'obtuse' direction. --- Note: we normalize our output lines. --- FIXME: the outer PLine returned by two PLines in the same direction should be two PLines, whch are the same line in both directions. -getOutsideArc :: (ProjectivePoint2 a, ProjectiveLine2 b, ProjectivePoint2 c, ProjectiveLine2 d) => a -> b -> c -> d -> (PLine2, PLine2Err) -getOutsideArc ppoint1 pline1 ppoint2 pline2 - | npline1 == npline2 = error "need to be able to return two PLines." - | noIntersection (pline1, mempty) (pline2, mempty) = error $ "no intersection between pline " <> show pline1 <> " and " <> show pline2 <> ".\n" - | l1TowardPoint && l2TowardPoint = (flipL resFlipped, resFlippedErr) - | l1TowardPoint = (flipL resNormal, resNormalErr) - | l2TowardPoint = (resNormal, resNormalErr) - | otherwise = (resFlipped, resFlippedErr) - where - (resNormal, resNormalErr) = getInsideArcWithErr pline1 pline2 - (resFlipped, resFlippedErr) = getInsideArcWithErr pline1 (flipL pline2) - npline1 = normalizeL pline1 - npline2 = normalizeL pline2 - intersectionPoint = fst $ intersectionOf (pline1, mempty) (pline2, mempty) - l1TowardPoint = towardIntersection ppoint1 pline1 intersectionPoint - l2TowardPoint = towardIntersection ppoint2 pline2 intersectionPoint - --- | Determine if the line segment formed by the two given points starts with the first point, or the second. --- Note: Due to numeric uncertainty, we cannot rely on Eq here, and must check the sign of the angle. --- FIXME: shouldn't we be given an error component in our inputs? -towardIntersection :: (ProjectivePoint2 a, ProjectiveLine2 b) => a -> b -> CPPoint2 -> Bool -towardIntersection pp1 pl1 pp2 - | d <= realToFrac dErr = error $ "cannot resolve points finely enough.\nPPoint1: " <> show pp1 <> "\nPPoint2: " <> show pp2 <> "\nPLineIn: " <> show pl1 <> "\nnewPLine: " <> show newPLine <> "\n" - | otherwise = angleFound > realToFrac (ulpVal angleErr) - where - (angleFound, (_,_, angleErr)) = angleBetween2PL newPLine pl1 - (d, (_,_,UlpSum dErr)) = distance2PP (pp1, mempty) (pp2, mempty) - newPLine = fst $ join2PP pp1 pp2 - - -- | Get a PLine in the direction of the inside of the contour, at the angle bisector of the intersection of the line segment, and another segment from the end of the given line segment, toward the given point. -- Note that we normalize our output, but return it as a PLine2. this is safe, because double normalization (if it happens) only raises the ULP. -getFirstArcWithErr :: Point2 -> Point2 -> Point2 -> (PLine2, PLine2Err) -getFirstArcWithErr p1 p2 p3 +getFirstArc :: Point2 -> Point2 -> Point2 -> (PLine2, PLine2Err) +getFirstArc p1 p2 p3 -- since we hawe two equal sides, we can draw a point ot the other side of the quad, and use it for constructing. | distance p2 p1 == distance p2 p3 = (PLine2 $ vecOfL quadRes, quadErr <> quadResErr) {- @@ -77,7 +44,7 @@ getFirstArcWithErr p1 p2 p3 -} | otherwise = (insideArc, insideArcErr) where - (insideArc, insideArcErr) = getInsideArcWithErr side1 side2 + (insideArc, insideArcErr) = getInsideArc side1 side2 -- FIXME: how do these errors effect the result? (side1, _) = normalizeL side1Raw (side1Raw, _) = eToPL (makeLineSeg p1 p2) @@ -96,10 +63,10 @@ getFirstArcWithErr p1 p2 p3 -} -- | Get a PLine along the angle bisector of the intersection of the two given line segments, pointing in the 'acute' direction. --- Note that we normalize our output, but don't bother normalizing our input lines, as the ones we output and the ones getFirstArcWithErr outputs are normalized. +-- Note that we normalize our output, but don't bother normalizing our input lines, as the ones we output and the ones getFirstArc outputs are normalized. -- Note that we know that the inside is to the right of the first line given, and that the first line points toward the intersection. -getInsideArcWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PLine2, PLine2Err) -getInsideArcWithErr line1 line2 +getInsideArc :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PLine2, PLine2Err) +getInsideArc line1 line2 -- | pline1 == pline2 = error "need to be able to return two PLines." | otherwise = (PLine2 $ vecOfL normRes, errTotal) where @@ -109,3 +76,36 @@ getInsideArcWithErr line1 line2 flippedPV1 = vecOfL $ flipL line1 pv2 = vecOfL line2 +-- | Get a PLine along the angle bisector of the intersection of the two given line segments, pointing in the 'obtuse' direction. +-- Note: we normalize our output lines. +-- FIXME: the outer PLine returned by two PLines in the same direction should be two PLines, whch are the same line in both directions. +getOutsideArc :: (ProjectivePoint2 a, ProjectiveLine2 b, ProjectivePoint2 c, ProjectiveLine2 d) => a -> b -> c -> d -> (PLine2, PLine2Err) +getOutsideArc ppoint1 pline1 ppoint2 pline2 + | npline1 == npline2 = error "need to be able to return two PLines." + | noIntersection (pline1, mempty) (pline2, mempty) = error $ "no intersection between pline " <> show pline1 <> " and " <> show pline2 <> ".\n" + | l1TowardPoint && l2TowardPoint = (flipL resFlipped, resFlippedErr) + | l1TowardPoint = (flipL resNormal, resNormalErr) + | l2TowardPoint = (resNormal, resNormalErr) + | otherwise = (resFlipped, resFlippedErr) + where + (resNormal, resNormalErr) = getInsideArc pline1 pline2 + (resFlipped, resFlippedErr) = getInsideArc pline1 (flipL pline2) + npline1 = normalizeL pline1 + npline2 = normalizeL pline2 + intersectionPoint = fst $ intersectionOf (pline1, mempty) (pline2, mempty) + l1TowardPoint = towardIntersection ppoint1 pline1 intersectionPoint + l2TowardPoint = towardIntersection ppoint2 pline2 intersectionPoint + +-- | Determine if the line segment formed by the two given points starts with the first point, or the second. +-- Note: Due to numeric uncertainty, we cannot rely on Eq here, and must check the sign of the angle. +-- FIXME: shouldn't we be given an error component in our inputs? +towardIntersection :: (ProjectivePoint2 a, ProjectiveLine2 b) => a -> b -> CPPoint2 -> Bool +towardIntersection pp1 pl1 pp2 + | d <= realToFrac dErr = error $ "cannot resolve points finely enough.\nPPoint1: " <> show pp1 <> "\nPPoint2: " <> show pp2 <> "\nPLineIn: " <> show pl1 <> "\nnewPLine: " <> show newPLine <> "\n" + | otherwise = angleFound > realToFrac (ulpVal angleErr) + where + (angleFound, (_,_, angleErr)) = angleBetween2PL newPLine pl1 + (d, (_,_,UlpSum dErr)) = distance2PP (pp1, mempty) (pp2, mempty) + newPLine = fst $ join2PP pp1 pp2 + + diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index 36703fd45..5a40edbb7 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -46,7 +46,7 @@ import Graphics.Slicer.Definitions (ℝ) import Graphics.Slicer.Math.Definitions (LineSeg, Point2, makeLineSeg) -import Graphics.Slicer.Math.Arcs (getFirstArcWithErr, getInsideArcWithErr) +import qualified Graphics.Slicer.Math.Arcs as Arcs (getFirstArc, getInsideArc) import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PPoint2, ProjectiveLine2, ProjectivePoint2, angleBetween2PL, canonicalizeP, distance2PP, distance2PL, distancePPointToPLineWithErr, eToPL, eToPPoint2, interpolate2PP, join2PP, normalizeL, pPointOnPerpWithErr, pToEP, translateL) @@ -81,10 +81,10 @@ eToPLine2 l1 = fst $ eToPL l1 -- | Get a PLine in the direction of the inside of the contour, at the angle bisector of the intersection of the line segment, and another segment from the end of the given line segment, toward the given point. getFirstArc :: Point2 -> Point2 -> Point2 -> PLine2 -getFirstArc p1 p2 p3 = fst $ getFirstArcWithErr p1 p2 p3 +getFirstArc p1 p2 p3 = fst $ Arcs.getFirstArc p1 p2 p3 getInsideArc :: PLine2 -> PLine2 -> PLine2 -getInsideArc pl1 pl2 = fst $ getInsideArcWithErr pl1 pl2 +getInsideArc pl1 pl2 = fst $ Arcs.getInsideArc pl1 pl2 -- | a typed join function. join two points, returning a line. join2PPoint2 :: (ProjectivePoint2 a) => a -> a -> PLine2 diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index d24411ec2..972a891c7 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -50,7 +50,7 @@ import Slist as SL (head, last, tail) import Graphics.Implicit.Definitions (ℝ) -import Graphics.Slicer.Math.Arcs (getFirstArcWithErr, getInsideArcWithErr, getOutsideArc) +import Graphics.Slicer.Math.Arcs (getFirstArc, getInsideArc, getOutsideArc) import Graphics.Slicer.Math.Contour (lineSegsOfContour) @@ -109,11 +109,11 @@ findINodes inSegSets | len inSegSets == 2 = -- Two walls, no closed ends. solve the ends of a hallway region, so we can then hand off the solutioning to our regular process. case initialENodes of - [] -> INodeSet $ slist [[makeINode [getInsideArcWithErr (flipL $ eToPLine2 firstSeg) (eToPLine2 lastSeg), getInsideArcWithErr (eToPLine2 firstSeg) (flipL $ eToPLine2 lastSeg)] Nothing]] + [] -> INodeSet $ slist [[makeINode [getInsideArc (flipL $ eToPLine2 firstSeg) (eToPLine2 lastSeg), getInsideArc (eToPLine2 firstSeg) (flipL $ eToPLine2 lastSeg)] Nothing]] where firstSeg = SL.head $ slist $ SL.head inSegSets lastSeg = SL.head $ slist $ SL.last inSegSets - [a] -> INodeSet $ slist [[makeINode [getInsideArcWithErr (eToPLine2 lastSeg) (eToPLine2 shortSide), getInsideArcWithErr (eToPLine2 firstSeg) (eToPLine2 shortSide)] (Just (flipL $ outOf a, errOfOut a))]] + [a] -> INodeSet $ slist [[makeINode [getInsideArc (eToPLine2 lastSeg) (eToPLine2 shortSide), getInsideArc (eToPLine2 firstSeg) (eToPLine2 shortSide)] (Just (flipL $ outOf a, errOfOut a))]] where firstSeg = fromMaybe (error "no first segment?") $ safeHead $ slist longSide lastSeg = SL.last $ slist longSide @@ -196,7 +196,7 @@ sortedPair n1 n2 = sortedPLinesWithErr [outAndErrOf n1, outAndErrOf n2] makeENode :: Point2 -> Point2 -> Point2 -> ENode makeENode p1 p2 p3 = ENode (p1,p2,p3) arc arcErr where - (arc, arcErr) = getFirstArcWithErr p1 p2 p3 + (arc, arcErr) = getFirstArc p1 p2 p3 -- | Make a first generation set of nodes, AKA, a set of arcs that come from the points where line segments meet, toward the inside of the contour. makeENodes :: [LineSeg] -> [ENode] From 6a7a608d59d988f23fc7aa8871073f82e361c060 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 27 Nov 2022 12:32:07 +0000 Subject: [PATCH 102/206] normalize lines before adding them when generating insideArcs. --- Graphics/Slicer/Math/Arcs.hs | 8 +++++--- tests/golden/C0-Faces-Default.ganja.js | 8 ++++---- tests/golden/C0-Faces-Ordered.ganja.js | 8 ++++---- tests/golden/C0-Straight_Skeleton.ganja.js | 8 ++++---- tests/golden/C1-Straight_Skeleton.ganja.js | 8 ++++---- tests/golden/C2-Straight_Skeleton.ganja.js | 8 ++++---- tests/golden/C3-Straight_Skeleton.ganja.js | 8 ++++---- tests/golden/C4-Straight_Skeleton.ganja.js | 8 ++++---- tests/golden/C5-Straight_Skeleton.ganja.js | 8 ++++---- tests/golden/C6-Straight_Skeleton.ganja.js | 4 ++-- tests/golden/C7-Cell2-NodeTree.ganja.js | 4 ++-- tests/golden/rectangle-Faces-Default.ganja.js | 14 +++++++++----- tests/golden/rectangle-Straight_Skeleton.ganja.js | 14 +++++++++----- 13 files changed, 59 insertions(+), 49 deletions(-) diff --git a/Graphics/Slicer/Math/Arcs.hs b/Graphics/Slicer/Math/Arcs.hs index 22fd0b8f3..7ada9a3c9 100644 --- a/Graphics/Slicer/Math/Arcs.hs +++ b/Graphics/Slicer/Math/Arcs.hs @@ -72,9 +72,11 @@ getInsideArc line1 line2 where errTotal = normErr <> PLine2Err addVecErrs mempty mempty mempty mempty mempty (normRes, normErr) = normalizeL $ PLine2 $ addVecRes - (addVecRes, addVecErrs) = addVecPairWithErr flippedPV1 pv2 - flippedPV1 = vecOfL $ flipL line1 - pv2 = vecOfL line2 + (addVecRes, addVecErrs) = addVecPairWithErr lv1 lv2 + lv1 = vecOfL $ flipL npline1 + lv2 = vecOfL npline2 + (npline1, npline1Err) = normalizeL line1 + (npline2, npline2Err) = normalizeL line2 -- | Get a PLine along the angle bisector of the intersection of the two given line segments, pointing in the 'obtuse' direction. -- Note: we normalize our output lines. diff --git a/tests/golden/C0-Faces-Default.ganja.js b/tests/golden/C0-Faces-Default.ganja.js index ac1675c73..d81c776f8 100644 --- a/tests/golden/C0-Faces-Default.ganja.js +++ b/tests/golden/C0-Faces-Default.ganja.js @@ -12,16 +12,16 @@ Algebra(2,0,1,()=>{ var aea = point(1.0,1.0); var aeb = point(-1.0,1.0); var af = 0.0e1-1.414213562373095e2+0.0e0; - var ag = -0.4142135623730951e1-0.17157287525380988e2+0.2426406871192852e0; + var ag = -0.41421356237309515e1-0.17157287525380993e2+0.24264068711928524e0; var ah = -0.3826834323650897e1-0.9238795325112867e2+0.541196100146197e0; var ai = 0.3826834323650897e1-0.9238795325112867e2-0.541196100146197e0; - var aj = 0.41421356237309515e1-0.17157287525380982e2-0.24264068711928521e0; + var aj = 0.41421356237309515e1-0.17157287525380993e2-0.24264068711928524e0; var ak = 0.0e1-1.414213562373095e2+0.0e0; var al = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; var am = 0.3826834323650897e1-0.9238795325112867e2-0.541196100146197e0; var an = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var ao = -0.4142135623730951e1-0.17157287525380988e2+0.2426406871192852e0; - var ap = 0.41421356237309515e1-0.17157287525380982e2-0.24264068711928521e0; + var ao = -0.41421356237309515e1-0.17157287525380993e2+0.24264068711928524e0; + var ap = 0.41421356237309515e1-0.17157287525380993e2-0.24264068711928524e0; var aq = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; var ar = -0.3826834323650897e1-0.9238795325112867e2+0.541196100146197e0; var as = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; diff --git a/tests/golden/C0-Faces-Ordered.ganja.js b/tests/golden/C0-Faces-Ordered.ganja.js index 00da3950f..17cea52f5 100644 --- a/tests/golden/C0-Faces-Ordered.ganja.js +++ b/tests/golden/C0-Faces-Ordered.ganja.js @@ -12,18 +12,18 @@ Algebra(2,0,1,()=>{ var aea = point(-1.0,1.0); var aeb = point(0.0,0.0); var af = 0.3826834323650897e1-0.9238795325112867e2-0.541196100146197e0; - var ag = 0.41421356237309515e1-0.17157287525380982e2-0.24264068711928521e0; + var ag = 0.41421356237309515e1-0.17157287525380993e2-0.24264068711928524e0; var ah = 0.0e1-1.414213562373095e2+0.0e0; var ai = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; var aj = 0.3826834323650897e1-0.9238795325112867e2-0.541196100146197e0; var ak = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var al = -0.4142135623730951e1-0.17157287525380988e2+0.2426406871192852e0; - var am = 0.41421356237309515e1-0.17157287525380982e2-0.24264068711928521e0; + var al = -0.41421356237309515e1-0.17157287525380993e2+0.24264068711928524e0; + var am = 0.41421356237309515e1-0.17157287525380993e2-0.24264068711928524e0; var an = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; var ao = -0.3826834323650897e1-0.9238795325112867e2+0.541196100146197e0; var ap = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; var aq = 0.0e1-1.414213562373095e2+0.0e0; - var ar = -0.4142135623730951e1-0.17157287525380988e2+0.2426406871192852e0; + var ar = -0.41421356237309515e1-0.17157287525380993e2+0.24264068711928524e0; var as = -0.3826834323650897e1-0.9238795325112867e2+0.541196100146197e0; document.body.appendChild(this.graph([ 0x882288, diff --git a/tests/golden/C0-Straight_Skeleton.ganja.js b/tests/golden/C0-Straight_Skeleton.ganja.js index ec90aa37e..0fe6060c5 100644 --- a/tests/golden/C0-Straight_Skeleton.ganja.js +++ b/tests/golden/C0-Straight_Skeleton.ganja.js @@ -13,13 +13,13 @@ Algebra(2,0,1,()=>{ var aeb = point(0.0,0.0); var afa = 0.3826834323650897e1-0.9238795325112867e2-0.541196100146197e0; var afb = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var afc = 0.41421356237309515e1-0.17157287525380982e2-0.24264068711928521e0; + var afc = 0.41421356237309515e1-0.17157287525380993e2-0.24264068711928524e0; var aga = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; var agb = -0.3826834323650897e1-0.9238795325112867e2+0.541196100146197e0; - var agc = -0.4142135623730951e1-0.17157287525380988e2+0.2426406871192852e0; + var agc = -0.41421356237309515e1-0.17157287525380993e2+0.24264068711928524e0; var aha = 0.0e1-1.414213562373095e2+0.0e0; - var ahb = 0.41421356237309515e1-0.17157287525380982e2-0.24264068711928521e0; - var ahc = -0.4142135623730951e1-0.17157287525380988e2+0.2426406871192852e0; + var ahb = 0.41421356237309515e1-0.17157287525380993e2-0.24264068711928524e0; + var ahc = -0.41421356237309515e1-0.17157287525380993e2+0.24264068711928524e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C1-Straight_Skeleton.ganja.js b/tests/golden/C1-Straight_Skeleton.ganja.js index 8cec104ad..0c76b7ec2 100644 --- a/tests/golden/C1-Straight_Skeleton.ganja.js +++ b/tests/golden/C1-Straight_Skeleton.ganja.js @@ -13,13 +13,13 @@ Algebra(2,0,1,()=>{ var aeb = point(-1.0,1.0); var afa = -0.7071067811865475e1-0.7071067811865475e2+0.0e0; var afb = 0.9238795325112867e1-0.3826834323650897e2+0.541196100146197e0; - var afc = 0.17157287525380988e1-0.4142135623730951e2+0.2426406871192852e0; + var afc = 0.17157287525380993e1-0.41421356237309515e2+0.24264068711928524e0; var aga = 0.9238795325112867e1+0.3826834323650897e2-0.541196100146197e0; var agb = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var agc = 0.17157287525380982e1+0.41421356237309515e2-0.24264068711928521e0; - var aha = 0.17157287525380988e1-0.4142135623730951e2+0.2426406871192852e0; + var agc = 0.17157287525380993e1+0.41421356237309515e2-0.24264068711928524e0; + var aha = 0.17157287525380993e1-0.41421356237309515e2+0.24264068711928524e0; var ahb = 1.414213562373095e1+0.0e2+0.0e0; - var ahc = 0.17157287525380982e1+0.41421356237309515e2-0.24264068711928521e0; + var ahc = 0.17157287525380993e1+0.41421356237309515e2-0.24264068711928524e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C2-Straight_Skeleton.ganja.js b/tests/golden/C2-Straight_Skeleton.ganja.js index f553b3e1a..43912f152 100644 --- a/tests/golden/C2-Straight_Skeleton.ganja.js +++ b/tests/golden/C2-Straight_Skeleton.ganja.js @@ -13,13 +13,13 @@ Algebra(2,0,1,()=>{ var aeb = point(-1.0,-1.0); var afa = 0.7071067811865475e1-0.7071067811865475e2+0.0e0; var afb = 0.3826834323650897e1+0.9238795325112867e2+0.541196100146197e0; - var afc = 0.4142135623730951e1+0.17157287525380988e2+0.2426406871192852e0; + var afc = 0.41421356237309515e1+0.17157287525380993e2+0.24264068711928524e0; var aga = -0.3826834323650897e1+0.9238795325112867e2-0.541196100146197e0; var agb = -0.7071067811865475e1-0.7071067811865475e2+0.0e0; - var agc = -0.41421356237309515e1+0.17157287525380982e2-0.24264068711928521e0; - var aha = 0.4142135623730951e1+0.17157287525380988e2+0.2426406871192852e0; + var agc = -0.41421356237309515e1+0.17157287525380993e2-0.24264068711928524e0; + var aha = 0.41421356237309515e1+0.17157287525380993e2+0.24264068711928524e0; var ahb = 0.0e1+1.414213562373095e2+0.0e0; - var ahc = -0.41421356237309515e1+0.17157287525380982e2-0.24264068711928521e0; + var ahc = -0.41421356237309515e1+0.17157287525380993e2-0.24264068711928524e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C3-Straight_Skeleton.ganja.js b/tests/golden/C3-Straight_Skeleton.ganja.js index b0e98fc59..e31f6f12c 100644 --- a/tests/golden/C3-Straight_Skeleton.ganja.js +++ b/tests/golden/C3-Straight_Skeleton.ganja.js @@ -13,13 +13,13 @@ Algebra(2,0,1,()=>{ var aeb = point(0.0,0.0); var afa = -0.9238795325112867e1-0.3826834323650897e2-0.541196100146197e0; var afb = 0.7071067811865475e1-0.7071067811865475e2+0.0e0; - var afc = -0.17157287525380982e1-0.41421356237309515e2-0.24264068711928521e0; + var afc = -0.17157287525380993e1-0.41421356237309515e2-0.24264068711928524e0; var aga = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; var agb = -0.9238795325112867e1+0.3826834323650897e2+0.541196100146197e0; - var agc = -0.17157287525380988e1+0.4142135623730951e2+0.2426406871192852e0; + var agc = -0.17157287525380993e1+0.41421356237309515e2+0.24264068711928524e0; var aha = -1.414213562373095e1+0.0e2+0.0e0; - var ahb = -0.17157287525380982e1-0.41421356237309515e2-0.24264068711928521e0; - var ahc = -0.17157287525380988e1+0.4142135623730951e2+0.2426406871192852e0; + var ahb = -0.17157287525380993e1-0.41421356237309515e2-0.24264068711928524e0; + var ahc = -0.17157287525380993e1+0.41421356237309515e2+0.24264068711928524e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C4-Straight_Skeleton.ganja.js b/tests/golden/C4-Straight_Skeleton.ganja.js index ec90aa37e..0fe6060c5 100644 --- a/tests/golden/C4-Straight_Skeleton.ganja.js +++ b/tests/golden/C4-Straight_Skeleton.ganja.js @@ -13,13 +13,13 @@ Algebra(2,0,1,()=>{ var aeb = point(0.0,0.0); var afa = 0.3826834323650897e1-0.9238795325112867e2-0.541196100146197e0; var afb = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var afc = 0.41421356237309515e1-0.17157287525380982e2-0.24264068711928521e0; + var afc = 0.41421356237309515e1-0.17157287525380993e2-0.24264068711928524e0; var aga = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; var agb = -0.3826834323650897e1-0.9238795325112867e2+0.541196100146197e0; - var agc = -0.4142135623730951e1-0.17157287525380988e2+0.2426406871192852e0; + var agc = -0.41421356237309515e1-0.17157287525380993e2+0.24264068711928524e0; var aha = 0.0e1-1.414213562373095e2+0.0e0; - var ahb = 0.41421356237309515e1-0.17157287525380982e2-0.24264068711928521e0; - var ahc = -0.4142135623730951e1-0.17157287525380988e2+0.2426406871192852e0; + var ahb = 0.41421356237309515e1-0.17157287525380993e2-0.24264068711928524e0; + var ahc = -0.41421356237309515e1-0.17157287525380993e2+0.24264068711928524e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C5-Straight_Skeleton.ganja.js b/tests/golden/C5-Straight_Skeleton.ganja.js index 56b6f8e2a..df01b96c2 100644 --- a/tests/golden/C5-Straight_Skeleton.ganja.js +++ b/tests/golden/C5-Straight_Skeleton.ganja.js @@ -15,14 +15,14 @@ Algebra(2,0,1,()=>{ var afb = point(0.0,0.0); var aga = 0.3826834323650897e1-0.9238795325112867e2-0.541196100146197e0; var agb = 0.9238795325112867e1+0.3826834323650899e2-0.5411961001461969e0; - var agc = 0.29289321881345265e1-0.29289321881345276e2-0.29289321881345265e0; + var agc = 0.2928932188134523e1-0.29289321881345265e2-0.2928932188134523e0; var aha = -0.9238795325112867e1+0.3826834323650899e2+0.5411961001461969e0; var ahb = -0.3826834323650897e1-0.9238795325112867e2+0.541196100146197e0; - var ahc = -0.2928932188134523e1-0.29289321881345265e2+0.2928932188134523e0; + var ahc = -0.29289321881345265e1-0.29289321881345276e2+0.29289321881345265e0; var aia = 0.0e1-1.414213562373095e2+0.0e0; - var aib = 0.29289321881345265e1-0.29289321881345276e2-0.29289321881345265e0; + var aib = 0.2928932188134523e1-0.29289321881345265e2-0.2928932188134523e0; var aic = 0.0e1+1.0e2+0.0e0; - var aid = -0.2928932188134523e1-0.29289321881345265e2+0.2928932188134523e0; + var aid = -0.29289321881345265e1-0.29289321881345276e2+0.29289321881345265e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C6-Straight_Skeleton.ganja.js b/tests/golden/C6-Straight_Skeleton.ganja.js index 5580c1543..faf8cd4cf 100644 --- a/tests/golden/C6-Straight_Skeleton.ganja.js +++ b/tests/golden/C6-Straight_Skeleton.ganja.js @@ -26,10 +26,10 @@ Algebra(2,0,1,()=>{ var ajc = 0.14412639668556793e1-0.5468566089394846e2+0.3778686232909291e0; var aka = 0.9932897335288758e1+0.11565251949756612e2-0.606432399999752e0; var akb = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var akc = 0.14412639668556804e1+0.5468566089394846e2-0.3778686232909291e0; + var akc = 0.14412639668556793e1+0.5468566089394846e2-0.3778686232909291e0; var ala = 0.14412639668556793e1-0.5468566089394846e2+0.3778686232909291e0; var alb = 1.7888543819998317e1+0.0e2+0.0e0; - var alc = 0.14412639668556804e1+0.5468566089394846e2-0.3778686232909291e0; + var alc = 0.14412639668556793e1+0.5468566089394846e2-0.3778686232909291e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C7-Cell2-NodeTree.ganja.js b/tests/golden/C7-Cell2-NodeTree.ganja.js index 557370d08..91ae7118a 100644 --- a/tests/golden/C7-Cell2-NodeTree.ganja.js +++ b/tests/golden/C7-Cell2-NodeTree.ganja.js @@ -5,8 +5,8 @@ Algebra(2,0,1,()=>{ var aab = point(0.0,-1.0); var aba = point(0.0,-1.0); var abb = point(1.0,-1.0); - var aca = 0.5547001962252291e1+0.8320502943378437e2+0.2773500981126146e0; - var acb = 0.9701425001453319e1+0.24253562503633297e2-0.24253562503633297e0; + var aca = 0.5257311121191336e1+0.85065080835204e2+0.3249196962329064e0; + var acb = 0.9732489894677302e1+0.22975292054736118e2-0.22975292054736118e0; var acc = -0.7071067811865475e1+0.7071067811865475e2+0.7071067811865475e0; document.body.appendChild(this.graph([ 0x882288, diff --git a/tests/golden/rectangle-Faces-Default.ganja.js b/tests/golden/rectangle-Faces-Default.ganja.js index 3a8199075..e54f4b7bb 100644 --- a/tests/golden/rectangle-Faces-Default.ganja.js +++ b/tests/golden/rectangle-Faces-Default.ganja.js @@ -12,11 +12,13 @@ Algebra(2,0,1,()=>{ var ae = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; var af = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; var ag = -0.7071067811865475e1-0.7071067811865475e2-0.7071067811865475e0; - var ah = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var ai = 0.7071067811865475e1-0.7071067811865475e2+0.7071067811865475e0; - var aj = -0.7071067811865475e1-0.7071067811865475e2-0.7071067811865475e0; - var ak = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var al = 0.7071067811865475e1-0.7071067811865475e2+0.7071067811865475e0; + var ah = 0.0e1+1.0e2+0.0e0; + var ai = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; + var aj = 0.7071067811865475e1-0.7071067811865475e2+0.7071067811865475e0; + var ak = -0.7071067811865475e1-0.7071067811865475e2-0.7071067811865475e0; + var al = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; + var am = 0.0e1+1.0e2+0.0e0; + var an = 0.7071067811865475e1-0.7071067811865475e2+0.7071067811865475e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], @@ -46,6 +48,8 @@ Algebra(2,0,1,()=>{ aj, "aj", ak, "ak", al, "al", + am, "am", + an, "an", ],{ grid: true, labels: true, diff --git a/tests/golden/rectangle-Straight_Skeleton.ganja.js b/tests/golden/rectangle-Straight_Skeleton.ganja.js index 7b9656cb1..b2dcaa58a 100644 --- a/tests/golden/rectangle-Straight_Skeleton.ganja.js +++ b/tests/golden/rectangle-Straight_Skeleton.ganja.js @@ -9,10 +9,12 @@ Algebra(2,0,1,()=>{ var acb = point(-2.0,1.0); var ada = point(-2.0,1.0); var adb = point(-2.0,-1.0); - var aea = 0.7071067811865475e1-0.7071067811865475e2+0.7071067811865475e0; - var aeb = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var aec = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var aed = -0.7071067811865475e1-0.7071067811865475e2-0.7071067811865475e0; + var aea = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; + var aeb = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; + var aec = 0.0e1+1.0e2+0.0e0; + var afa = 0.7071067811865475e1-0.7071067811865475e2+0.7071067811865475e0; + var afb = 0.0e1+1.0e2+0.0e0; + var afc = -0.7071067811865475e1-0.7071067811865475e2-0.7071067811865475e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], @@ -37,7 +39,9 @@ Algebra(2,0,1,()=>{ aea, "aea", aeb, "aeb", aec, "aec", - aed, "aed", + afa, "afa", + afb, "afb", + afc, "afc", ],{ grid: true, labels: true, From 8a327354d713404e6f84274d84ecd5e5ffd92fc4 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 27 Nov 2022 18:08:00 +0000 Subject: [PATCH 103/206] dont bother normalizing getInsideArc output. --- Graphics/Slicer/Math/Arcs.hs | 5 ++--- tests/golden/C0-Cell1-NodeTree.ganja.js | 4 ++-- .../C0-Cell1_And_Divide-NodeTree.ganja.js | 6 +++--- tests/golden/C0-Cell2-NodeTree.ganja.js | 4 ++-- .../C0-Cell2_And_Divide-NodeTree.ganja.js | 6 +++--- tests/golden/C0-Faces-Default.ganja.js | 8 ++++---- tests/golden/C0-Faces-Ordered.ganja.js | 8 ++++---- tests/golden/C0-NodeTree-TwoMerge.ganja.js | 12 +++++------ tests/golden/C0-NodeTree.ganja.js | 12 +++++------ tests/golden/C0-Straight_Skeleton.ganja.js | 4 ++-- tests/golden/C1-Cell1-NodeTree.ganja.js | 4 ++-- tests/golden/C1-Straight_Skeleton.ganja.js | 4 ++-- tests/golden/C2-Cell1-NodeTree.ganja.js | 4 ++-- tests/golden/C2-Straight_Skeleton.ganja.js | 4 ++-- tests/golden/C3-Straight_Skeleton.ganja.js | 4 ++-- tests/golden/C4-Straight_Skeleton.ganja.js | 4 ++-- tests/golden/C5-Straight_Skeleton.ganja.js | 16 +++++++-------- tests/golden/C6-Straight_Skeleton.ganja.js | 16 +++++++-------- tests/golden/C7-Cell2-NodeTree.ganja.js | 4 ++-- tests/golden/C7-Cell3-NodeTree.ganja.js | 8 ++++---- tests/golden/rectangle-Faces-Default.ganja.js | 20 +++++++++---------- .../rectangle-Straight_Skeleton.ganja.js | 12 +++++------ tests/golden/square-Faces-Default.ganja.js | 8 ++++---- .../golden/square-Straight_Skeleton.ganja.js | 8 ++++---- tests/golden/triangle-Faces-Default.ganja.js | 8 ++++---- .../triangle-Straight_Skeleton.ganja.js | 4 ++-- 26 files changed, 98 insertions(+), 99 deletions(-) diff --git a/Graphics/Slicer/Math/Arcs.hs b/Graphics/Slicer/Math/Arcs.hs index 7ada9a3c9..285a0a3f3 100644 --- a/Graphics/Slicer/Math/Arcs.hs +++ b/Graphics/Slicer/Math/Arcs.hs @@ -68,10 +68,9 @@ getFirstArc p1 p2 p3 getInsideArc :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PLine2, PLine2Err) getInsideArc line1 line2 -- | pline1 == pline2 = error "need to be able to return two PLines." - | otherwise = (PLine2 $ vecOfL normRes, errTotal) + | otherwise = (PLine2 addVecRes, errTotal) where - errTotal = normErr <> PLine2Err addVecErrs mempty mempty mempty mempty mempty - (normRes, normErr) = normalizeL $ PLine2 $ addVecRes + errTotal = PLine2Err addVecErrs mempty mempty mempty mempty mempty (addVecRes, addVecErrs) = addVecPairWithErr lv1 lv2 lv1 = vecOfL $ flipL npline1 lv2 = vecOfL npline2 diff --git a/tests/golden/C0-Cell1-NodeTree.ganja.js b/tests/golden/C0-Cell1-NodeTree.ganja.js index 942a95888..d1d29e187 100644 --- a/tests/golden/C0-Cell1-NodeTree.ganja.js +++ b/tests/golden/C0-Cell1-NodeTree.ganja.js @@ -8,8 +8,8 @@ Algebra(2,0,1,()=>{ var aca = point(-1.0,1.0); var acb = point(0.0,0.0); var ada = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var adb = -0.3826834323650897e1-0.9238795325112867e2+0.541196100146197e0; - var adc = -0.9807852804032305e1-0.19509032201612822e2+0.48706362218573185e0; + var adb = -0.7071067811865475e1-1.7071067811865475e2+1.0e0; + var adc = -1.0897902135516373e1-0.21677275132473917e2+0.541196100146197e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C0-Cell1_And_Divide-NodeTree.ganja.js b/tests/golden/C0-Cell1_And_Divide-NodeTree.ganja.js index 5c6b6d674..40f6e3f8f 100644 --- a/tests/golden/C0-Cell1_And_Divide-NodeTree.ganja.js +++ b/tests/golden/C0-Cell1_And_Divide-NodeTree.ganja.js @@ -10,9 +10,9 @@ Algebra(2,0,1,()=>{ var ada = point(0.0,0.0); var adb = point(-1.0,-1.0); var aea = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var aeb = -0.3826834323650897e1-0.9238795325112867e2+0.541196100146197e0; - var aec = -0.9807852804032305e1-0.19509032201612822e2+0.48706362218573185e0; - var afa = -0.9807852804032305e1-0.19509032201612822e2+0.48706362218573185e0; + var aeb = -0.7071067811865475e1-1.7071067811865475e2+1.0e0; + var aec = -1.0897902135516373e1-0.21677275132473917e2+0.541196100146197e0; + var afa = -1.0897902135516373e1-0.21677275132473917e2+0.541196100146197e0; var afb = 0.0e1-1.414213562373095e2+0.0e0; document.body.appendChild(this.graph([ 0x882288, diff --git a/tests/golden/C0-Cell2-NodeTree.ganja.js b/tests/golden/C0-Cell2-NodeTree.ganja.js index 8685410d8..73c711063 100644 --- a/tests/golden/C0-Cell2-NodeTree.ganja.js +++ b/tests/golden/C0-Cell2-NodeTree.ganja.js @@ -7,9 +7,9 @@ Algebra(2,0,1,()=>{ var abb = point(1.0,-1.0); var aca = point(1.0,-1.0); var acb = point(1.0,1.0); - var ada = 0.3826834323650897e1-0.9238795325112867e2-0.541196100146197e0; + var ada = 0.7071067811865475e1-1.7071067811865475e2-1.0e0; var adb = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var adc = 0.9807852804032305e1-0.19509032201612822e2-0.48706362218573185e0; + var adc = 1.0897902135516373e1-0.21677275132473917e2-0.541196100146197e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C0-Cell2_And_Divide-NodeTree.ganja.js b/tests/golden/C0-Cell2_And_Divide-NodeTree.ganja.js index fdc2be194..6696e0d1d 100644 --- a/tests/golden/C0-Cell2_And_Divide-NodeTree.ganja.js +++ b/tests/golden/C0-Cell2_And_Divide-NodeTree.ganja.js @@ -9,11 +9,11 @@ Algebra(2,0,1,()=>{ var acb = point(1.0,-1.0); var ada = point(1.0,-1.0); var adb = point(1.0,1.0); - var aea = 0.3826834323650897e1-0.9238795325112867e2-0.541196100146197e0; + var aea = 0.7071067811865475e1-1.7071067811865475e2-1.0e0; var aeb = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var aec = 0.9807852804032305e1-0.19509032201612822e2-0.48706362218573185e0; + var aec = 1.0897902135516373e1-0.21677275132473917e2-0.541196100146197e0; var afa = 0.0e1-1.414213562373095e2+0.0e0; - var afb = 0.9807852804032305e1-0.19509032201612822e2-0.48706362218573185e0; + var afb = 1.0897902135516373e1-0.21677275132473917e2-0.541196100146197e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C0-Faces-Default.ganja.js b/tests/golden/C0-Faces-Default.ganja.js index d81c776f8..b7ebb43e3 100644 --- a/tests/golden/C0-Faces-Default.ganja.js +++ b/tests/golden/C0-Faces-Default.ganja.js @@ -13,17 +13,17 @@ Algebra(2,0,1,()=>{ var aeb = point(-1.0,1.0); var af = 0.0e1-1.414213562373095e2+0.0e0; var ag = -0.41421356237309515e1-0.17157287525380993e2+0.24264068711928524e0; - var ah = -0.3826834323650897e1-0.9238795325112867e2+0.541196100146197e0; - var ai = 0.3826834323650897e1-0.9238795325112867e2-0.541196100146197e0; + var ah = -0.7071067811865475e1-1.7071067811865475e2+1.0e0; + var ai = 0.7071067811865475e1-1.7071067811865475e2-1.0e0; var aj = 0.41421356237309515e1-0.17157287525380993e2-0.24264068711928524e0; var ak = 0.0e1-1.414213562373095e2+0.0e0; var al = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var am = 0.3826834323650897e1-0.9238795325112867e2-0.541196100146197e0; + var am = 0.7071067811865475e1-1.7071067811865475e2-1.0e0; var an = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; var ao = -0.41421356237309515e1-0.17157287525380993e2+0.24264068711928524e0; var ap = 0.41421356237309515e1-0.17157287525380993e2-0.24264068711928524e0; var aq = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var ar = -0.3826834323650897e1-0.9238795325112867e2+0.541196100146197e0; + var ar = -0.7071067811865475e1-1.7071067811865475e2+1.0e0; var as = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; document.body.appendChild(this.graph([ 0x882288, diff --git a/tests/golden/C0-Faces-Ordered.ganja.js b/tests/golden/C0-Faces-Ordered.ganja.js index 17cea52f5..6a655fd63 100644 --- a/tests/golden/C0-Faces-Ordered.ganja.js +++ b/tests/golden/C0-Faces-Ordered.ganja.js @@ -11,20 +11,20 @@ Algebra(2,0,1,()=>{ var adb = point(-1.0,1.0); var aea = point(-1.0,1.0); var aeb = point(0.0,0.0); - var af = 0.3826834323650897e1-0.9238795325112867e2-0.541196100146197e0; + var af = 0.7071067811865475e1-1.7071067811865475e2-1.0e0; var ag = 0.41421356237309515e1-0.17157287525380993e2-0.24264068711928524e0; var ah = 0.0e1-1.414213562373095e2+0.0e0; var ai = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var aj = 0.3826834323650897e1-0.9238795325112867e2-0.541196100146197e0; + var aj = 0.7071067811865475e1-1.7071067811865475e2-1.0e0; var ak = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; var al = -0.41421356237309515e1-0.17157287525380993e2+0.24264068711928524e0; var am = 0.41421356237309515e1-0.17157287525380993e2-0.24264068711928524e0; var an = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var ao = -0.3826834323650897e1-0.9238795325112867e2+0.541196100146197e0; + var ao = -0.7071067811865475e1-1.7071067811865475e2+1.0e0; var ap = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; var aq = 0.0e1-1.414213562373095e2+0.0e0; var ar = -0.41421356237309515e1-0.17157287525380993e2+0.24264068711928524e0; - var as = -0.3826834323650897e1-0.9238795325112867e2+0.541196100146197e0; + var as = -0.7071067811865475e1-1.7071067811865475e2+1.0e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C0-NodeTree-TwoMerge.ganja.js b/tests/golden/C0-NodeTree-TwoMerge.ganja.js index d226a4335..0b63c4318 100644 --- a/tests/golden/C0-NodeTree-TwoMerge.ganja.js +++ b/tests/golden/C0-NodeTree-TwoMerge.ganja.js @@ -11,15 +11,15 @@ Algebra(2,0,1,()=>{ var adb = point(-1.0,1.0); var aea = point(-1.0,1.0); var aeb = point(0.0,0.0); - var afa = 0.3826834323650897e1-0.9238795325112867e2-0.541196100146197e0; + var afa = 0.7071067811865475e1-1.7071067811865475e2-1.0e0; var afb = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var afc = 0.9807852804032305e1-0.19509032201612822e2-0.48706362218573185e0; + var afc = 1.0897902135516373e1-0.21677275132473917e2-0.541196100146197e0; var aga = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var agb = -0.3826834323650897e1-0.9238795325112867e2+0.541196100146197e0; - var agc = -0.9807852804032305e1-0.19509032201612822e2+0.48706362218573185e0; + var agb = -0.7071067811865475e1-1.7071067811865475e2+1.0e0; + var agc = -1.0897902135516373e1-0.21677275132473917e2+0.541196100146197e0; var aha = 0.0e1-1.414213562373095e2+0.0e0; - var ahb = 0.9807852804032305e1-0.19509032201612822e2-0.48706362218573185e0; - var ahc = -0.9807852804032305e1-0.19509032201612822e2+0.48706362218573185e0; + var ahb = 1.0897902135516373e1-0.21677275132473917e2-0.541196100146197e0; + var ahc = -1.0897902135516373e1-0.21677275132473917e2+0.541196100146197e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C0-NodeTree.ganja.js b/tests/golden/C0-NodeTree.ganja.js index d226a4335..0b63c4318 100644 --- a/tests/golden/C0-NodeTree.ganja.js +++ b/tests/golden/C0-NodeTree.ganja.js @@ -11,15 +11,15 @@ Algebra(2,0,1,()=>{ var adb = point(-1.0,1.0); var aea = point(-1.0,1.0); var aeb = point(0.0,0.0); - var afa = 0.3826834323650897e1-0.9238795325112867e2-0.541196100146197e0; + var afa = 0.7071067811865475e1-1.7071067811865475e2-1.0e0; var afb = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var afc = 0.9807852804032305e1-0.19509032201612822e2-0.48706362218573185e0; + var afc = 1.0897902135516373e1-0.21677275132473917e2-0.541196100146197e0; var aga = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var agb = -0.3826834323650897e1-0.9238795325112867e2+0.541196100146197e0; - var agc = -0.9807852804032305e1-0.19509032201612822e2+0.48706362218573185e0; + var agb = -0.7071067811865475e1-1.7071067811865475e2+1.0e0; + var agc = -1.0897902135516373e1-0.21677275132473917e2+0.541196100146197e0; var aha = 0.0e1-1.414213562373095e2+0.0e0; - var ahb = 0.9807852804032305e1-0.19509032201612822e2-0.48706362218573185e0; - var ahc = -0.9807852804032305e1-0.19509032201612822e2+0.48706362218573185e0; + var ahb = 1.0897902135516373e1-0.21677275132473917e2-0.541196100146197e0; + var ahc = -1.0897902135516373e1-0.21677275132473917e2+0.541196100146197e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C0-Straight_Skeleton.ganja.js b/tests/golden/C0-Straight_Skeleton.ganja.js index 0fe6060c5..191e7ecbc 100644 --- a/tests/golden/C0-Straight_Skeleton.ganja.js +++ b/tests/golden/C0-Straight_Skeleton.ganja.js @@ -11,11 +11,11 @@ Algebra(2,0,1,()=>{ var adb = point(-1.0,1.0); var aea = point(-1.0,1.0); var aeb = point(0.0,0.0); - var afa = 0.3826834323650897e1-0.9238795325112867e2-0.541196100146197e0; + var afa = 0.7071067811865475e1-1.7071067811865475e2-1.0e0; var afb = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; var afc = 0.41421356237309515e1-0.17157287525380993e2-0.24264068711928524e0; var aga = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var agb = -0.3826834323650897e1-0.9238795325112867e2+0.541196100146197e0; + var agb = -0.7071067811865475e1-1.7071067811865475e2+1.0e0; var agc = -0.41421356237309515e1-0.17157287525380993e2+0.24264068711928524e0; var aha = 0.0e1-1.414213562373095e2+0.0e0; var ahb = 0.41421356237309515e1-0.17157287525380993e2-0.24264068711928524e0; diff --git a/tests/golden/C1-Cell1-NodeTree.ganja.js b/tests/golden/C1-Cell1-NodeTree.ganja.js index 6f3573d57..1dca33e88 100644 --- a/tests/golden/C1-Cell1-NodeTree.ganja.js +++ b/tests/golden/C1-Cell1-NodeTree.ganja.js @@ -7,9 +7,9 @@ Algebra(2,0,1,()=>{ var abb = point(1.0,1.0); var aca = point(1.0,1.0); var acb = point(-1.0,1.0); - var ada = 0.9238795325112867e1+0.3826834323650897e2-0.541196100146197e0; + var ada = 1.7071067811865475e1+0.7071067811865475e2-1.0e0; var adb = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var adc = 0.19509032201612822e1+0.9807852804032305e2-0.48706362218573185e0; + var adc = 0.21677275132473917e1+1.0897902135516373e2-0.541196100146197e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C1-Straight_Skeleton.ganja.js b/tests/golden/C1-Straight_Skeleton.ganja.js index 0c76b7ec2..75cf947a4 100644 --- a/tests/golden/C1-Straight_Skeleton.ganja.js +++ b/tests/golden/C1-Straight_Skeleton.ganja.js @@ -12,9 +12,9 @@ Algebra(2,0,1,()=>{ var aea = point(1.0,1.0); var aeb = point(-1.0,1.0); var afa = -0.7071067811865475e1-0.7071067811865475e2+0.0e0; - var afb = 0.9238795325112867e1-0.3826834323650897e2+0.541196100146197e0; + var afb = 1.7071067811865475e1-0.7071067811865475e2+1.0e0; var afc = 0.17157287525380993e1-0.41421356237309515e2+0.24264068711928524e0; - var aga = 0.9238795325112867e1+0.3826834323650897e2-0.541196100146197e0; + var aga = 1.7071067811865475e1+0.7071067811865475e2-1.0e0; var agb = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; var agc = 0.17157287525380993e1+0.41421356237309515e2-0.24264068711928524e0; var aha = 0.17157287525380993e1-0.41421356237309515e2+0.24264068711928524e0; diff --git a/tests/golden/C2-Cell1-NodeTree.ganja.js b/tests/golden/C2-Cell1-NodeTree.ganja.js index cd90766f8..e21cb2a79 100644 --- a/tests/golden/C2-Cell1-NodeTree.ganja.js +++ b/tests/golden/C2-Cell1-NodeTree.ganja.js @@ -7,9 +7,9 @@ Algebra(2,0,1,()=>{ var abb = point(-1.0,1.0); var aca = point(-1.0,1.0); var acb = point(-1.0,-1.0); - var ada = -0.3826834323650897e1+0.9238795325112867e2-0.541196100146197e0; + var ada = -0.7071067811865475e1+1.7071067811865475e2-1.0e0; var adb = -0.7071067811865475e1-0.7071067811865475e2+0.0e0; - var adc = -0.9807852804032305e1+0.19509032201612822e2-0.48706362218573185e0; + var adc = -1.0897902135516373e1+0.21677275132473917e2-0.541196100146197e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C2-Straight_Skeleton.ganja.js b/tests/golden/C2-Straight_Skeleton.ganja.js index 43912f152..fe62f7606 100644 --- a/tests/golden/C2-Straight_Skeleton.ganja.js +++ b/tests/golden/C2-Straight_Skeleton.ganja.js @@ -12,9 +12,9 @@ Algebra(2,0,1,()=>{ var aea = point(-1.0,1.0); var aeb = point(-1.0,-1.0); var afa = 0.7071067811865475e1-0.7071067811865475e2+0.0e0; - var afb = 0.3826834323650897e1+0.9238795325112867e2+0.541196100146197e0; + var afb = 0.7071067811865475e1+1.7071067811865475e2+1.0e0; var afc = 0.41421356237309515e1+0.17157287525380993e2+0.24264068711928524e0; - var aga = -0.3826834323650897e1+0.9238795325112867e2-0.541196100146197e0; + var aga = -0.7071067811865475e1+1.7071067811865475e2-1.0e0; var agb = -0.7071067811865475e1-0.7071067811865475e2+0.0e0; var agc = -0.41421356237309515e1+0.17157287525380993e2-0.24264068711928524e0; var aha = 0.41421356237309515e1+0.17157287525380993e2+0.24264068711928524e0; diff --git a/tests/golden/C3-Straight_Skeleton.ganja.js b/tests/golden/C3-Straight_Skeleton.ganja.js index e31f6f12c..686d10da5 100644 --- a/tests/golden/C3-Straight_Skeleton.ganja.js +++ b/tests/golden/C3-Straight_Skeleton.ganja.js @@ -11,11 +11,11 @@ Algebra(2,0,1,()=>{ var adb = point(1.0,1.0); var aea = point(1.0,1.0); var aeb = point(0.0,0.0); - var afa = -0.9238795325112867e1-0.3826834323650897e2-0.541196100146197e0; + var afa = -1.7071067811865475e1-0.7071067811865475e2-1.0e0; var afb = 0.7071067811865475e1-0.7071067811865475e2+0.0e0; var afc = -0.17157287525380993e1-0.41421356237309515e2-0.24264068711928524e0; var aga = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var agb = -0.9238795325112867e1+0.3826834323650897e2+0.541196100146197e0; + var agb = -1.7071067811865475e1+0.7071067811865475e2+1.0e0; var agc = -0.17157287525380993e1+0.41421356237309515e2+0.24264068711928524e0; var aha = -1.414213562373095e1+0.0e2+0.0e0; var ahb = -0.17157287525380993e1-0.41421356237309515e2-0.24264068711928524e0; diff --git a/tests/golden/C4-Straight_Skeleton.ganja.js b/tests/golden/C4-Straight_Skeleton.ganja.js index 0fe6060c5..191e7ecbc 100644 --- a/tests/golden/C4-Straight_Skeleton.ganja.js +++ b/tests/golden/C4-Straight_Skeleton.ganja.js @@ -11,11 +11,11 @@ Algebra(2,0,1,()=>{ var adb = point(-1.0,1.0); var aea = point(-1.0,1.0); var aeb = point(0.0,0.0); - var afa = 0.3826834323650897e1-0.9238795325112867e2-0.541196100146197e0; + var afa = 0.7071067811865475e1-1.7071067811865475e2-1.0e0; var afb = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; var afc = 0.41421356237309515e1-0.17157287525380993e2-0.24264068711928524e0; var aga = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var agb = -0.3826834323650897e1-0.9238795325112867e2+0.541196100146197e0; + var agb = -0.7071067811865475e1-1.7071067811865475e2+1.0e0; var agc = -0.41421356237309515e1-0.17157287525380993e2+0.24264068711928524e0; var aha = 0.0e1-1.414213562373095e2+0.0e0; var ahb = 0.41421356237309515e1-0.17157287525380993e2-0.24264068711928524e0; diff --git a/tests/golden/C5-Straight_Skeleton.ganja.js b/tests/golden/C5-Straight_Skeleton.ganja.js index df01b96c2..a5b227228 100644 --- a/tests/golden/C5-Straight_Skeleton.ganja.js +++ b/tests/golden/C5-Straight_Skeleton.ganja.js @@ -13,16 +13,16 @@ Algebra(2,0,1,()=>{ var aeb = point(-1.0,1.0); var afa = point(-1.0,1.0); var afb = point(0.0,0.0); - var aga = 0.3826834323650897e1-0.9238795325112867e2-0.541196100146197e0; - var agb = 0.9238795325112867e1+0.3826834323650899e2-0.5411961001461969e0; - var agc = 0.2928932188134523e1-0.29289321881345265e2-0.2928932188134523e0; - var aha = -0.9238795325112867e1+0.3826834323650899e2+0.5411961001461969e0; - var ahb = -0.3826834323650897e1-0.9238795325112867e2+0.541196100146197e0; - var ahc = -0.29289321881345265e1-0.29289321881345276e2+0.29289321881345265e0; + var aga = 0.7071067811865475e1-1.7071067811865475e2-1.0e0; + var agb = 0.7071067811865475e1+0.29289321881345254e2-0.4142135623730949e0; + var agc = 0.2928932188134524e1-0.29289321881345254e2-0.2928932188134524e0; + var aha = -0.7071067811865475e1+0.29289321881345254e2+0.4142135623730949e0; + var ahb = -0.7071067811865475e1-1.7071067811865475e2+1.0e0; + var ahc = -0.2928932188134526e1-0.29289321881345265e2+0.2928932188134526e0; var aia = 0.0e1-1.414213562373095e2+0.0e0; - var aib = 0.2928932188134523e1-0.29289321881345265e2-0.2928932188134523e0; + var aib = 0.2928932188134524e1-0.29289321881345254e2-0.2928932188134524e0; var aic = 0.0e1+1.0e2+0.0e0; - var aid = -0.29289321881345265e1-0.29289321881345276e2+0.29289321881345265e0; + var aid = -0.2928932188134526e1-0.29289321881345265e2+0.2928932188134526e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C6-Straight_Skeleton.ganja.js b/tests/golden/C6-Straight_Skeleton.ganja.js index faf8cd4cf..af1c4a7d0 100644 --- a/tests/golden/C6-Straight_Skeleton.ganja.js +++ b/tests/golden/C6-Straight_Skeleton.ganja.js @@ -15,16 +15,16 @@ Algebra(2,0,1,()=>{ var afb = point(1.0,1.0); var aga = point(1.0,1.0); var agb = point(-1.0,1.0); - var aha = 0.7071067811865475e1-0.7071067811865475e2+0.0e0; - var ahb = 0.8506508083520399e1+0.5257311121191337e2+0.9510565162951536e0; - var ahc = 0.9932897335288758e1-0.11565251949756612e2+0.606432399999752e0; - var aia = 0.8506508083520399e1-0.5257311121191337e2-0.9510565162951536e0; - var aib = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var aic = 0.9932897335288758e1+0.11565251949756612e2-0.606432399999752e0; + var aha = 1.0e1-1.0e2+0.0e0; + var ahb = 0.8944271909999159e1+0.5527864045000421e2+1.0e0; + var ahc = 1.5577575895385873e1-0.18137566906741376e2+0.9510565162951536e0; + var aia = 0.8944271909999159e1-0.5527864045000421e2-1.0e0; + var aib = 1.0e1+1.0e2+0.0e0; + var aic = 1.5577575895385873e1+0.18137566906741376e2-0.9510565162951536e0; var aja = -0.7071067811865475e1-0.7071067811865475e2+0.0e0; - var ajb = 0.9932897335288758e1-0.11565251949756612e2+0.606432399999752e0; + var ajb = 1.5577575895385873e1-0.18137566906741376e2+0.9510565162951536e0; var ajc = 0.14412639668556793e1-0.5468566089394846e2+0.3778686232909291e0; - var aka = 0.9932897335288758e1+0.11565251949756612e2-0.606432399999752e0; + var aka = 1.5577575895385873e1+0.18137566906741376e2-0.9510565162951536e0; var akb = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; var akc = 0.14412639668556793e1+0.5468566089394846e2-0.3778686232909291e0; var ala = 0.14412639668556793e1-0.5468566089394846e2+0.3778686232909291e0; diff --git a/tests/golden/C7-Cell2-NodeTree.ganja.js b/tests/golden/C7-Cell2-NodeTree.ganja.js index 91ae7118a..f1af27bbc 100644 --- a/tests/golden/C7-Cell2-NodeTree.ganja.js +++ b/tests/golden/C7-Cell2-NodeTree.ganja.js @@ -5,8 +5,8 @@ Algebra(2,0,1,()=>{ var aab = point(0.0,-1.0); var aba = point(0.0,-1.0); var abb = point(1.0,-1.0); - var aca = 0.5257311121191336e1+0.85065080835204e2+0.3249196962329064e0; - var acb = 0.9732489894677302e1+0.22975292054736118e2-0.22975292054736118e0; + var aca = 0.8944271909999159e1+1.4472135954999579e2+0.5527864045000421e0; + var acb = 1.8944271909999157e1+0.4472135954999579e2-0.4472135954999579e0; var acc = -0.7071067811865475e1+0.7071067811865475e2+0.7071067811865475e0; document.body.appendChild(this.graph([ 0x882288, diff --git a/tests/golden/C7-Cell3-NodeTree.ganja.js b/tests/golden/C7-Cell3-NodeTree.ganja.js index a040d10d6..31141aa89 100644 --- a/tests/golden/C7-Cell3-NodeTree.ganja.js +++ b/tests/golden/C7-Cell3-NodeTree.ganja.js @@ -11,10 +11,10 @@ Algebra(2,0,1,()=>{ var adb = point(0.0,0.0); var aea = -0.7071067811865475e1-0.7071067811865475e2+0.0e0; var aeb = 0.7071067811865475e1-0.7071067811865475e2+0.7071067811865475e0; - var aec = 0.0e1-1.0e2+0.5e0; - var afa = -0.8506508083520399e1+0.5257311121191337e2-0.5257311121191337e0; - var afb = 0.0e1-1.0e2+0.5e0; - var afc = -0.8734217515379193e1-0.48696452020699943e2-0.026419904378450296e0; + var aec = 0.0e1-1.4142135623730951e2+0.7071067811865476e0; + var afa = -0.8944271909999159e1+0.5527864045000421e2-0.5527864045000421e0; + var afb = 0.0e1-1.4142135623730951e2+0.7071067811865476e0; + var afc = -0.8506508083520399e1-0.4742688878808663e2-0.025731112119133703e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/rectangle-Faces-Default.ganja.js b/tests/golden/rectangle-Faces-Default.ganja.js index e54f4b7bb..6513c9c07 100644 --- a/tests/golden/rectangle-Faces-Default.ganja.js +++ b/tests/golden/rectangle-Faces-Default.ganja.js @@ -9,16 +9,16 @@ Algebra(2,0,1,()=>{ var acb = point(-2.0,-1.0); var ada = point(-2.0,-1.0); var adb = point(1.0,-1.0); - var ae = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var af = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var ag = -0.7071067811865475e1-0.7071067811865475e2-0.7071067811865475e0; - var ah = 0.0e1+1.0e2+0.0e0; - var ai = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var aj = 0.7071067811865475e1-0.7071067811865475e2+0.7071067811865475e0; - var ak = -0.7071067811865475e1-0.7071067811865475e2-0.7071067811865475e0; - var al = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var am = 0.0e1+1.0e2+0.0e0; - var an = 0.7071067811865475e1-0.7071067811865475e2+0.7071067811865475e0; + var ae = -1.0e1+1.0e2+0.0e0; + var af = 1.0e1+1.0e2+0.0e0; + var ag = -1.0e1-1.0e2-1.0e0; + var ah = 0.0e1+1.414213562373095e2+0.0e0; + var ai = -1.0e1+1.0e2+0.0e0; + var aj = 1.0e1-1.0e2+1.0e0; + var ak = -1.0e1-1.0e2-1.0e0; + var al = 1.0e1+1.0e2+0.0e0; + var am = 0.0e1+1.414213562373095e2+0.0e0; + var an = 1.0e1-1.0e2+1.0e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/rectangle-Straight_Skeleton.ganja.js b/tests/golden/rectangle-Straight_Skeleton.ganja.js index b2dcaa58a..a41b2ad7e 100644 --- a/tests/golden/rectangle-Straight_Skeleton.ganja.js +++ b/tests/golden/rectangle-Straight_Skeleton.ganja.js @@ -9,12 +9,12 @@ Algebra(2,0,1,()=>{ var acb = point(-2.0,1.0); var ada = point(-2.0,1.0); var adb = point(-2.0,-1.0); - var aea = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var aeb = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var aec = 0.0e1+1.0e2+0.0e0; - var afa = 0.7071067811865475e1-0.7071067811865475e2+0.7071067811865475e0; - var afb = 0.0e1+1.0e2+0.0e0; - var afc = -0.7071067811865475e1-0.7071067811865475e2-0.7071067811865475e0; + var aea = 1.0e1+1.0e2+0.0e0; + var aeb = -1.0e1+1.0e2+0.0e0; + var aec = 0.0e1+1.414213562373095e2+0.0e0; + var afa = 1.0e1-1.0e2+1.0e0; + var afb = 0.0e1+1.414213562373095e2+0.0e0; + var afc = -1.0e1-1.0e2-1.0e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/square-Faces-Default.ganja.js b/tests/golden/square-Faces-Default.ganja.js index 66bd957c3..0740b2db1 100644 --- a/tests/golden/square-Faces-Default.ganja.js +++ b/tests/golden/square-Faces-Default.ganja.js @@ -10,14 +10,14 @@ Algebra(2,0,1,()=>{ var ada = point(1.0,1.0); var adb = point(-1.0,1.0); var ae = 0.7071067811865475e1-0.7071067811865475e2+0.0e0; - var af = 1.0e1+0.0e2+0.0e0; - var ag = -1.0e1+0.0e2+0.0e0; + var af = 1.4142135623730951e1+0.0e2+0.0e0; + var ag = -1.4142135623730951e1+0.0e2+0.0e0; var ah = -0.7071067811865475e1-0.7071067811865475e2+0.0e0; var ai = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; var aj = 0.7071067811865475e1-0.7071067811865475e2+0.0e0; var ak = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var al = -1.0e1+0.0e2+0.0e0; - var am = 1.0e1+0.0e2+0.0e0; + var al = -1.4142135623730951e1+0.0e2+0.0e0; + var am = 1.4142135623730951e1+0.0e2+0.0e0; var an = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; var ao = -0.7071067811865475e1-0.7071067811865475e2+0.0e0; var ap = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; diff --git a/tests/golden/square-Straight_Skeleton.ganja.js b/tests/golden/square-Straight_Skeleton.ganja.js index dc3fbc87f..6843a725b 100644 --- a/tests/golden/square-Straight_Skeleton.ganja.js +++ b/tests/golden/square-Straight_Skeleton.ganja.js @@ -11,12 +11,12 @@ Algebra(2,0,1,()=>{ var adb = point(-1.0,-1.0); var aea = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; var aeb = -0.7071067811865475e1-0.7071067811865475e2+0.0e0; - var aec = -1.0e1+0.0e2+0.0e0; + var aec = -1.4142135623730951e1+0.0e2+0.0e0; var afa = 0.7071067811865475e1-0.7071067811865475e2+0.0e0; var afb = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var afc = 1.0e1+0.0e2+0.0e0; - var aga = 1.0e1+0.0e2+0.0e0; - var agb = -1.0e1+0.0e2+0.0e0; + var afc = 1.4142135623730951e1+0.0e2+0.0e0; + var aga = 1.4142135623730951e1+0.0e2+0.0e0; + var agb = -1.4142135623730951e1+0.0e2+0.0e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/triangle-Faces-Default.ganja.js b/tests/golden/triangle-Faces-Default.ganja.js index 2cb151399..1fd24236c 100644 --- a/tests/golden/triangle-Faces-Default.ganja.js +++ b/tests/golden/triangle-Faces-Default.ganja.js @@ -7,11 +7,11 @@ Algebra(2,0,1,()=>{ var abb = point(1.0,1.7320508075688772); var aca = point(1.0,1.7320508075688772); var acb = point(0.0,0.0); - var ad = 0.5000000000000001e1+0.8660254037844387e2-1.0000000000000002e0; - var ae = 0.5000000000000001e1-0.8660254037844387e2+0.0e0; + var ad = 0.8660254037844387e1+1.5e2-1.7320508075688774e0; + var ae = 0.8660254037844387e1-1.5e2+0.0e0; var af = -1.0e1+0.0e2+1.0e0; - var ag = 0.5000000000000001e1+0.8660254037844387e2-1.0000000000000002e0; - var ah = 0.5000000000000001e1-0.8660254037844387e2+0.0e0; + var ag = 0.8660254037844387e1+1.5e2-1.7320508075688774e0; + var ah = 0.8660254037844387e1-1.5e2+0.0e0; var ai = -1.0e1+0.0e2+1.0e0; document.body.appendChild(this.graph([ 0x882288, diff --git a/tests/golden/triangle-Straight_Skeleton.ganja.js b/tests/golden/triangle-Straight_Skeleton.ganja.js index 1ef53ac70..b368bd9f3 100644 --- a/tests/golden/triangle-Straight_Skeleton.ganja.js +++ b/tests/golden/triangle-Straight_Skeleton.ganja.js @@ -8,8 +8,8 @@ Algebra(2,0,1,()=>{ var aca = point(2.0,0.0); var acb = point(1.0,1.7320508075688772); var ada = -1.0e1+0.0e2+1.0e0; - var adb = 0.5000000000000001e1-0.8660254037844387e2+0.0e0; - var adc = 0.5000000000000001e1+0.8660254037844387e2-1.0000000000000002e0; + var adb = 0.8660254037844387e1-1.5e2+0.0e0; + var adc = 0.8660254037844387e1+1.5e2-1.7320508075688774e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], From 167f831d18bcf39991ce12e3b9d39b4af45b30e9 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 27 Nov 2022 22:12:14 +0000 Subject: [PATCH 104/206] skip normalization in output of getFirstArc. --- Graphics/Slicer/Math/Arcs.hs | 4 +--- tests/golden/C0-Cell1-NodeTree.ganja.js | 4 ++-- .../C0-Cell1_And_Divide-NodeTree.ganja.js | 6 ++--- tests/golden/C0-Cell2-NodeTree.ganja.js | 4 ++-- .../C0-Cell2_And_Divide-NodeTree.ganja.js | 6 ++--- tests/golden/C0-Faces-Default.ganja.js | 16 ++++++------- tests/golden/C0-Faces-Ordered.ganja.js | 16 ++++++------- tests/golden/C0-NodeTree-TwoMerge.ganja.js | 12 +++++----- tests/golden/C0-NodeTree.ganja.js | 12 +++++----- tests/golden/C0-Straight_Skeleton.ganja.js | 12 +++++----- tests/golden/C1-Cell1-NodeTree.ganja.js | 4 ++-- tests/golden/C1-Straight_Skeleton.ganja.js | 12 +++++----- tests/golden/C2-Cell1-NodeTree.ganja.js | 4 ++-- tests/golden/C2-Straight_Skeleton.ganja.js | 12 +++++----- tests/golden/C3-Straight_Skeleton.ganja.js | 12 +++++----- tests/golden/C4-Straight_Skeleton.ganja.js | 12 +++++----- tests/golden/C6-Straight_Skeleton.ganja.js | 4 ++-- tests/golden/C7-Cell2-NodeTree.ganja.js | 2 +- tests/golden/C7-Cell3-NodeTree.ganja.js | 8 +++---- tests/golden/square-Faces-Default.ganja.js | 24 +++++++++---------- .../golden/square-Straight_Skeleton.ganja.js | 16 ++++++------- tests/golden/triangle-Faces-Default.ganja.js | 4 ++-- .../triangle-Straight_Skeleton.ganja.js | 2 +- 23 files changed, 103 insertions(+), 105 deletions(-) diff --git a/Graphics/Slicer/Math/Arcs.hs b/Graphics/Slicer/Math/Arcs.hs index 285a0a3f3..26445b95b 100644 --- a/Graphics/Slicer/Math/Arcs.hs +++ b/Graphics/Slicer/Math/Arcs.hs @@ -37,7 +37,7 @@ import Graphics.Slicer.Math.PGA (CPPoint2, ProjectiveLine2, ProjectivePoint2, PL getFirstArc :: Point2 -> Point2 -> Point2 -> (PLine2, PLine2Err) getFirstArc p1 p2 p3 -- since we hawe two equal sides, we can draw a point ot the other side of the quad, and use it for constructing. - | distance p2 p1 == distance p2 p3 = (PLine2 $ vecOfL quadRes, quadErr <> quadResErr) + | distance p2 p1 == distance p2 p3 = (quad, quadErr) {- | distance p2 p1 > distance p2 p3 = scaleSide p1 p3 True (distance p2 p1 / distance p2 p3) | otherwise = scaleSide p3 p1 True (distance p2 p3 / distance p2 p1) @@ -50,7 +50,6 @@ getFirstArc p1 p2 p3 (side1Raw, _) = eToPL (makeLineSeg p1 p2) (side2, _) = normalizeL side2Raw (side2Raw, _) = eToPL (makeLineSeg p2 p3) - (quadRes, quadResErr) = normalizeL quad (quad, quadErr) = eToPL $ makeLineSeg p2 $ scalePoint 0.5 $ addPoints p1 p3 {- scaleSide ps1 ps2 t v @@ -63,7 +62,6 @@ getFirstArc p1 p2 p3 -} -- | Get a PLine along the angle bisector of the intersection of the two given line segments, pointing in the 'acute' direction. --- Note that we normalize our output, but don't bother normalizing our input lines, as the ones we output and the ones getFirstArc outputs are normalized. -- Note that we know that the inside is to the right of the first line given, and that the first line points toward the intersection. getInsideArc :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PLine2, PLine2Err) getInsideArc line1 line2 diff --git a/tests/golden/C0-Cell1-NodeTree.ganja.js b/tests/golden/C0-Cell1-NodeTree.ganja.js index d1d29e187..e0cd91a50 100644 --- a/tests/golden/C0-Cell1-NodeTree.ganja.js +++ b/tests/golden/C0-Cell1-NodeTree.ganja.js @@ -7,9 +7,9 @@ Algebra(2,0,1,()=>{ var abb = point(-1.0,1.0); var aca = point(-1.0,1.0); var acb = point(0.0,0.0); - var ada = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; + var ada = -1.0e1+1.0e2+0.0e0; var adb = -0.7071067811865475e1-1.7071067811865475e2+1.0e0; - var adc = -1.0897902135516373e1-0.21677275132473917e2+0.541196100146197e0; + var adc = -1.089790213551637e1-0.21677275132473928e2+0.541196100146197e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C0-Cell1_And_Divide-NodeTree.ganja.js b/tests/golden/C0-Cell1_And_Divide-NodeTree.ganja.js index 40f6e3f8f..64bf3a1d0 100644 --- a/tests/golden/C0-Cell1_And_Divide-NodeTree.ganja.js +++ b/tests/golden/C0-Cell1_And_Divide-NodeTree.ganja.js @@ -9,10 +9,10 @@ Algebra(2,0,1,()=>{ var acb = point(0.0,0.0); var ada = point(0.0,0.0); var adb = point(-1.0,-1.0); - var aea = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; + var aea = -1.0e1+1.0e2+0.0e0; var aeb = -0.7071067811865475e1-1.7071067811865475e2+1.0e0; - var aec = -1.0897902135516373e1-0.21677275132473917e2+0.541196100146197e0; - var afa = -1.0897902135516373e1-0.21677275132473917e2+0.541196100146197e0; + var aec = -1.089790213551637e1-0.21677275132473928e2+0.541196100146197e0; + var afa = -1.089790213551637e1-0.21677275132473928e2+0.541196100146197e0; var afb = 0.0e1-1.414213562373095e2+0.0e0; document.body.appendChild(this.graph([ 0x882288, diff --git a/tests/golden/C0-Cell2-NodeTree.ganja.js b/tests/golden/C0-Cell2-NodeTree.ganja.js index 73c711063..379678c2a 100644 --- a/tests/golden/C0-Cell2-NodeTree.ganja.js +++ b/tests/golden/C0-Cell2-NodeTree.ganja.js @@ -8,8 +8,8 @@ Algebra(2,0,1,()=>{ var aca = point(1.0,-1.0); var acb = point(1.0,1.0); var ada = 0.7071067811865475e1-1.7071067811865475e2-1.0e0; - var adb = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var adc = 1.0897902135516373e1-0.21677275132473917e2-0.541196100146197e0; + var adb = 1.0e1+1.0e2+0.0e0; + var adc = 1.089790213551637e1-0.21677275132473928e2-0.541196100146197e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C0-Cell2_And_Divide-NodeTree.ganja.js b/tests/golden/C0-Cell2_And_Divide-NodeTree.ganja.js index 6696e0d1d..e969d21a5 100644 --- a/tests/golden/C0-Cell2_And_Divide-NodeTree.ganja.js +++ b/tests/golden/C0-Cell2_And_Divide-NodeTree.ganja.js @@ -10,10 +10,10 @@ Algebra(2,0,1,()=>{ var ada = point(1.0,-1.0); var adb = point(1.0,1.0); var aea = 0.7071067811865475e1-1.7071067811865475e2-1.0e0; - var aeb = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var aec = 1.0897902135516373e1-0.21677275132473917e2-0.541196100146197e0; + var aeb = 1.0e1+1.0e2+0.0e0; + var aec = 1.089790213551637e1-0.21677275132473928e2-0.541196100146197e0; var afa = 0.0e1-1.414213562373095e2+0.0e0; - var afb = 1.0897902135516373e1-0.21677275132473917e2-0.541196100146197e0; + var afb = 1.089790213551637e1-0.21677275132473928e2-0.541196100146197e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C0-Faces-Default.ganja.js b/tests/golden/C0-Faces-Default.ganja.js index b7ebb43e3..78d7da555 100644 --- a/tests/golden/C0-Faces-Default.ganja.js +++ b/tests/golden/C0-Faces-Default.ganja.js @@ -12,19 +12,19 @@ Algebra(2,0,1,()=>{ var aea = point(1.0,1.0); var aeb = point(-1.0,1.0); var af = 0.0e1-1.414213562373095e2+0.0e0; - var ag = -0.41421356237309515e1-0.17157287525380993e2+0.24264068711928524e0; + var ag = -0.4142135623730951e1-0.17157287525381e2+0.24264068711928521e0; var ah = -0.7071067811865475e1-1.7071067811865475e2+1.0e0; var ai = 0.7071067811865475e1-1.7071067811865475e2-1.0e0; - var aj = 0.41421356237309515e1-0.17157287525380993e2-0.24264068711928524e0; + var aj = 0.4142135623730951e1-0.17157287525381e2-0.24264068711928521e0; var ak = 0.0e1-1.414213562373095e2+0.0e0; - var al = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; + var al = 1.0e1+1.0e2+0.0e0; var am = 0.7071067811865475e1-1.7071067811865475e2-1.0e0; - var an = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var ao = -0.41421356237309515e1-0.17157287525380993e2+0.24264068711928524e0; - var ap = 0.41421356237309515e1-0.17157287525380993e2-0.24264068711928524e0; - var aq = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; + var an = -1.0e1+1.0e2+0.0e0; + var ao = -0.4142135623730951e1-0.17157287525381e2+0.24264068711928521e0; + var ap = 0.4142135623730951e1-0.17157287525381e2-0.24264068711928521e0; + var aq = 1.0e1+1.0e2+0.0e0; var ar = -0.7071067811865475e1-1.7071067811865475e2+1.0e0; - var as = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; + var as = -1.0e1+1.0e2+0.0e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C0-Faces-Ordered.ganja.js b/tests/golden/C0-Faces-Ordered.ganja.js index 6a655fd63..d959af5fc 100644 --- a/tests/golden/C0-Faces-Ordered.ganja.js +++ b/tests/golden/C0-Faces-Ordered.ganja.js @@ -12,18 +12,18 @@ Algebra(2,0,1,()=>{ var aea = point(-1.0,1.0); var aeb = point(0.0,0.0); var af = 0.7071067811865475e1-1.7071067811865475e2-1.0e0; - var ag = 0.41421356237309515e1-0.17157287525380993e2-0.24264068711928524e0; + var ag = 0.4142135623730951e1-0.17157287525381e2-0.24264068711928521e0; var ah = 0.0e1-1.414213562373095e2+0.0e0; - var ai = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; + var ai = 1.0e1+1.0e2+0.0e0; var aj = 0.7071067811865475e1-1.7071067811865475e2-1.0e0; - var ak = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var al = -0.41421356237309515e1-0.17157287525380993e2+0.24264068711928524e0; - var am = 0.41421356237309515e1-0.17157287525380993e2-0.24264068711928524e0; - var an = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; + var ak = -1.0e1+1.0e2+0.0e0; + var al = -0.4142135623730951e1-0.17157287525381e2+0.24264068711928521e0; + var am = 0.4142135623730951e1-0.17157287525381e2-0.24264068711928521e0; + var an = 1.0e1+1.0e2+0.0e0; var ao = -0.7071067811865475e1-1.7071067811865475e2+1.0e0; - var ap = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; + var ap = -1.0e1+1.0e2+0.0e0; var aq = 0.0e1-1.414213562373095e2+0.0e0; - var ar = -0.41421356237309515e1-0.17157287525380993e2+0.24264068711928524e0; + var ar = -0.4142135623730951e1-0.17157287525381e2+0.24264068711928521e0; var as = -0.7071067811865475e1-1.7071067811865475e2+1.0e0; document.body.appendChild(this.graph([ 0x882288, diff --git a/tests/golden/C0-NodeTree-TwoMerge.ganja.js b/tests/golden/C0-NodeTree-TwoMerge.ganja.js index 0b63c4318..99c5db449 100644 --- a/tests/golden/C0-NodeTree-TwoMerge.ganja.js +++ b/tests/golden/C0-NodeTree-TwoMerge.ganja.js @@ -12,14 +12,14 @@ Algebra(2,0,1,()=>{ var aea = point(-1.0,1.0); var aeb = point(0.0,0.0); var afa = 0.7071067811865475e1-1.7071067811865475e2-1.0e0; - var afb = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var afc = 1.0897902135516373e1-0.21677275132473917e2-0.541196100146197e0; - var aga = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; + var afb = 1.0e1+1.0e2+0.0e0; + var afc = 1.089790213551637e1-0.21677275132473928e2-0.541196100146197e0; + var aga = -1.0e1+1.0e2+0.0e0; var agb = -0.7071067811865475e1-1.7071067811865475e2+1.0e0; - var agc = -1.0897902135516373e1-0.21677275132473917e2+0.541196100146197e0; + var agc = -1.089790213551637e1-0.21677275132473928e2+0.541196100146197e0; var aha = 0.0e1-1.414213562373095e2+0.0e0; - var ahb = 1.0897902135516373e1-0.21677275132473917e2-0.541196100146197e0; - var ahc = -1.0897902135516373e1-0.21677275132473917e2+0.541196100146197e0; + var ahb = 1.089790213551637e1-0.21677275132473928e2-0.541196100146197e0; + var ahc = -1.089790213551637e1-0.21677275132473928e2+0.541196100146197e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C0-NodeTree.ganja.js b/tests/golden/C0-NodeTree.ganja.js index 0b63c4318..99c5db449 100644 --- a/tests/golden/C0-NodeTree.ganja.js +++ b/tests/golden/C0-NodeTree.ganja.js @@ -12,14 +12,14 @@ Algebra(2,0,1,()=>{ var aea = point(-1.0,1.0); var aeb = point(0.0,0.0); var afa = 0.7071067811865475e1-1.7071067811865475e2-1.0e0; - var afb = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var afc = 1.0897902135516373e1-0.21677275132473917e2-0.541196100146197e0; - var aga = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; + var afb = 1.0e1+1.0e2+0.0e0; + var afc = 1.089790213551637e1-0.21677275132473928e2-0.541196100146197e0; + var aga = -1.0e1+1.0e2+0.0e0; var agb = -0.7071067811865475e1-1.7071067811865475e2+1.0e0; - var agc = -1.0897902135516373e1-0.21677275132473917e2+0.541196100146197e0; + var agc = -1.089790213551637e1-0.21677275132473928e2+0.541196100146197e0; var aha = 0.0e1-1.414213562373095e2+0.0e0; - var ahb = 1.0897902135516373e1-0.21677275132473917e2-0.541196100146197e0; - var ahc = -1.0897902135516373e1-0.21677275132473917e2+0.541196100146197e0; + var ahb = 1.089790213551637e1-0.21677275132473928e2-0.541196100146197e0; + var ahc = -1.089790213551637e1-0.21677275132473928e2+0.541196100146197e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C0-Straight_Skeleton.ganja.js b/tests/golden/C0-Straight_Skeleton.ganja.js index 191e7ecbc..94359a426 100644 --- a/tests/golden/C0-Straight_Skeleton.ganja.js +++ b/tests/golden/C0-Straight_Skeleton.ganja.js @@ -12,14 +12,14 @@ Algebra(2,0,1,()=>{ var aea = point(-1.0,1.0); var aeb = point(0.0,0.0); var afa = 0.7071067811865475e1-1.7071067811865475e2-1.0e0; - var afb = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var afc = 0.41421356237309515e1-0.17157287525380993e2-0.24264068711928524e0; - var aga = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; + var afb = 1.0e1+1.0e2+0.0e0; + var afc = 0.4142135623730951e1-0.17157287525381e2-0.24264068711928521e0; + var aga = -1.0e1+1.0e2+0.0e0; var agb = -0.7071067811865475e1-1.7071067811865475e2+1.0e0; - var agc = -0.41421356237309515e1-0.17157287525380993e2+0.24264068711928524e0; + var agc = -0.4142135623730951e1-0.17157287525381e2+0.24264068711928521e0; var aha = 0.0e1-1.414213562373095e2+0.0e0; - var ahb = 0.41421356237309515e1-0.17157287525380993e2-0.24264068711928524e0; - var ahc = -0.41421356237309515e1-0.17157287525380993e2+0.24264068711928524e0; + var ahb = 0.4142135623730951e1-0.17157287525381e2-0.24264068711928521e0; + var ahc = -0.4142135623730951e1-0.17157287525381e2+0.24264068711928521e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C1-Cell1-NodeTree.ganja.js b/tests/golden/C1-Cell1-NodeTree.ganja.js index 1dca33e88..9660e8ba3 100644 --- a/tests/golden/C1-Cell1-NodeTree.ganja.js +++ b/tests/golden/C1-Cell1-NodeTree.ganja.js @@ -8,8 +8,8 @@ Algebra(2,0,1,()=>{ var aca = point(1.0,1.0); var acb = point(-1.0,1.0); var ada = 1.7071067811865475e1+0.7071067811865475e2-1.0e0; - var adb = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var adc = 0.21677275132473917e1+1.0897902135516373e2-0.541196100146197e0; + var adb = -1.0e1+1.0e2+0.0e0; + var adc = 0.21677275132473928e1+1.089790213551637e2-0.541196100146197e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C1-Straight_Skeleton.ganja.js b/tests/golden/C1-Straight_Skeleton.ganja.js index 75cf947a4..8ec213789 100644 --- a/tests/golden/C1-Straight_Skeleton.ganja.js +++ b/tests/golden/C1-Straight_Skeleton.ganja.js @@ -11,15 +11,15 @@ Algebra(2,0,1,()=>{ var adb = point(1.0,1.0); var aea = point(1.0,1.0); var aeb = point(-1.0,1.0); - var afa = -0.7071067811865475e1-0.7071067811865475e2+0.0e0; + var afa = -1.0e1-1.0e2+0.0e0; var afb = 1.7071067811865475e1-0.7071067811865475e2+1.0e0; - var afc = 0.17157287525380993e1-0.41421356237309515e2+0.24264068711928524e0; + var afc = 0.17157287525381e1-0.4142135623730951e2+0.24264068711928521e0; var aga = 1.7071067811865475e1+0.7071067811865475e2-1.0e0; - var agb = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var agc = 0.17157287525380993e1+0.41421356237309515e2-0.24264068711928524e0; - var aha = 0.17157287525380993e1-0.41421356237309515e2+0.24264068711928524e0; + var agb = -1.0e1+1.0e2+0.0e0; + var agc = 0.17157287525381e1+0.4142135623730951e2-0.24264068711928521e0; + var aha = 0.17157287525381e1-0.4142135623730951e2+0.24264068711928521e0; var ahb = 1.414213562373095e1+0.0e2+0.0e0; - var ahc = 0.17157287525380993e1+0.41421356237309515e2-0.24264068711928524e0; + var ahc = 0.17157287525381e1+0.4142135623730951e2-0.24264068711928521e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C2-Cell1-NodeTree.ganja.js b/tests/golden/C2-Cell1-NodeTree.ganja.js index e21cb2a79..ee1223b25 100644 --- a/tests/golden/C2-Cell1-NodeTree.ganja.js +++ b/tests/golden/C2-Cell1-NodeTree.ganja.js @@ -8,8 +8,8 @@ Algebra(2,0,1,()=>{ var aca = point(-1.0,1.0); var acb = point(-1.0,-1.0); var ada = -0.7071067811865475e1+1.7071067811865475e2-1.0e0; - var adb = -0.7071067811865475e1-0.7071067811865475e2+0.0e0; - var adc = -1.0897902135516373e1+0.21677275132473917e2-0.541196100146197e0; + var adb = -1.0e1-1.0e2+0.0e0; + var adc = -1.089790213551637e1+0.21677275132473928e2-0.541196100146197e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C2-Straight_Skeleton.ganja.js b/tests/golden/C2-Straight_Skeleton.ganja.js index fe62f7606..bf5ddca18 100644 --- a/tests/golden/C2-Straight_Skeleton.ganja.js +++ b/tests/golden/C2-Straight_Skeleton.ganja.js @@ -11,15 +11,15 @@ Algebra(2,0,1,()=>{ var adb = point(-1.0,1.0); var aea = point(-1.0,1.0); var aeb = point(-1.0,-1.0); - var afa = 0.7071067811865475e1-0.7071067811865475e2+0.0e0; + var afa = 1.0e1-1.0e2+0.0e0; var afb = 0.7071067811865475e1+1.7071067811865475e2+1.0e0; - var afc = 0.41421356237309515e1+0.17157287525380993e2+0.24264068711928524e0; + var afc = 0.4142135623730951e1+0.17157287525381e2+0.24264068711928521e0; var aga = -0.7071067811865475e1+1.7071067811865475e2-1.0e0; - var agb = -0.7071067811865475e1-0.7071067811865475e2+0.0e0; - var agc = -0.41421356237309515e1+0.17157287525380993e2-0.24264068711928524e0; - var aha = 0.41421356237309515e1+0.17157287525380993e2+0.24264068711928524e0; + var agb = -1.0e1-1.0e2+0.0e0; + var agc = -0.4142135623730951e1+0.17157287525381e2-0.24264068711928521e0; + var aha = 0.4142135623730951e1+0.17157287525381e2+0.24264068711928521e0; var ahb = 0.0e1+1.414213562373095e2+0.0e0; - var ahc = -0.41421356237309515e1+0.17157287525380993e2-0.24264068711928524e0; + var ahc = -0.4142135623730951e1+0.17157287525381e2-0.24264068711928521e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C3-Straight_Skeleton.ganja.js b/tests/golden/C3-Straight_Skeleton.ganja.js index 686d10da5..6df95f204 100644 --- a/tests/golden/C3-Straight_Skeleton.ganja.js +++ b/tests/golden/C3-Straight_Skeleton.ganja.js @@ -12,14 +12,14 @@ Algebra(2,0,1,()=>{ var aea = point(1.0,1.0); var aeb = point(0.0,0.0); var afa = -1.7071067811865475e1-0.7071067811865475e2-1.0e0; - var afb = 0.7071067811865475e1-0.7071067811865475e2+0.0e0; - var afc = -0.17157287525380993e1-0.41421356237309515e2-0.24264068711928524e0; - var aga = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; + var afb = 1.0e1-1.0e2+0.0e0; + var afc = -0.17157287525381e1-0.4142135623730951e2-0.24264068711928521e0; + var aga = 1.0e1+1.0e2+0.0e0; var agb = -1.7071067811865475e1+0.7071067811865475e2+1.0e0; - var agc = -0.17157287525380993e1+0.41421356237309515e2+0.24264068711928524e0; + var agc = -0.17157287525381e1+0.4142135623730951e2+0.24264068711928521e0; var aha = -1.414213562373095e1+0.0e2+0.0e0; - var ahb = -0.17157287525380993e1-0.41421356237309515e2-0.24264068711928524e0; - var ahc = -0.17157287525380993e1+0.41421356237309515e2+0.24264068711928524e0; + var ahb = -0.17157287525381e1-0.4142135623730951e2-0.24264068711928521e0; + var ahc = -0.17157287525381e1+0.4142135623730951e2+0.24264068711928521e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C4-Straight_Skeleton.ganja.js b/tests/golden/C4-Straight_Skeleton.ganja.js index 191e7ecbc..94359a426 100644 --- a/tests/golden/C4-Straight_Skeleton.ganja.js +++ b/tests/golden/C4-Straight_Skeleton.ganja.js @@ -12,14 +12,14 @@ Algebra(2,0,1,()=>{ var aea = point(-1.0,1.0); var aeb = point(0.0,0.0); var afa = 0.7071067811865475e1-1.7071067811865475e2-1.0e0; - var afb = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var afc = 0.41421356237309515e1-0.17157287525380993e2-0.24264068711928524e0; - var aga = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; + var afb = 1.0e1+1.0e2+0.0e0; + var afc = 0.4142135623730951e1-0.17157287525381e2-0.24264068711928521e0; + var aga = -1.0e1+1.0e2+0.0e0; var agb = -0.7071067811865475e1-1.7071067811865475e2+1.0e0; - var agc = -0.41421356237309515e1-0.17157287525380993e2+0.24264068711928524e0; + var agc = -0.4142135623730951e1-0.17157287525381e2+0.24264068711928521e0; var aha = 0.0e1-1.414213562373095e2+0.0e0; - var ahb = 0.41421356237309515e1-0.17157287525380993e2-0.24264068711928524e0; - var ahc = -0.41421356237309515e1-0.17157287525380993e2+0.24264068711928524e0; + var ahb = 0.4142135623730951e1-0.17157287525381e2-0.24264068711928521e0; + var ahc = -0.4142135623730951e1-0.17157287525381e2+0.24264068711928521e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C6-Straight_Skeleton.ganja.js b/tests/golden/C6-Straight_Skeleton.ganja.js index af1c4a7d0..9d514afca 100644 --- a/tests/golden/C6-Straight_Skeleton.ganja.js +++ b/tests/golden/C6-Straight_Skeleton.ganja.js @@ -21,11 +21,11 @@ Algebra(2,0,1,()=>{ var aia = 0.8944271909999159e1-0.5527864045000421e2-1.0e0; var aib = 1.0e1+1.0e2+0.0e0; var aic = 1.5577575895385873e1+0.18137566906741376e2-0.9510565162951536e0; - var aja = -0.7071067811865475e1-0.7071067811865475e2+0.0e0; + var aja = -1.0e1-1.0e2+0.0e0; var ajb = 1.5577575895385873e1-0.18137566906741376e2+0.9510565162951536e0; var ajc = 0.14412639668556793e1-0.5468566089394846e2+0.3778686232909291e0; var aka = 1.5577575895385873e1+0.18137566906741376e2-0.9510565162951536e0; - var akb = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; + var akb = -1.0e1+1.0e2+0.0e0; var akc = 0.14412639668556793e1+0.5468566089394846e2-0.3778686232909291e0; var ala = 0.14412639668556793e1-0.5468566089394846e2+0.3778686232909291e0; var alb = 1.7888543819998317e1+0.0e2+0.0e0; diff --git a/tests/golden/C7-Cell2-NodeTree.ganja.js b/tests/golden/C7-Cell2-NodeTree.ganja.js index f1af27bbc..4b389c675 100644 --- a/tests/golden/C7-Cell2-NodeTree.ganja.js +++ b/tests/golden/C7-Cell2-NodeTree.ganja.js @@ -7,7 +7,7 @@ Algebra(2,0,1,()=>{ var abb = point(1.0,-1.0); var aca = 0.8944271909999159e1+1.4472135954999579e2+0.5527864045000421e0; var acb = 1.8944271909999157e1+0.4472135954999579e2-0.4472135954999579e0; - var acc = -0.7071067811865475e1+0.7071067811865475e2+0.7071067811865475e0; + var acc = -0.5e1+0.5e2+0.5e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C7-Cell3-NodeTree.ganja.js b/tests/golden/C7-Cell3-NodeTree.ganja.js index 31141aa89..9df93ecea 100644 --- a/tests/golden/C7-Cell3-NodeTree.ganja.js +++ b/tests/golden/C7-Cell3-NodeTree.ganja.js @@ -9,11 +9,11 @@ Algebra(2,0,1,()=>{ var acb = point(-1.0,0.0); var ada = point(-1.0,0.0); var adb = point(0.0,0.0); - var aea = -0.7071067811865475e1-0.7071067811865475e2+0.0e0; - var aeb = 0.7071067811865475e1-0.7071067811865475e2+0.7071067811865475e0; - var aec = 0.0e1-1.4142135623730951e2+0.7071067811865476e0; + var aea = -0.5e1-0.5e2+0.0e0; + var aeb = 0.5e1-0.5e2+0.5e0; + var aec = 0.0e1-1.414213562373095e2+0.7071067811865475e0; var afa = -0.8944271909999159e1+0.5527864045000421e2-0.5527864045000421e0; - var afb = 0.0e1-1.4142135623730951e2+0.7071067811865476e0; + var afb = 0.0e1-1.414213562373095e2+0.7071067811865475e0; var afc = -0.8506508083520399e1-0.4742688878808663e2-0.025731112119133703e0; document.body.appendChild(this.graph([ 0x882288, diff --git a/tests/golden/square-Faces-Default.ganja.js b/tests/golden/square-Faces-Default.ganja.js index 0740b2db1..f17b01db4 100644 --- a/tests/golden/square-Faces-Default.ganja.js +++ b/tests/golden/square-Faces-Default.ganja.js @@ -9,18 +9,18 @@ Algebra(2,0,1,()=>{ var acb = point(1.0,1.0); var ada = point(1.0,1.0); var adb = point(-1.0,1.0); - var ae = 0.7071067811865475e1-0.7071067811865475e2+0.0e0; - var af = 1.4142135623730951e1+0.0e2+0.0e0; - var ag = -1.4142135623730951e1+0.0e2+0.0e0; - var ah = -0.7071067811865475e1-0.7071067811865475e2+0.0e0; - var ai = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var aj = 0.7071067811865475e1-0.7071067811865475e2+0.0e0; - var ak = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var al = -1.4142135623730951e1+0.0e2+0.0e0; - var am = 1.4142135623730951e1+0.0e2+0.0e0; - var an = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var ao = -0.7071067811865475e1-0.7071067811865475e2+0.0e0; - var ap = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; + var ae = 1.0e1-1.0e2+0.0e0; + var af = 1.414213562373095e1+0.0e2+0.0e0; + var ag = -1.414213562373095e1+0.0e2+0.0e0; + var ah = -1.0e1-1.0e2+0.0e0; + var ai = 1.0e1+1.0e2+0.0e0; + var aj = 1.0e1-1.0e2+0.0e0; + var ak = -1.0e1+1.0e2+0.0e0; + var al = -1.414213562373095e1+0.0e2+0.0e0; + var am = 1.414213562373095e1+0.0e2+0.0e0; + var an = 1.0e1+1.0e2+0.0e0; + var ao = -1.0e1-1.0e2+0.0e0; + var ap = -1.0e1+1.0e2+0.0e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/square-Straight_Skeleton.ganja.js b/tests/golden/square-Straight_Skeleton.ganja.js index 6843a725b..b5b17d198 100644 --- a/tests/golden/square-Straight_Skeleton.ganja.js +++ b/tests/golden/square-Straight_Skeleton.ganja.js @@ -9,14 +9,14 @@ Algebra(2,0,1,()=>{ var acb = point(-1.0,1.0); var ada = point(-1.0,1.0); var adb = point(-1.0,-1.0); - var aea = -0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var aeb = -0.7071067811865475e1-0.7071067811865475e2+0.0e0; - var aec = -1.4142135623730951e1+0.0e2+0.0e0; - var afa = 0.7071067811865475e1-0.7071067811865475e2+0.0e0; - var afb = 0.7071067811865475e1+0.7071067811865475e2+0.0e0; - var afc = 1.4142135623730951e1+0.0e2+0.0e0; - var aga = 1.4142135623730951e1+0.0e2+0.0e0; - var agb = -1.4142135623730951e1+0.0e2+0.0e0; + var aea = -1.0e1+1.0e2+0.0e0; + var aeb = -1.0e1-1.0e2+0.0e0; + var aec = -1.414213562373095e1+0.0e2+0.0e0; + var afa = 1.0e1-1.0e2+0.0e0; + var afb = 1.0e1+1.0e2+0.0e0; + var afc = 1.414213562373095e1+0.0e2+0.0e0; + var aga = 1.414213562373095e1+0.0e2+0.0e0; + var agb = -1.414213562373095e1+0.0e2+0.0e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/triangle-Faces-Default.ganja.js b/tests/golden/triangle-Faces-Default.ganja.js index 1fd24236c..c389741cc 100644 --- a/tests/golden/triangle-Faces-Default.ganja.js +++ b/tests/golden/triangle-Faces-Default.ganja.js @@ -9,10 +9,10 @@ Algebra(2,0,1,()=>{ var acb = point(0.0,0.0); var ad = 0.8660254037844387e1+1.5e2-1.7320508075688774e0; var ae = 0.8660254037844387e1-1.5e2+0.0e0; - var af = -1.0e1+0.0e2+1.0e0; + var af = -1.7320508075688772e1+0.0e2+1.7320508075688772e0; var ag = 0.8660254037844387e1+1.5e2-1.7320508075688774e0; var ah = 0.8660254037844387e1-1.5e2+0.0e0; - var ai = -1.0e1+0.0e2+1.0e0; + var ai = -1.7320508075688772e1+0.0e2+1.7320508075688772e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/triangle-Straight_Skeleton.ganja.js b/tests/golden/triangle-Straight_Skeleton.ganja.js index b368bd9f3..4a9cab297 100644 --- a/tests/golden/triangle-Straight_Skeleton.ganja.js +++ b/tests/golden/triangle-Straight_Skeleton.ganja.js @@ -7,7 +7,7 @@ Algebra(2,0,1,()=>{ var abb = point(2.0,0.0); var aca = point(2.0,0.0); var acb = point(1.0,1.7320508075688772); - var ada = -1.0e1+0.0e2+1.0e0; + var ada = -1.7320508075688772e1+0.0e2+1.7320508075688772e0; var adb = 0.8660254037844387e1-1.5e2+0.0e0; var adc = 0.8660254037844387e1+1.5e2-1.7320508075688774e0; document.body.appendChild(this.graph([ From cd5583b083ab1cdcbac6812123a9bc0fa2e0826e Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 27 Nov 2022 22:43:49 +0000 Subject: [PATCH 105/206] fix unit test. --- tests/Math/PGA.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index 026a585ab..b95ca59e8 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -1841,17 +1841,17 @@ facetSpec = do (LineSeg (Point2 (1.5669872981077808,0.2500000000000001)) (Point2 (1.0,1.2320508075688771))) (slist [LineSeg (Point2 (1.0,1.2320508075688771)) (Point2 (0.4330127018922193,0.25))])] ,[Face (LineSeg (Point2 (2.433012701892219,-0.25)) (Point2 (-0.43301270189221924,-0.25))) - (PLine2 (GVec [GVal (-1.0000000000000002) (singleton (GEZero 1)), GVal 0.5000000000000001 (singleton (GEPlus 1)), GVal 0.8660254037844387 (singleton (GEPlus 2))])) + (PLine2 (GVec [GVal (-1.7320508075688774) (singleton (GEZero 1)), GVal 0.8660254037844387 (singleton (GEPlus 1)), GVal 1.5 (singleton (GEPlus 2))])) (slist []) - (PLine2 (GVec [GVal 0.5000000000000001 (singleton (GEPlus 1)),GVal (-0.8660254037844387) (singleton (GEPlus 2))])) + (PLine2 (GVec [GVal 0.8660254037844387 (singleton (GEPlus 1)),GVal (-1.5) (singleton (GEPlus 2))])) ,Face (LineSeg (Point2 (1.0,2.232050807568877)) (Point2 (2.4330127018922192,-0.25))) - (PLine2 (GVec [GVal 1.0 (singleton (GEZero 1)), GVal (-1.0) (singleton (GEPlus 1))])) + (PLine2 (GVec [GVal 1.7320508075688772 (singleton (GEZero 1)), GVal (-1.7320508075688772) (singleton (GEPlus 1))])) (slist []) - (PLine2 (GVec [GVal (-1.0000000000000002) (singleton (GEZero 1)), GVal 0.5000000000000001 (singleton (GEPlus 1)), GVal 0.8660254037844387 (singleton (GEPlus 2))])) + (PLine2 (GVec [GVal (-1.7320508075688774) (singleton (GEZero 1)), GVal 0.8660254037844387 (singleton (GEPlus 1)), GVal 1.5 (singleton (GEPlus 2))])) ,Face (LineSeg (Point2 (-0.43301270189221935,-0.25000000000000006)) (Point2 (1.0,2.232050807568877))) - (PLine2 (GVec [GVal 0.5000000000000001 (singleton (GEPlus 1)), GVal (-0.8660254037844387) (singleton (GEPlus 2))])) + (PLine2 (GVec [GVal 0.8660254037844387 (singleton (GEPlus 1)), GVal (-1.5) (singleton (GEPlus 2))])) (slist []) - (PLine2 (GVec [GVal 1.0 (singleton (GEZero 1)), GVal (-1.0) (singleton (GEPlus 1))])) + (PLine2 (GVec [GVal 1.7320508075688772 (singleton (GEZero 1)), GVal (-1.7320508075688772) (singleton (GEPlus 1))])) ]) where -- c0 - c4 are the contours of a square around the origin with a 90 degree chunk missing, rotated 0, 90, 180, 270 and 360 degrees: From 11e6b0ef2abb7ebbb07d4cb3d8d2305fec616030 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Mon, 28 Nov 2022 22:31:33 +0000 Subject: [PATCH 106/206] wrap the Arc functions, providing them with better names, and exposing more error quotents. --- Graphics/Slicer/Math/Arcs.hs | 56 ++++++++++++++++-------- Graphics/Slicer/Math/Skeleton/Concave.hs | 2 +- 2 files changed, 38 insertions(+), 20 deletions(-) diff --git a/Graphics/Slicer/Math/Arcs.hs b/Graphics/Slicer/Math/Arcs.hs index 26445b95b..2357e6b50 100644 --- a/Graphics/Slicer/Math/Arcs.hs +++ b/Graphics/Slicer/Math/Arcs.hs @@ -32,24 +32,30 @@ import Graphics.Slicer.Math.Intersections (intersectionOf, noIntersection) import Graphics.Slicer.Math.PGA (CPPoint2, ProjectiveLine2, ProjectivePoint2, PLine2(PLine2), PLine2Err(PLine2Err), angleBetween2PL, distance2PP, eToPL, flipL, join2PP, normalizeL, vecOfL) --- | Get a PLine in the direction of the inside of the contour, at the angle bisector of the intersection of the line segment, and another segment from the end of the given line segment, toward the given point. --- Note that we normalize our output, but return it as a PLine2. this is safe, because double normalization (if it happens) only raises the ULP. +-- | Get a Projective Line in the direction of the inside of a contour. Generates a line bisecting the angle of the intersection between a line constructed from the first two points, and another line constrected from the last two points. getFirstArc :: Point2 -> Point2 -> Point2 -> (PLine2, PLine2Err) -getFirstArc p1 p2 p3 +getFirstArc a b c = (res, resErr) + where + (res, (_,_, resErr)) = getAcuteArcBetweenPoints a b c + + +-- | Get a Projective Line in the direction of the inside of a contour. Generates a line bisecting the angle of the intersection between a line constructed from the first two points, and another line constrected from the last two points. +getAcuteArcBetweenPoints :: Point2 -> Point2 -> Point2 -> (PLine2, (PLine2Err, PLine2Err, PLine2Err)) +getAcuteArcBetweenPoints p1 p2 p3 -- since we hawe two equal sides, we can draw a point ot the other side of the quad, and use it for constructing. - | distance p2 p1 == distance p2 p3 = (quad, quadErr) + | distance p2 p1 == distance p2 p3 = (quad, (side1ConsErr <> side1NormErr, side2ConsErr <> side2NormErr, quadErr)) {- | distance p2 p1 > distance p2 p3 = scaleSide p1 p3 True (distance p2 p1 / distance p2 p3) | otherwise = scaleSide p3 p1 True (distance p2 p3 / distance p2 p1) -} | otherwise = (insideArc, insideArcErr) where - (insideArc, insideArcErr) = getInsideArc side1 side2 + (insideArc, insideArcErr) = getAcuteAngleBisector side1 side2 -- FIXME: how do these errors effect the result? - (side1, _) = normalizeL side1Raw - (side1Raw, _) = eToPL (makeLineSeg p1 p2) - (side2, _) = normalizeL side2Raw - (side2Raw, _) = eToPL (makeLineSeg p2 p3) + (side1, side1NormErr) = normalizeL side1Raw + (side1Raw, side1ConsErr) = eToPL (makeLineSeg p1 p2) + (side2, side2NormErr) = normalizeL side2Raw + (side2Raw, side2ConsErr) = eToPL (makeLineSeg p2 p3) (quad, quadErr) = eToPL $ makeLineSeg p2 $ scalePoint 0.5 $ addPoints p1 p3 {- scaleSide ps1 ps2 t v @@ -61,14 +67,21 @@ getFirstArc p1 p2 p3 (scaled, UlpSum scaledUlp) = pLineFromEndpointsWithErr p2 $ scalePoint 0.5 $ addPoints ps1 $ addPoints p2 $ scalePoint v $ addPoints ps2 $ negatePoint p2 -} +-- | Get a Projective Line along the angle bisector of the intersection of the two given lines, pointing in the 'acute' direction. +-- Wrapper, stripping the normalization error quotents of inputs from its output +getInsideArc :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PLine2, PLine2Err) +getInsideArc line1 line2 = (res, resErr) + where + (res, (_, _, resErr)) = getAcuteAngleBisector line1 line2 + -- | Get a PLine along the angle bisector of the intersection of the two given line segments, pointing in the 'acute' direction. -- Note that we know that the inside is to the right of the first line given, and that the first line points toward the intersection. -getInsideArc :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PLine2, PLine2Err) -getInsideArc line1 line2 --- | pline1 == pline2 = error "need to be able to return two PLines." - | otherwise = (PLine2 addVecRes, errTotal) +getAcuteAngleBisector :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PLine2, (PLine2Err, PLine2Err, PLine2Err)) +getAcuteAngleBisector line1 line2 + | npline1 == npline2 = error "Given two identical lines." + | npline1 == flipL npline2 = error "Need to be able to return two PLines." + | otherwise = (PLine2 addVecRes, (npline1Err, npline2Err, PLine2Err addVecErrs mempty mempty mempty mempty mempty)) where - errTotal = PLine2Err addVecErrs mempty mempty mempty mempty mempty (addVecRes, addVecErrs) = addVecPairWithErr lv1 lv2 lv1 = vecOfL $ flipL npline1 lv2 = vecOfL npline2 @@ -76,10 +89,15 @@ getInsideArc line1 line2 (npline2, npline2Err) = normalizeL line2 -- | Get a PLine along the angle bisector of the intersection of the two given line segments, pointing in the 'obtuse' direction. --- Note: we normalize our output lines. --- FIXME: the outer PLine returned by two PLines in the same direction should be two PLines, whch are the same line in both directions. getOutsideArc :: (ProjectivePoint2 a, ProjectiveLine2 b, ProjectivePoint2 c, ProjectiveLine2 d) => a -> b -> c -> d -> (PLine2, PLine2Err) -getOutsideArc ppoint1 pline1 ppoint2 pline2 +getOutsideArc a b c d = (res, resErr) + where + (res, (_,_, resErr)) = getObtuseAngleBisector a b c d + +-- | Get a PLine along the angle bisector of the intersection of the two given line segments, pointing in the 'obtuse' direction. +-- FIXME: the outer PLine returned by two PLines in the same direction should be two PLines, whch are the same line in both directions. +getObtuseAngleBisector :: (ProjectivePoint2 a, ProjectiveLine2 b, ProjectivePoint2 c, ProjectiveLine2 d) => a -> b -> c -> d -> (PLine2, (PLine2Err, PLine2Err, PLine2Err)) +getObtuseAngleBisector ppoint1 pline1 ppoint2 pline2 | npline1 == npline2 = error "need to be able to return two PLines." | noIntersection (pline1, mempty) (pline2, mempty) = error $ "no intersection between pline " <> show pline1 <> " and " <> show pline2 <> ".\n" | l1TowardPoint && l2TowardPoint = (flipL resFlipped, resFlippedErr) @@ -87,8 +105,8 @@ getOutsideArc ppoint1 pline1 ppoint2 pline2 | l2TowardPoint = (resNormal, resNormalErr) | otherwise = (resFlipped, resFlippedErr) where - (resNormal, resNormalErr) = getInsideArc pline1 pline2 - (resFlipped, resFlippedErr) = getInsideArc pline1 (flipL pline2) + (resNormal, resNormalErr) = getAcuteAngleBisector pline1 pline2 + (resFlipped, resFlippedErr) = getAcuteAngleBisector pline1 (flipL pline2) npline1 = normalizeL pline1 npline2 = normalizeL pline2 intersectionPoint = fst $ intersectionOf (pline1, mempty) (pline2, mempty) diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index 972a891c7..b33fb498e 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -60,7 +60,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum)) import Graphics.Slicer.Math.Intersections (intersectionOf, intersectionBetween, isCollinear, isParallel, isAntiCollinear, noIntersection) -import Graphics.Slicer.Math.Lossy (distancePPointToPLine, eToPLine2, normalizePLine2) +import Graphics.Slicer.Math.Lossy as Lossy (distancePPointToPLine, eToPLine2, normalizePLine2) import Graphics.Slicer.Math.PGA (Arcable(errOfOut, hasArc, outOf), Pointable(canPoint, pPointOf), PLine2, PLine2Err, CPPoint2(CPPoint2), PPoint2(PPoint2), distance2PP, flipL, outAndErrOf, pLineIsLeft, distancePPointToPLineWithErr) From ff4c58df5057f57c07437d363fcf47a0da715cee Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Tue, 29 Nov 2022 15:57:41 +0000 Subject: [PATCH 107/206] better name. --- Graphics/Slicer/Math/Arcs.hs | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/Graphics/Slicer/Math/Arcs.hs b/Graphics/Slicer/Math/Arcs.hs index 2357e6b50..354c51652 100644 --- a/Graphics/Slicer/Math/Arcs.hs +++ b/Graphics/Slicer/Math/Arcs.hs @@ -36,12 +36,12 @@ import Graphics.Slicer.Math.PGA (CPPoint2, ProjectiveLine2, ProjectivePoint2, PL getFirstArc :: Point2 -> Point2 -> Point2 -> (PLine2, PLine2Err) getFirstArc a b c = (res, resErr) where - (res, (_,_, resErr)) = getAcuteArcBetweenPoints a b c + (res, (_,_, resErr)) = getAcuteArcFromPoints a b c -- | Get a Projective Line in the direction of the inside of a contour. Generates a line bisecting the angle of the intersection between a line constructed from the first two points, and another line constrected from the last two points. -getAcuteArcBetweenPoints :: Point2 -> Point2 -> Point2 -> (PLine2, (PLine2Err, PLine2Err, PLine2Err)) -getAcuteArcBetweenPoints p1 p2 p3 +getAcuteArcFromPoints :: Point2 -> Point2 -> Point2 -> (PLine2, (PLine2Err, PLine2Err, PLine2Err)) +getAcuteArcFromPoints p1 p2 p3 -- since we hawe two equal sides, we can draw a point ot the other side of the quad, and use it for constructing. | distance p2 p1 == distance p2 p3 = (quad, (side1ConsErr <> side1NormErr, side2ConsErr <> side2NormErr, quadErr)) {- @@ -124,5 +124,3 @@ towardIntersection pp1 pl1 pp2 (angleFound, (_,_, angleErr)) = angleBetween2PL newPLine pl1 (d, (_,_,UlpSum dErr)) = distance2PP (pp1, mempty) (pp2, mempty) newPLine = fst $ join2PP pp1 pp2 - - From 98a835d2151c2da7471ab82c5838f2f26831ace0 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Wed, 30 Nov 2022 19:23:25 +0000 Subject: [PATCH 108/206] accept error quotents along with projective lines in arc functions. --- Graphics/Slicer/Math/Arcs.hs | 74 ++++++++++-------------- Graphics/Slicer/Math/Ganja.hs | 4 +- Graphics/Slicer/Math/Lossy.hs | 2 +- Graphics/Slicer/Math/Skeleton/Concave.hs | 13 +++-- tests/Math/PGA.hs | 32 +++++----- 5 files changed, 59 insertions(+), 66 deletions(-) diff --git a/Graphics/Slicer/Math/Arcs.hs b/Graphics/Slicer/Math/Arcs.hs index 354c51652..c7b50d90e 100644 --- a/Graphics/Slicer/Math/Arcs.hs +++ b/Graphics/Slicer/Math/Arcs.hs @@ -22,7 +22,7 @@ module Graphics.Slicer.Math.Arcs (getFirstArc, getInsideArc, getOutsideArc, towardIntersection) where -import Prelude (Bool, ($), (<>), (==), (>), (<=), (&&), error, fst, mempty, otherwise, realToFrac, show) +import Prelude (Bool, ($), (<>), (==), (>), (<=), (&&), (||), error, fst, mempty, otherwise, realToFrac, show) import Graphics.Slicer.Math.Definitions (Point2, addPoints, distance, makeLineSeg, scalePoint) @@ -38,46 +38,36 @@ getFirstArc a b c = (res, resErr) where (res, (_,_, resErr)) = getAcuteArcFromPoints a b c - --- | Get a Projective Line in the direction of the inside of a contour. Generates a line bisecting the angle of the intersection between a line constructed from the first two points, and another line constrected from the last two points. +-- | Get a Projective Line in the direction of the inside of a contour. +-- Generates a line bisecting the angle of the intersection between a line constructed from the first two points, and another line constrected from the last two points. +-- Note: we return normalization error, because we construct projective lines here. getAcuteArcFromPoints :: Point2 -> Point2 -> Point2 -> (PLine2, (PLine2Err, PLine2Err, PLine2Err)) getAcuteArcFromPoints p1 p2 p3 - -- since we hawe two equal sides, we can draw a point ot the other side of the quad, and use it for constructing. - | distance p2 p1 == distance p2 p3 = (quad, (side1ConsErr <> side1NormErr, side2ConsErr <> side2NormErr, quadErr)) - {- - | distance p2 p1 > distance p2 p3 = scaleSide p1 p3 True (distance p2 p1 / distance p2 p3) - | otherwise = scaleSide p3 p1 True (distance p2 p3 / distance p2 p1) - -} - | otherwise = (insideArc, insideArcErr) + | p1 == p2 || p2 == p3 = error "given two input points that are identical!" + -- Since we hawe two equal sides, we can draw a point on the other side of the quad, and use it for constructing our result. + | distance p2 p1 == distance p2 p3 = (quad, (mempty, mempty, quadErr)) + | otherwise = (insideArc, (side1ConsErr <> side1NormErr, side2ConsErr <> side2NormErr, insideArcErr)) where - (insideArc, insideArcErr) = getAcuteAngleBisector side1 side2 - -- FIXME: how do these errors effect the result? + (insideArc, (_,_, insideArcErr)) = getAcuteAngleBisectorFromLines (side1, side1NormErr) (side2, side2NormErr) + -- FIXME: how do these error quotents effect the resulting line? (side1, side1NormErr) = normalizeL side1Raw (side1Raw, side1ConsErr) = eToPL (makeLineSeg p1 p2) (side2, side2NormErr) = normalizeL side2Raw (side2Raw, side2ConsErr) = eToPL (makeLineSeg p2 p3) + -- Only used for the quad case. (quad, quadErr) = eToPL $ makeLineSeg p2 $ scalePoint 0.5 $ addPoints p1 p3 - {- - scaleSide ps1 ps2 t v - | t == True = (PLine2 scaledRes, UlpSum $ scaledUlp + scaledResUlp) - | otherwise = (flipPLine2 $ PLine2 scaledRes, UlpSum $ scaledUlp + scaledResUlp) - where - (NPLine2 scaledRes, UlpSum scaledResUlp) = normalizePLine2WithErr scaled - -- FIXME: poor ULP tracking on this linear math. - (scaled, UlpSum scaledUlp) = pLineFromEndpointsWithErr p2 $ scalePoint 0.5 $ addPoints ps1 $ addPoints p2 $ scalePoint v $ addPoints ps2 $ negatePoint p2 - -} -- | Get a Projective Line along the angle bisector of the intersection of the two given lines, pointing in the 'acute' direction. --- Wrapper, stripping the normalization error quotents of inputs from its output -getInsideArc :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PLine2, PLine2Err) +-- A wrapper of getAcuteAngleBisectorFromLines, dropping the returning of normalization error of the inputs. +getInsideArc :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> (PLine2, PLine2Err) getInsideArc line1 line2 = (res, resErr) where - (res, (_, _, resErr)) = getAcuteAngleBisector line1 line2 + (res, (_,_, resErr)) = getAcuteAngleBisectorFromLines line1 line2 --- | Get a PLine along the angle bisector of the intersection of the two given line segments, pointing in the 'acute' direction. --- Note that we know that the inside is to the right of the first line given, and that the first line points toward the intersection. -getAcuteAngleBisector :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PLine2, (PLine2Err, PLine2Err, PLine2Err)) -getAcuteAngleBisector line1 line2 +-- | Get a Projective Line along the angle bisector of the intersection of the two given lines, pointing in the 'acute' direction. +-- Note that we assume that the first line points toward the intersection. +getAcuteAngleBisectorFromLines :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> (PLine2, (PLine2Err, PLine2Err, PLine2Err)) +getAcuteAngleBisectorFromLines (line1,_) (line2,_) | npline1 == npline2 = error "Given two identical lines." | npline1 == flipL npline2 = error "Need to be able to return two PLines." | otherwise = (PLine2 addVecRes, (npline1Err, npline2Err, PLine2Err addVecErrs mempty mempty mempty mempty mempty)) @@ -88,30 +78,30 @@ getAcuteAngleBisector line1 line2 (npline1, npline1Err) = normalizeL line1 (npline2, npline2Err) = normalizeL line2 --- | Get a PLine along the angle bisector of the intersection of the two given line segments, pointing in the 'obtuse' direction. -getOutsideArc :: (ProjectivePoint2 a, ProjectiveLine2 b, ProjectivePoint2 c, ProjectiveLine2 d) => a -> b -> c -> d -> (PLine2, PLine2Err) +-- | Get a Projective Line along the angle bisector of the intersection of the two given lines, pointing in the 'obtuse' direction. +getOutsideArc :: (ProjectivePoint2 a, ProjectiveLine2 b, ProjectivePoint2 c, ProjectiveLine2 d) => a -> (b, PLine2Err) -> c -> (d, PLine2Err) -> (PLine2, PLine2Err) getOutsideArc a b c d = (res, resErr) where (res, (_,_, resErr)) = getObtuseAngleBisector a b c d --- | Get a PLine along the angle bisector of the intersection of the two given line segments, pointing in the 'obtuse' direction. --- FIXME: the outer PLine returned by two PLines in the same direction should be two PLines, whch are the same line in both directions. -getObtuseAngleBisector :: (ProjectivePoint2 a, ProjectiveLine2 b, ProjectivePoint2 c, ProjectiveLine2 d) => a -> b -> c -> d -> (PLine2, (PLine2Err, PLine2Err, PLine2Err)) -getObtuseAngleBisector ppoint1 pline1 ppoint2 pline2 +-- | Get a PLine along the angle bisector of the intersection of the two given lines, pointing in the 'obtuse' direction. +-- FIXME: the outer line returned by two lines in the same direction should be two lines at a 90 degree angle to the input lines. +getObtuseAngleBisector :: (ProjectivePoint2 a, ProjectiveLine2 b, ProjectivePoint2 c, ProjectiveLine2 d) => a -> (b, PLine2Err) -> c -> (d, PLine2Err) -> (PLine2, (PLine2Err, PLine2Err, PLine2Err)) +getObtuseAngleBisector ppoint1 line1@(pl1, pl1Err) ppoint2 line2@(pl2, pl2Err) | npline1 == npline2 = error "need to be able to return two PLines." - | noIntersection (pline1, mempty) (pline2, mempty) = error $ "no intersection between pline " <> show pline1 <> " and " <> show pline2 <> ".\n" + | noIntersection line1 line2 = error $ "no intersection between pline " <> show line1 <> " and " <> show line2 <> ".\n" | l1TowardPoint && l2TowardPoint = (flipL resFlipped, resFlippedErr) | l1TowardPoint = (flipL resNormal, resNormalErr) | l2TowardPoint = (resNormal, resNormalErr) | otherwise = (resFlipped, resFlippedErr) where - (resNormal, resNormalErr) = getAcuteAngleBisector pline1 pline2 - (resFlipped, resFlippedErr) = getAcuteAngleBisector pline1 (flipL pline2) - npline1 = normalizeL pline1 - npline2 = normalizeL pline2 - intersectionPoint = fst $ intersectionOf (pline1, mempty) (pline2, mempty) - l1TowardPoint = towardIntersection ppoint1 pline1 intersectionPoint - l2TowardPoint = towardIntersection ppoint2 pline2 intersectionPoint + (resNormal, resNormalErr) = getAcuteAngleBisectorFromLines line1 line2 + (resFlipped, resFlippedErr) = getAcuteAngleBisectorFromLines line1 (flipL pl2, pl2Err) + npline1 = normalizeL pl1 + npline2 = normalizeL pl2 + intersectionPoint = fst $ intersectionOf line1 line2 + l1TowardPoint = towardIntersection ppoint1 pl1 intersectionPoint + l2TowardPoint = towardIntersection ppoint2 pl2 intersectionPoint -- | Determine if the line segment formed by the two given points starts with the first point, or the second. -- Note: Due to numeric uncertainty, we cannot rely on Eq here, and must check the sign of the angle. diff --git a/Graphics/Slicer/Math/Ganja.hs b/Graphics/Slicer/Math/Ganja.hs index 26286435f..beedadd07 100644 --- a/Graphics/Slicer/Math/Ganja.hs +++ b/Graphics/Slicer/Math/Ganja.hs @@ -114,7 +114,7 @@ import Graphics.Slicer.Math.Definitions (Contour, Point2(Point2), LineSeg, endPo import Graphics.Slicer.Math.GeometricAlgebra (GNum(GEPlus, GEZero), GVec(GVec), getVal, valOf) -import Graphics.Slicer.Math.Lossy (eToPLine2, join2PPoint2, normalizePLine2, pPointBetweenPPoints, pToEPoint2) +import Graphics.Slicer.Math.Lossy (eToPLine2, join2PPoint2, pPointBetweenPPoints, pToEPoint2) import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), PLine2(PLine2), PPoint2(PPoint2), PLine2Err, eToPL, eToPPoint2, flipL, normalizeL, translateRotatePPoint2WithErr, outOf, pPointOf, NPLine2(NPLine2)) @@ -666,7 +666,7 @@ randomINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 = makeINode [maybeFlippedpl1,m maybeFlippedpl1 = (if flipIn1 then flipL (fst pl1) else (fst pl1), snd pl1) maybeFlippedpl2 = (if flipIn2 then flipL (fst pl2) else (fst pl2), snd pl2) bisector1 = normalizeL outsideRes - (outsideRes, outsideResErr) = getOutsideArc pp1 (normalizePLine2 $ fst maybeFlippedpl1) pp2 (normalizePLine2 $ fst maybeFlippedpl2) + (outsideRes, outsideResErr) = getOutsideArc pp1 (normalizeL $ fst maybeFlippedpl1) pp2 (normalizeL $ fst maybeFlippedpl2) -- | A helper function. constructs a random PLine. randomPLine :: ℝ -> ℝ -> NonZero ℝ -> NonZero ℝ -> PLine2 diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index 5a40edbb7..c4662ea72 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -84,7 +84,7 @@ getFirstArc :: Point2 -> Point2 -> Point2 -> PLine2 getFirstArc p1 p2 p3 = fst $ Arcs.getFirstArc p1 p2 p3 getInsideArc :: PLine2 -> PLine2 -> PLine2 -getInsideArc pl1 pl2 = fst $ Arcs.getInsideArc pl1 pl2 +getInsideArc pl1 pl2 = fst $ Arcs.getInsideArc (pl1, mempty) (pl2, mempty) -- | a typed join function. join two points, returning a line. join2PPoint2 :: (ProjectivePoint2 a) => a -> a -> PLine2 diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index b33fb498e..20aa3b913 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -60,9 +60,9 @@ import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum)) import Graphics.Slicer.Math.Intersections (intersectionOf, intersectionBetween, isCollinear, isParallel, isAntiCollinear, noIntersection) -import Graphics.Slicer.Math.Lossy as Lossy (distancePPointToPLine, eToPLine2, normalizePLine2) +import Graphics.Slicer.Math.Lossy as Lossy (distancePPointToPLine) -import Graphics.Slicer.Math.PGA (Arcable(errOfOut, hasArc, outOf), Pointable(canPoint, pPointOf), PLine2, PLine2Err, CPPoint2(CPPoint2), PPoint2(PPoint2), distance2PP, flipL, outAndErrOf, pLineIsLeft, distancePPointToPLineWithErr) +import Graphics.Slicer.Math.PGA (Arcable(errOfOut, hasArc, outOf), Pointable(canPoint, pPointOf), PLine2, PLine2Err, CPPoint2(CPPoint2), PPoint2(PPoint2), distance2PP, eToPL, flipL, outAndErrOf, pLineIsLeft, distancePPointToPLineWithErr) import Graphics.Slicer.Math.Skeleton.Definitions (ENode(ENode), ENodeSet(ENodeSet), INode(INode), INodeSet(INodeSet), NodeTree(NodeTree), concavePLines, getFirstLineSeg, getLastLineSeg, finalOutOf, firstInOf, getPairs, indexPLinesTo, insOf, lastINodeOf, linePairs, makeINode, sortedPLinesWithErr, isLoop) @@ -109,11 +109,14 @@ findINodes inSegSets | len inSegSets == 2 = -- Two walls, no closed ends. solve the ends of a hallway region, so we can then hand off the solutioning to our regular process. case initialENodes of - [] -> INodeSet $ slist [[makeINode [getInsideArc (flipL $ eToPLine2 firstSeg) (eToPLine2 lastSeg), getInsideArc (eToPLine2 firstSeg) (flipL $ eToPLine2 lastSeg)] Nothing]] + [] -> INodeSet $ slist [[makeINode [getInsideArc (eToFlippedPL firstSeg) (eToPL lastSeg), getInsideArc (eToPL firstSeg) (eToFlippedPL lastSeg)] Nothing]] where firstSeg = SL.head $ slist $ SL.head inSegSets lastSeg = SL.head $ slist $ SL.last inSegSets - [a] -> INodeSet $ slist [[makeINode [getInsideArc (eToPLine2 lastSeg) (eToPLine2 shortSide), getInsideArc (eToPLine2 firstSeg) (eToPLine2 shortSide)] (Just (flipL $ outOf a, errOfOut a))]] + eToFlippedPL lineSeg = (flipL res, resErr) + where + (res, resErr) = eToPL lineSeg + [a] -> INodeSet $ slist [[makeINode [getInsideArc (eToPL lastSeg) (eToPL shortSide), getInsideArc (eToPL firstSeg) (eToPL shortSide)] (Just (flipL $ outOf a, errOfOut a))]] where firstSeg = fromMaybe (error "no first segment?") $ safeHead $ slist longSide lastSeg = SL.last $ slist longSide @@ -177,7 +180,7 @@ averageNodes n1 n2 | nodesAreAntiCollinear n1 n2 = error $ "Cannot (yet) handle two input plines that are collinear.\n" <> dumpInput | n1Distance < getRounded n1Err = error $ "intersection is AT the point of n1!\n" <> dumpInput | n2Distance < getRounded n2Err = error $ "intersection is AT the point of n2!\n" <> dumpInput - | otherwise = makeINode (sortedPair n1 n2) $ Just $ getOutsideArc (pPointOf n1) (normalizePLine2 $ outOf n1) (pPointOf n2) (normalizePLine2 $ outOf n2) + | otherwise = makeINode (sortedPair n1 n2) $ Just $ getOutsideArc (pPointOf n1) (outAndErrOf n1) (pPointOf n2) (outAndErrOf n2) where (n1Distance, (_,_, UlpSum n1Err)) = distance2PP (intersectionOf (outAndErrOf n1) (outAndErrOf n2)) (pPointOf n1, mempty) (n2Distance, (_,_, UlpSum n2Err)) = distance2PP (intersectionOf (outAndErrOf n1) (outAndErrOf n2)) (pPointOf n2, mempty) diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index b95ca59e8..82c750803 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -788,23 +788,23 @@ prop_AxisAligned45DegreeAngles xPos yPos offset rawMagnitude1 rawMagnitude2 prop_AxisAlignedRightAnglesOutside :: Bool -> Bool -> ℝ -> Positive ℝ -> Bool prop_AxisAlignedRightAnglesOutside xPos yPos offset rawMagnitude | xPos && yPos = normalizePLine2 (fst $ - getOutsideArc (eToPPoint2 $ Point2 (offset,offset+mag)) (normalizePLine2 $ eToPLine2 $ LineSeg (Point2 (offset,offset+mag)) (Point2 (offset,offset))) - (eToPPoint2 $ Point2 (offset+mag,offset)) (normalizePLine2 $ eToPLine2 $ LineSeg (Point2 (offset+mag,offset)) (Point2 (offset,offset)))) + getOutsideArc (eToPPoint2 $ Point2 (offset,offset+mag)) (eToPL $ LineSeg (Point2 (offset,offset+mag)) (Point2 (offset,offset))) + (eToPPoint2 $ Point2 (offset+mag,offset)) (eToPL $ LineSeg (Point2 (offset+mag,offset)) (Point2 (offset,offset)))) `myAngleBetween` NPLine2 (GVec [GVal (-0.7071067811865475) (singleton (GEPlus 1)), GVal 0.7071067811865475 (singleton (GEPlus 2))]) | xPos = normalizePLine2 (fst $ - getOutsideArc (eToPPoint2 $ Point2 (offset,-(offset+mag))) (normalizePLine2 $ eToPLine2 $ LineSeg (Point2 (offset,-(offset+mag))) (Point2 (offset,-offset))) - (eToPPoint2 $ Point2 (offset+mag,-offset)) (normalizePLine2 $ eToPLine2 $ LineSeg (Point2 (offset+mag,-offset)) (Point2 (offset,-offset)))) + getOutsideArc (eToPPoint2 $ Point2 (offset,-(offset+mag))) (eToPL $ LineSeg (Point2 (offset,-(offset+mag))) (Point2 (offset,-offset))) + (eToPPoint2 $ Point2 (offset+mag,-offset)) (eToPL $ LineSeg (Point2 (offset+mag,-offset)) (Point2 (offset,-offset)))) `myAngleBetween` NPLine2 (GVec [GVal 0.7071067811865475 (singleton (GEPlus 1)), GVal 0.7071067811865475 (singleton (GEPlus 2))]) | not xPos && yPos = normalizePLine2 ( fst $ - getOutsideArc (eToPPoint2 $ Point2 (-offset,offset+mag)) (normalizePLine2 $ eToPLine2 $ LineSeg (Point2 (-offset,offset+mag)) (Point2 (-offset,offset))) - (eToPPoint2 $ Point2 (-(offset+mag),offset)) (normalizePLine2 $ eToPLine2 $ LineSeg (Point2 (-(offset+mag),offset)) (Point2 (-offset,offset)))) + getOutsideArc (eToPPoint2 $ Point2 (-offset,offset+mag)) (eToPL $ LineSeg (Point2 (-offset,offset+mag)) (Point2 (-offset,offset))) + (eToPPoint2 $ Point2 (-(offset+mag),offset)) (eToPL $ LineSeg (Point2 (-(offset+mag),offset)) (Point2 (-offset,offset)))) `myAngleBetween` NPLine2 (GVec [GVal (-0.7071067811865475) (singleton (GEPlus 1)), GVal (-0.7071067811865475) (singleton (GEPlus 2))]) | otherwise = normalizePLine2 ( fst $ - getOutsideArc (eToPPoint2 $ Point2 (-offset,-(offset+mag))) (normalizePLine2 $ eToPLine2 $ LineSeg (Point2 (-offset,-(offset+mag))) (Point2 (-offset,-offset))) - (eToPPoint2 $ Point2 (-(offset+mag),-offset)) (normalizePLine2 $ eToPLine2 $ LineSeg (Point2 (-(offset+mag),-offset)) (Point2 (-offset,-offset)))) + getOutsideArc (eToPPoint2 $ Point2 (-offset,-(offset+mag))) (eToPL $ LineSeg (Point2 (-offset,-(offset+mag))) (Point2 (-offset,-offset))) + (eToPPoint2 $ Point2 (-(offset+mag),-offset)) (eToPL $ LineSeg (Point2 (-(offset+mag),-offset)) (Point2 (-offset,-offset)))) `myAngleBetween` NPLine2 (GVec [GVal 0.7071067811865475 (singleton (GEPlus 1)), GVal (-0.7071067811865475) (singleton (GEPlus 2))]) where @@ -819,23 +819,23 @@ prop_AxisAlignedRightAnglesOutside xPos yPos offset rawMagnitude prop_AxisAligned135DegreeAnglesOutside :: Bool -> Bool -> Positive ℝ -> Positive ℝ -> Bool prop_AxisAligned135DegreeAnglesOutside xPos yPos rawOffset rawMagnitude | xPos && yPos = normalizePLine2 ( fst $ - getOutsideArc (eToPPoint2 $ Point2 (offset+mag,offset)) (normalizePLine2 $ eToPLine2 $ LineSeg (Point2 (offset+mag,offset)) (Point2 (offset,offset))) - (eToPPoint2 $ Point2 (offset+mag,offset+mag)) (normalizePLine2 $ eToPLine2 $ LineSeg (Point2 (offset+mag,offset+mag)) (Point2 (offset,offset)))) + getOutsideArc (eToPPoint2 $ Point2 (offset+mag,offset)) (eToPL $ LineSeg (Point2 (offset+mag,offset)) (Point2 (offset,offset))) + (eToPPoint2 $ Point2 (offset+mag,offset+mag)) (eToPL $ LineSeg (Point2 (offset+mag,offset+mag)) (Point2 (offset,offset)))) `myAngleBetween` NPLine2 (GVec [GVal (-0.3826834323650899) (singleton (GEPlus 1)), GVal 0.9238795325112867 (singleton (GEPlus 2))]) | xPos = normalizePLine2 ( fst $ - getOutsideArc (eToPPoint2 $ Point2 (offset+mag,-offset)) (normalizePLine2 $ eToPLine2 $ LineSeg (Point2 (offset+mag,-offset)) (Point2 (offset,-offset))) - (eToPPoint2 $ Point2 (offset+mag,-(offset+mag))) (normalizePLine2 $ eToPLine2 $ LineSeg (Point2 (offset+mag,-(offset+mag))) (Point2 (offset,-offset)))) + getOutsideArc (eToPPoint2 $ Point2 (offset+mag,-offset)) (eToPL $ LineSeg (Point2 (offset+mag,-offset)) (Point2 (offset,-offset))) + (eToPPoint2 $ Point2 (offset+mag,-(offset+mag))) (eToPL $ LineSeg (Point2 (offset+mag,-(offset+mag))) (Point2 (offset,-offset)))) `myAngleBetween` NPLine2 (GVec [GVal 0.3826834323650899 (singleton (GEPlus 1)), GVal 0.9238795325112867 (singleton (GEPlus 2))]) | not xPos && yPos = normalizePLine2 ( fst $ - getOutsideArc (eToPPoint2 $ Point2 (-(offset+mag),offset)) (normalizePLine2 $ eToPLine2 $ LineSeg (Point2 (-(offset+mag),offset)) (Point2 (-offset,offset))) - (eToPPoint2 $ Point2 (-(offset+mag),offset+mag)) (normalizePLine2 $ eToPLine2 $ LineSeg (Point2 (-(offset+mag),offset+mag)) (Point2 (-offset,offset)))) + getOutsideArc (eToPPoint2 $ Point2 (-(offset+mag),offset)) (eToPL $ LineSeg (Point2 (-(offset+mag),offset)) (Point2 (-offset,offset))) + (eToPPoint2 $ Point2 (-(offset+mag),offset+mag)) (eToPL $ LineSeg (Point2 (-(offset+mag),offset+mag)) (Point2 (-offset,offset)))) `myAngleBetween` NPLine2 (GVec [GVal (-0.3826834323650899) (singleton (GEPlus 1)), GVal (-0.9238795325112867) (singleton (GEPlus 2))]) | otherwise = normalizePLine2 ( fst $ - getOutsideArc (eToPPoint2 $ Point2 (-(offset+mag),-offset)) (normalizePLine2 $ eToPLine2 $ LineSeg (Point2 (-(offset+mag),-offset)) (Point2 (-offset,-offset))) - (eToPPoint2 $ Point2 (-(offset+mag),-(offset+mag))) (normalizePLine2 $ eToPLine2 $ LineSeg (Point2 (-(offset+mag),-(offset+mag))) (Point2 (-offset,-offset)))) + getOutsideArc (eToPPoint2 $ Point2 (-(offset+mag),-offset)) (eToPL $ LineSeg (Point2 (-(offset+mag),-offset)) (Point2 (-offset,-offset))) + (eToPPoint2 $ Point2 (-(offset+mag),-(offset+mag))) (eToPL $ LineSeg (Point2 (-(offset+mag),-(offset+mag))) (Point2 (-offset,-offset)))) `myAngleBetween` NPLine2 (GVec [GVal 0.3826834323650899 (singleton (GEPlus 1)), GVal (-0.9238795325112867) (singleton (GEPlus 2))]) where From 884384eec11817abcc9c9b64a7b4128dec9a648f Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Wed, 30 Nov 2022 22:07:03 +0000 Subject: [PATCH 109/206] Accept projective points with error quotents, in Arc functions. --- Graphics/Slicer/Math/Arcs.hs | 56 ++++++++++---------- Graphics/Slicer/Math/Ganja.hs | 4 +- Graphics/Slicer/Math/Intersections.hs | 10 ++-- Graphics/Slicer/Math/PGA.hs | 6 +++ Graphics/Slicer/Math/Skeleton/Concave.hs | 4 +- Graphics/Slicer/Math/Skeleton/Motorcycles.hs | 2 +- tests/Math/PGA.hs | 46 ++++++++-------- 7 files changed, 67 insertions(+), 61 deletions(-) diff --git a/Graphics/Slicer/Math/Arcs.hs b/Graphics/Slicer/Math/Arcs.hs index c7b50d90e..157882835 100644 --- a/Graphics/Slicer/Math/Arcs.hs +++ b/Graphics/Slicer/Math/Arcs.hs @@ -22,15 +22,15 @@ module Graphics.Slicer.Math.Arcs (getFirstArc, getInsideArc, getOutsideArc, towardIntersection) where -import Prelude (Bool, ($), (<>), (==), (>), (<=), (&&), (||), error, fst, mempty, otherwise, realToFrac, show) +import Prelude (Bool, ($), (<>), (==), (>), (<=), (&&), (||), error, mempty, otherwise, realToFrac, show) import Graphics.Slicer.Math.Definitions (Point2, addPoints, distance, makeLineSeg, scalePoint) -import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum), addVecPairWithErr, ulpVal) +import Graphics.Slicer.Math.GeometricAlgebra (addVecPairWithErr, ulpVal) -import Graphics.Slicer.Math.Intersections (intersectionOf, noIntersection) +import Graphics.Slicer.Math.Intersections (intersectionOf, isAntiCollinear, isCollinear, noIntersection) -import Graphics.Slicer.Math.PGA (CPPoint2, ProjectiveLine2, ProjectivePoint2, PLine2(PLine2), PLine2Err(PLine2Err), angleBetween2PL, distance2PP, eToPL, flipL, join2PP, normalizeL, vecOfL) +import Graphics.Slicer.Math.PGA (ProjectiveLine2, ProjectivePoint2, PLine2(PLine2), PLine2Err(PLine2Err), PPoint2Err, angleBetween2PL, distance2PP, eToPL, flipL, join2PP, normalizeL, vecOfL) -- | Get a Projective Line in the direction of the inside of a contour. Generates a line bisecting the angle of the intersection between a line constructed from the first two points, and another line constrected from the last two points. getFirstArc :: Point2 -> Point2 -> Point2 -> (PLine2, PLine2Err) @@ -45,14 +45,15 @@ getAcuteArcFromPoints :: Point2 -> Point2 -> Point2 -> (PLine2, (PLine2Err, PLin getAcuteArcFromPoints p1 p2 p3 | p1 == p2 || p2 == p3 = error "given two input points that are identical!" -- Since we hawe two equal sides, we can draw a point on the other side of the quad, and use it for constructing our result. + | isCollinear line1 line2 = error "Given colinear points." | distance p2 p1 == distance p2 p3 = (quad, (mempty, mempty, quadErr)) | otherwise = (insideArc, (side1ConsErr <> side1NormErr, side2ConsErr <> side2NormErr, insideArcErr)) where - (insideArc, (_,_, insideArcErr)) = getAcuteAngleBisectorFromLines (side1, side1NormErr) (side2, side2NormErr) + (insideArc, (_,_, insideArcErr)) = getAcuteAngleBisectorFromLines line1 line2 -- FIXME: how do these error quotents effect the resulting line? - (side1, side1NormErr) = normalizeL side1Raw + line1@(_, side1NormErr) = normalizeL side1Raw (side1Raw, side1ConsErr) = eToPL (makeLineSeg p1 p2) - (side2, side2NormErr) = normalizeL side2Raw + line2@(_, side2NormErr) = normalizeL side2Raw (side2Raw, side2ConsErr) = eToPL (makeLineSeg p2 p3) -- Only used for the quad case. (quad, quadErr) = eToPL $ makeLineSeg p2 $ scalePoint 0.5 $ addPoints p1 p3 @@ -67,28 +68,30 @@ getInsideArc line1 line2 = (res, resErr) -- | Get a Projective Line along the angle bisector of the intersection of the two given lines, pointing in the 'acute' direction. -- Note that we assume that the first line points toward the intersection. getAcuteAngleBisectorFromLines :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> (PLine2, (PLine2Err, PLine2Err, PLine2Err)) -getAcuteAngleBisectorFromLines (line1,_) (line2,_) - | npline1 == npline2 = error "Given two identical lines." - | npline1 == flipL npline2 = error "Need to be able to return two PLines." +getAcuteAngleBisectorFromLines line1@(pl1,_) line2@(pl2,_) + | isCollinear line1 line2 = error "Given two colinear lines." + | isAntiCollinear line1 line2 = error "Need to be able to return two PLines." + | noIntersection line1 line2 = error $ "no intersection between pline " <> show line1 <> " and " <> show line2 <> ".\n" | otherwise = (PLine2 addVecRes, (npline1Err, npline2Err, PLine2Err addVecErrs mempty mempty mempty mempty mempty)) where (addVecRes, addVecErrs) = addVecPairWithErr lv1 lv2 lv1 = vecOfL $ flipL npline1 lv2 = vecOfL npline2 - (npline1, npline1Err) = normalizeL line1 - (npline2, npline2Err) = normalizeL line2 + (npline1, npline1Err) = normalizeL pl1 + (npline2, npline2Err) = normalizeL pl2 -- | Get a Projective Line along the angle bisector of the intersection of the two given lines, pointing in the 'obtuse' direction. -getOutsideArc :: (ProjectivePoint2 a, ProjectiveLine2 b, ProjectivePoint2 c, ProjectiveLine2 d) => a -> (b, PLine2Err) -> c -> (d, PLine2Err) -> (PLine2, PLine2Err) +getOutsideArc :: (ProjectivePoint2 a, ProjectiveLine2 b, ProjectivePoint2 c, ProjectiveLine2 d) => (a, PPoint2Err) -> (b, PLine2Err) -> (c, PPoint2Err) -> (d, PLine2Err) -> (PLine2, PLine2Err) getOutsideArc a b c d = (res, resErr) where (res, (_,_, resErr)) = getObtuseAngleBisector a b c d -- | Get a PLine along the angle bisector of the intersection of the two given lines, pointing in the 'obtuse' direction. -- FIXME: the outer line returned by two lines in the same direction should be two lines at a 90 degree angle to the input lines. -getObtuseAngleBisector :: (ProjectivePoint2 a, ProjectiveLine2 b, ProjectivePoint2 c, ProjectiveLine2 d) => a -> (b, PLine2Err) -> c -> (d, PLine2Err) -> (PLine2, (PLine2Err, PLine2Err, PLine2Err)) -getObtuseAngleBisector ppoint1 line1@(pl1, pl1Err) ppoint2 line2@(pl2, pl2Err) - | npline1 == npline2 = error "need to be able to return two PLines." +getObtuseAngleBisector :: (ProjectivePoint2 a, ProjectiveLine2 b, ProjectivePoint2 c, ProjectiveLine2 d) => (a, PPoint2Err) -> (b, PLine2Err) -> (c, PPoint2Err) -> (d, PLine2Err) -> (PLine2, (PLine2Err, PLine2Err, PLine2Err)) +getObtuseAngleBisector ppoint1 line1 ppoint2 line2@(pl2, pl2Err) + | isCollinear line1 line2 = error "Given two colinear lines." + | isAntiCollinear line1 line2 = error "Need to be able to return two PLines." | noIntersection line1 line2 = error $ "no intersection between pline " <> show line1 <> " and " <> show line2 <> ".\n" | l1TowardPoint && l2TowardPoint = (flipL resFlipped, resFlippedErr) | l1TowardPoint = (flipL resNormal, resNormalErr) @@ -97,20 +100,17 @@ getObtuseAngleBisector ppoint1 line1@(pl1, pl1Err) ppoint2 line2@(pl2, pl2Err) where (resNormal, resNormalErr) = getAcuteAngleBisectorFromLines line1 line2 (resFlipped, resFlippedErr) = getAcuteAngleBisectorFromLines line1 (flipL pl2, pl2Err) - npline1 = normalizeL pl1 - npline2 = normalizeL pl2 - intersectionPoint = fst $ intersectionOf line1 line2 - l1TowardPoint = towardIntersection ppoint1 pl1 intersectionPoint - l2TowardPoint = towardIntersection ppoint2 pl2 intersectionPoint + intersectionPoint = intersectionOf line1 line2 + l1TowardPoint = towardIntersection ppoint1 line1 intersectionPoint + l2TowardPoint = towardIntersection ppoint2 line2 intersectionPoint -- | Determine if the line segment formed by the two given points starts with the first point, or the second. --- Note: Due to numeric uncertainty, we cannot rely on Eq here, and must check the sign of the angle. --- FIXME: shouldn't we be given an error component in our inputs? -towardIntersection :: (ProjectivePoint2 a, ProjectiveLine2 b) => a -> b -> CPPoint2 -> Bool -towardIntersection pp1 pl1 pp2 - | d <= realToFrac dErr = error $ "cannot resolve points finely enough.\nPPoint1: " <> show pp1 <> "\nPPoint2: " <> show pp2 <> "\nPLineIn: " <> show pl1 <> "\nnewPLine: " <> show newPLine <> "\n" +-- FIXME: angleBetween2PL should be handling line error. +towardIntersection :: (ProjectivePoint2 a, ProjectiveLine2 b, ProjectivePoint2 c) => (a, PPoint2Err) -> (b, PLine2Err) -> (c, PPoint2Err) -> Bool +towardIntersection point1@(pp1, _) (pl1, _) point2@(pp2, _) + | d <= realToFrac (ulpVal dErr) = error $ "cannot resolve points finely enough.\nPPoint1: " <> show pp1 <> "\nPPoint2: " <> show pp2 <> "\nPLineIn: " <> show pl1 <> "\nnewPLine: " <> show newPLine <> "\n" | otherwise = angleFound > realToFrac (ulpVal angleErr) where (angleFound, (_,_, angleErr)) = angleBetween2PL newPLine pl1 - (d, (_,_,UlpSum dErr)) = distance2PP (pp1, mempty) (pp2, mempty) - newPLine = fst $ join2PP pp1 pp2 + (d, (_,_,dErr)) = distance2PP point1 point2 + (newPLine, _) = join2PP pp1 pp2 diff --git a/Graphics/Slicer/Math/Ganja.hs b/Graphics/Slicer/Math/Ganja.hs index beedadd07..19b7918b7 100644 --- a/Graphics/Slicer/Math/Ganja.hs +++ b/Graphics/Slicer/Math/Ganja.hs @@ -83,7 +83,7 @@ module Graphics.Slicer.Math.Ganja (GanjaAble, ListThree, Radian(Radian), edgesOf, generationsOf, toGanja, dumpGanja, dumpGanjas, randomPL, randomTriangle, randomSquare, randomRectangle, randomConvexDualRightQuad, randomConvexSingleRightQuad, randomConvexBisectableQuad, randomConvexQuad, randomConcaveChevronQuad, randomENode, randomINode, randomPLine, randomPLineWithErr, randomLineSeg, cellFrom, remainderFrom, onlyOne, onlyOneOf, randomPLineThroughOrigin, randomLineSegFromOriginNotX1Y1, randomX1Y1LineSegToOrigin, randomX1Y1LineSegToPoint, randomLineSegFromPointNotX1Y1, randomPLineThroughPoint) where -import Prelude (Bool, Enum, Eq, Fractional, Num, Ord, Show, String, Int, (<>), (<>), (<$>), ($), (>=), (==), abs, concat, error, fromInteger, fromRational, fst, mod, otherwise, replicate, show, signum, snd, zip, (.), (+), (-), (*), (<), (/), (>), (<=), (&&), (/=)) +import Prelude (Bool, Enum, Eq, Fractional, Num, Ord, Show, String, Int, (<>), (<>), (<$>), ($), (>=), (==), abs, concat, error, fromInteger, fromRational, fst, mempty, mod, otherwise, replicate, show, signum, snd, zip, (.), (+), (-), (*), (<), (/), (>), (<=), (&&), (/=)) import Data.Coerce (coerce) @@ -666,7 +666,7 @@ randomINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 = makeINode [maybeFlippedpl1,m maybeFlippedpl1 = (if flipIn1 then flipL (fst pl1) else (fst pl1), snd pl1) maybeFlippedpl2 = (if flipIn2 then flipL (fst pl2) else (fst pl2), snd pl2) bisector1 = normalizeL outsideRes - (outsideRes, outsideResErr) = getOutsideArc pp1 (normalizeL $ fst maybeFlippedpl1) pp2 (normalizeL $ fst maybeFlippedpl2) + (outsideRes, outsideResErr) = getOutsideArc (pp1, mempty) (normalizeL $ fst maybeFlippedpl1) (pp2, mempty) (normalizeL $ fst maybeFlippedpl2) -- | A helper function. constructs a random PLine. randomPLine :: ℝ -> ℝ -> NonZero ℝ -> NonZero ℝ -> PLine2 diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index 76ae510bf..60352941b 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -206,16 +206,16 @@ intersectionBetween pl1 pl2 = saneIntersection $ plinesIntersectIn (pl1,mempty) saneIntersection (IntersectsIn p (_,_, pErr)) = Just $ Right (p,pErr) -- | check if two lines cannot intersect. -noIntersection :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a,PLine2Err) -> (b,PLine2Err) -> Bool -noIntersection pline1@(pl1,_) pline2@(pl2,_) = isCollinear pline1 pline2 || isParallel pl1 pl2 || isAntiCollinear pl1 pl2 || isAntiParallel pl1 pl2 +noIntersection :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Bool +noIntersection pline1@(pl1,_) pline2@(pl2,_) = isCollinear pline1 pline2 || isParallel pl1 pl2 || isAntiCollinear pline1 pline2 || isAntiParallel pl1 pl2 -- | check if two lines are really the same line. -isCollinear :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b,PLine2Err) -> Bool +isCollinear :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Bool isCollinear pline1 pline2 = plinesIntersectIn pline1 pline2 == PCollinear -- | check if two lines are really the same line. -isAntiCollinear :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Bool -isAntiCollinear pline1 pline2 = plinesIntersectIn (pline1, mempty) (pline2, mempty) == PAntiCollinear +isAntiCollinear :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Bool +isAntiCollinear pline1 pline2 = plinesIntersectIn pline1 pline2 == PAntiCollinear -- | check if two lines are parallel. isParallel :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Bool diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 57f663f6f..7b19de161 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -251,6 +251,7 @@ perpLineAt line point = (PLine2 res, resErr) (cPoint, cPointErr) = canonicalizeP point -- | Translate a point a given distance away from where it is, rotating it a given amount clockwise (in radians) around it's original location, with 0 degrees being aligned to the X axis. +-- FIXME: make a single error quotent? translateRotatePPoint2WithErr :: (ProjectivePoint2 a) => a -> ℝ -> ℝ -> (PPoint2, (UlpSum, UlpSum, [ErrVal], PLine2Err, PLine2Err, PPoint2Err, ([ErrVal],[ErrVal]))) translateRotatePPoint2WithErr point d rotation = (res, resErr) where @@ -301,6 +302,11 @@ class Pointable a where -- | Get a projective representation of this point. pPointOf :: a -> PPoint2 +{- +pPointAndErrOf :: (Pointable a) => a -> (PPoint2, PPoint2Err) + | canPoint a = ( +-} + -- | Check if/where the arc of a motorcycle, inode, or enode intersect a line segment. outputIntersectsLineSeg :: (Arcable a) => a -> LineSeg -> Either Intersection PIntersection outputIntersectsLineSeg source l1 diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index 20aa3b913..f4802dc1d 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -180,7 +180,7 @@ averageNodes n1 n2 | nodesAreAntiCollinear n1 n2 = error $ "Cannot (yet) handle two input plines that are collinear.\n" <> dumpInput | n1Distance < getRounded n1Err = error $ "intersection is AT the point of n1!\n" <> dumpInput | n2Distance < getRounded n2Err = error $ "intersection is AT the point of n2!\n" <> dumpInput - | otherwise = makeINode (sortedPair n1 n2) $ Just $ getOutsideArc (pPointOf n1) (outAndErrOf n1) (pPointOf n2) (outAndErrOf n2) + | otherwise = makeINode (sortedPair n1 n2) $ Just $ getOutsideArc (pPointOf n1, mempty) (outAndErrOf n1) (pPointOf n2, mempty) (outAndErrOf n2) where (n1Distance, (_,_, UlpSum n1Err)) = distance2PP (intersectionOf (outAndErrOf n1) (outAndErrOf n2)) (pPointOf n1, mempty) (n2Distance, (_,_, UlpSum n2Err)) = distance2PP (intersectionOf (outAndErrOf n1) (outAndErrOf n2)) (pPointOf n2, mempty) @@ -235,7 +235,7 @@ convexNodes contour = catMaybes $ onlyNodes <$> zip (linePairs contour) (mapWith -- FIXME: shouldn't this be pulled into PGA.hs, as part of an outsIntersectIn? nodesAreAntiCollinear :: (Pointable a, Arcable a, Pointable b, Arcable b) => a -> b -> Bool nodesAreAntiCollinear node1 node2 - | hasArc node1 && hasArc node2 && isAntiCollinear (outOf node1) (outOf node2) = True + | hasArc node1 && hasArc node2 && isAntiCollinear (outAndErrOf node1) (outAndErrOf node2) = True | canPoint node1 && canPoint node2 && hasArc node1 && hasArc node2 = (distancePPointToPLine (pPointOf node1) (outOf node2) < fudgeFactor*50) && (distancePPointToPLine (pPointOf node2) (outOf node1) < fudgeFactor*50) | otherwise = False diff --git a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs index e27301f5f..9e2d6e45d 100644 --- a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs +++ b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs @@ -142,7 +142,7 @@ crashMotorcycles contour holes crashOf :: Motorcycle -> Motorcycle -> Maybe Collision crashOf mot1 mot2@(Motorcycle (inSeg2, _) _ _) -- If we have a clear path between mot1 and the origin of mot2 - | isAntiCollinear (outOf mot1) (outOf mot2) && motorcycleIntersectsAt contour mot1 == (inSeg2, Left $ endPoint inSeg2) = Just $ Collision (mot1,mot2, slist []) Nothing HeadOn + | isAntiCollinear (outAndErrOf mot1) (outAndErrOf mot2) && motorcycleIntersectsAt contour mot1 == (inSeg2, Left $ endPoint inSeg2) = Just $ Collision (mot1,mot2, slist []) Nothing HeadOn | noIntersection (outAndErrOf mot1) (outAndErrOf mot2) = Nothing | intersectionIsBehind mot1 = Nothing | intersectionIsBehind mot2 = Nothing diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index 82c750803..205700fc3 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -59,7 +59,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(GEZero, GEPlu import Graphics.Slicer.Math.Lossy (angleBetween, canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenPLines, distancePPointToPLine, eToCPPoint2, eToPLine2, getFirstArc, join2PPoint2, normalizePLine2, pPointOnPerp) -- Our 2D Projective Geometric Algebra library. -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PLine2Err(PLine2Err), canonicalizeP, distance2PP, distancePPointToPLineWithErr, eToPL, eToPPoint2, interpolate2PP, intersect2PL, translateL, translateRotatePPoint2WithErr, angleBetween2PL, flipL, join2PP, makePPoint2, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, distancePPointToPLineWithErr, errOfOut, pPointOnPerpWithErr, outOf, pPointOf, outputIntersectsLineSeg) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PLine2Err(PLine2Err), canonicalizeP, distance2PP, distancePPointToPLineWithErr, eToPL, eToPP, eToPPoint2, interpolate2PP, intersect2PL, translateL, translateRotatePPoint2WithErr, angleBetween2PL, flipL, join2PP, makePPoint2, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, distancePPointToPLineWithErr, errOfOut, pPointOnPerpWithErr, outOf, pPointOf, outputIntersectsLineSeg) -- The primitives of our PGA only library, and error estimation code. @@ -788,23 +788,23 @@ prop_AxisAligned45DegreeAngles xPos yPos offset rawMagnitude1 rawMagnitude2 prop_AxisAlignedRightAnglesOutside :: Bool -> Bool -> ℝ -> Positive ℝ -> Bool prop_AxisAlignedRightAnglesOutside xPos yPos offset rawMagnitude | xPos && yPos = normalizePLine2 (fst $ - getOutsideArc (eToPPoint2 $ Point2 (offset,offset+mag)) (eToPL $ LineSeg (Point2 (offset,offset+mag)) (Point2 (offset,offset))) - (eToPPoint2 $ Point2 (offset+mag,offset)) (eToPL $ LineSeg (Point2 (offset+mag,offset)) (Point2 (offset,offset)))) + getOutsideArc (eToPP $ Point2 (offset,offset+mag), mempty) (eToPL $ LineSeg (Point2 (offset,offset+mag)) (Point2 (offset,offset))) + (eToPP $ Point2 (offset+mag,offset), mempty) (eToPL $ LineSeg (Point2 (offset+mag,offset)) (Point2 (offset,offset)))) `myAngleBetween` NPLine2 (GVec [GVal (-0.7071067811865475) (singleton (GEPlus 1)), GVal 0.7071067811865475 (singleton (GEPlus 2))]) | xPos = normalizePLine2 (fst $ - getOutsideArc (eToPPoint2 $ Point2 (offset,-(offset+mag))) (eToPL $ LineSeg (Point2 (offset,-(offset+mag))) (Point2 (offset,-offset))) - (eToPPoint2 $ Point2 (offset+mag,-offset)) (eToPL $ LineSeg (Point2 (offset+mag,-offset)) (Point2 (offset,-offset)))) + getOutsideArc (eToPP $ Point2 (offset,-(offset+mag)), mempty) (eToPL $ LineSeg (Point2 (offset,-(offset+mag))) (Point2 (offset,-offset))) + (eToPP $ Point2 (offset+mag,-offset), mempty) (eToPL $ LineSeg (Point2 (offset+mag,-offset)) (Point2 (offset,-offset)))) `myAngleBetween` NPLine2 (GVec [GVal 0.7071067811865475 (singleton (GEPlus 1)), GVal 0.7071067811865475 (singleton (GEPlus 2))]) | not xPos && yPos = normalizePLine2 ( fst $ - getOutsideArc (eToPPoint2 $ Point2 (-offset,offset+mag)) (eToPL $ LineSeg (Point2 (-offset,offset+mag)) (Point2 (-offset,offset))) - (eToPPoint2 $ Point2 (-(offset+mag),offset)) (eToPL $ LineSeg (Point2 (-(offset+mag),offset)) (Point2 (-offset,offset)))) + getOutsideArc (eToPP $ Point2 (-offset,offset+mag), mempty) (eToPL $ LineSeg (Point2 (-offset,offset+mag)) (Point2 (-offset,offset))) + (eToPP $ Point2 (-(offset+mag),offset), mempty) (eToPL $ LineSeg (Point2 (-(offset+mag),offset)) (Point2 (-offset,offset)))) `myAngleBetween` NPLine2 (GVec [GVal (-0.7071067811865475) (singleton (GEPlus 1)), GVal (-0.7071067811865475) (singleton (GEPlus 2))]) | otherwise = normalizePLine2 ( fst $ - getOutsideArc (eToPPoint2 $ Point2 (-offset,-(offset+mag))) (eToPL $ LineSeg (Point2 (-offset,-(offset+mag))) (Point2 (-offset,-offset))) - (eToPPoint2 $ Point2 (-(offset+mag),-offset)) (eToPL $ LineSeg (Point2 (-(offset+mag),-offset)) (Point2 (-offset,-offset)))) + getOutsideArc (eToPP $ Point2 (-offset,-(offset+mag)), mempty) (eToPL $ LineSeg (Point2 (-offset,-(offset+mag))) (Point2 (-offset,-offset))) + (eToPP $ Point2 (-(offset+mag),-offset), mempty) (eToPL $ LineSeg (Point2 (-(offset+mag),-offset)) (Point2 (-offset,-offset)))) `myAngleBetween` NPLine2 (GVec [GVal 0.7071067811865475 (singleton (GEPlus 1)), GVal (-0.7071067811865475) (singleton (GEPlus 2))]) where @@ -819,23 +819,23 @@ prop_AxisAlignedRightAnglesOutside xPos yPos offset rawMagnitude prop_AxisAligned135DegreeAnglesOutside :: Bool -> Bool -> Positive ℝ -> Positive ℝ -> Bool prop_AxisAligned135DegreeAnglesOutside xPos yPos rawOffset rawMagnitude | xPos && yPos = normalizePLine2 ( fst $ - getOutsideArc (eToPPoint2 $ Point2 (offset+mag,offset)) (eToPL $ LineSeg (Point2 (offset+mag,offset)) (Point2 (offset,offset))) - (eToPPoint2 $ Point2 (offset+mag,offset+mag)) (eToPL $ LineSeg (Point2 (offset+mag,offset+mag)) (Point2 (offset,offset)))) + getOutsideArc (eToPP $ Point2 (offset+mag,offset), mempty) (eToPL $ LineSeg (Point2 (offset+mag,offset)) (Point2 (offset,offset))) + (eToPP $ Point2 (offset+mag,offset+mag), mempty) (eToPL $ LineSeg (Point2 (offset+mag,offset+mag)) (Point2 (offset,offset)))) `myAngleBetween` NPLine2 (GVec [GVal (-0.3826834323650899) (singleton (GEPlus 1)), GVal 0.9238795325112867 (singleton (GEPlus 2))]) | xPos = normalizePLine2 ( fst $ - getOutsideArc (eToPPoint2 $ Point2 (offset+mag,-offset)) (eToPL $ LineSeg (Point2 (offset+mag,-offset)) (Point2 (offset,-offset))) - (eToPPoint2 $ Point2 (offset+mag,-(offset+mag))) (eToPL $ LineSeg (Point2 (offset+mag,-(offset+mag))) (Point2 (offset,-offset)))) + getOutsideArc (eToPP $ Point2 (offset+mag,-offset), mempty) (eToPL $ LineSeg (Point2 (offset+mag,-offset)) (Point2 (offset,-offset))) + (eToPP $ Point2 (offset+mag,-(offset+mag)), mempty) (eToPL $ LineSeg (Point2 (offset+mag,-(offset+mag))) (Point2 (offset,-offset)))) `myAngleBetween` NPLine2 (GVec [GVal 0.3826834323650899 (singleton (GEPlus 1)), GVal 0.9238795325112867 (singleton (GEPlus 2))]) | not xPos && yPos = normalizePLine2 ( fst $ - getOutsideArc (eToPPoint2 $ Point2 (-(offset+mag),offset)) (eToPL $ LineSeg (Point2 (-(offset+mag),offset)) (Point2 (-offset,offset))) - (eToPPoint2 $ Point2 (-(offset+mag),offset+mag)) (eToPL $ LineSeg (Point2 (-(offset+mag),offset+mag)) (Point2 (-offset,offset)))) + getOutsideArc (eToPP $ Point2 (-(offset+mag),offset), mempty) (eToPL $ LineSeg (Point2 (-(offset+mag),offset)) (Point2 (-offset,offset))) + (eToPP $ Point2 (-(offset+mag),offset+mag), mempty) (eToPL $ LineSeg (Point2 (-(offset+mag),offset+mag)) (Point2 (-offset,offset)))) `myAngleBetween` NPLine2 (GVec [GVal (-0.3826834323650899) (singleton (GEPlus 1)), GVal (-0.9238795325112867) (singleton (GEPlus 2))]) | otherwise = normalizePLine2 ( fst $ - getOutsideArc (eToPPoint2 $ Point2 (-(offset+mag),-offset)) (eToPL $ LineSeg (Point2 (-(offset+mag),-offset)) (Point2 (-offset,-offset))) - (eToPPoint2 $ Point2 (-(offset+mag),-(offset+mag))) (eToPL $ LineSeg (Point2 (-(offset+mag),-(offset+mag))) (Point2 (-offset,-offset)))) + getOutsideArc (eToPP $ Point2 (-(offset+mag),-offset), mempty) (eToPL $ LineSeg (Point2 (-(offset+mag),-offset)) (Point2 (-offset,-offset))) + (eToPP $ Point2 (-(offset+mag),-(offset+mag)), mempty) (eToPL $ LineSeg (Point2 (-(offset+mag),-(offset+mag))) (Point2 (-offset,-offset)))) `myAngleBetween` NPLine2 (GVec [GVal 0.3826834323650899 (singleton (GEPlus 1)), GVal (-0.9238795325112867) (singleton (GEPlus 2))]) where @@ -1330,19 +1330,19 @@ prop_obtuseBisectorOnBiggerSide_makeINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 prop_eNodeTowardIntersection1 :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> Positive ℝ -> Radian ℝ -> Expectation prop_eNodeTowardIntersection1 x y d1 rawR1 d2 rawR2 = l1TowardIntersection --> True where - l1TowardIntersection = towardIntersection ((\(CPPoint2 v)-> PPoint2 v) $ eToPPoint2 $ startPoint l1) pl1 eNodePoint - (eNodePoint, _) = canonicalizeP $ pPointOf eNode + l1TowardIntersection = towardIntersection (eToPP $ startPoint l1, mempty) pl1 eNodePoint + eNodePoint = canonicalizeP $ pPointOf eNode l1 = getFirstLineSeg eNode - pl1 = eToPLine2 l1 + pl1 = eToPL l1 eNode = randomENode x y d1 rawR1 d2 rawR2 prop_eNodeAwayFromIntersection2 :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> Positive ℝ -> Radian ℝ -> Expectation prop_eNodeAwayFromIntersection2 x y d1 rawR1 d2 rawR2 = l2TowardIntersection --> False where - l2TowardIntersection = towardIntersection ((\(CPPoint2 v)-> PPoint2 v) $ eToPPoint2 $ endPoint l2) pl2 eNodePoint - (eNodePoint, _) = canonicalizeP $ pPointOf eNode + l2TowardIntersection = towardIntersection (eToPP $ endPoint l2, mempty) pl2 eNodePoint + eNodePoint = canonicalizeP $ pPointOf eNode l2 = getLastLineSeg eNode - pl2 = eToPLine2 l2 + pl2 = eToPL l2 eNode = randomENode x y d1 rawR1 d2 rawR2 prop_translateRotateMoves :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> Expectation From b58e81cba6e3d29beda1154616dd43162b46f980 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Thu, 1 Dec 2022 23:40:45 +0000 Subject: [PATCH 110/206] add more sanity tests, rename a function, and clean up error messages. --- Graphics/Slicer/Math/Arcs.hs | 45 ++++++++++++++++++++++-------------- 1 file changed, 28 insertions(+), 17 deletions(-) diff --git a/Graphics/Slicer/Math/Arcs.hs b/Graphics/Slicer/Math/Arcs.hs index 157882835..ba1e21361 100644 --- a/Graphics/Slicer/Math/Arcs.hs +++ b/Graphics/Slicer/Math/Arcs.hs @@ -68,10 +68,10 @@ getInsideArc line1 line2 = (res, resErr) -- | Get a Projective Line along the angle bisector of the intersection of the two given lines, pointing in the 'acute' direction. -- Note that we assume that the first line points toward the intersection. getAcuteAngleBisectorFromLines :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> (PLine2, (PLine2Err, PLine2Err, PLine2Err)) -getAcuteAngleBisectorFromLines line1@(pl1,_) line2@(pl2,_) - | isCollinear line1 line2 = error "Given two colinear lines." - | isAntiCollinear line1 line2 = error "Need to be able to return two PLines." - | noIntersection line1 line2 = error $ "no intersection between pline " <> show line1 <> " and " <> show line2 <> ".\n" +getAcuteAngleBisectorFromLines line1@(pl1, _) line2@(pl2, _) + | isCollinear line1 line2 = error "Asked to find the acute bisector of two colinear lines!" + | isAntiCollinear line1 line2 = error "Asked to find the acute bisector of two anti-colinear lines!" + | noIntersection line1 line2 = error $ "No intersection between line " <> show line1 <> " and line " <> show line2 <> ".\n" | otherwise = (PLine2 addVecRes, (npline1Err, npline2Err, PLine2Err addVecErrs mempty mempty mempty mempty mempty)) where (addVecRes, addVecErrs) = addVecPairWithErr lv1 lv2 @@ -84,22 +84,33 @@ getAcuteAngleBisectorFromLines line1@(pl1,_) line2@(pl2,_) getOutsideArc :: (ProjectivePoint2 a, ProjectiveLine2 b, ProjectivePoint2 c, ProjectiveLine2 d) => (a, PPoint2Err) -> (b, PLine2Err) -> (c, PPoint2Err) -> (d, PLine2Err) -> (PLine2, PLine2Err) getOutsideArc a b c d = (res, resErr) where - (res, (_,_, resErr)) = getObtuseAngleBisector a b c d + (res, (_,_, resErr)) = getObtuseAngleBisectorFromPointedLines a b c d -- | Get a PLine along the angle bisector of the intersection of the two given lines, pointing in the 'obtuse' direction. -- FIXME: the outer line returned by two lines in the same direction should be two lines at a 90 degree angle to the input lines. -getObtuseAngleBisector :: (ProjectivePoint2 a, ProjectiveLine2 b, ProjectivePoint2 c, ProjectiveLine2 d) => (a, PPoint2Err) -> (b, PLine2Err) -> (c, PPoint2Err) -> (d, PLine2Err) -> (PLine2, (PLine2Err, PLine2Err, PLine2Err)) -getObtuseAngleBisector ppoint1 line1 ppoint2 line2@(pl2, pl2Err) - | isCollinear line1 line2 = error "Given two colinear lines." - | isAntiCollinear line1 line2 = error "Need to be able to return two PLines." - | noIntersection line1 line2 = error $ "no intersection between pline " <> show line1 <> " and " <> show line2 <> ".\n" - | l1TowardPoint && l2TowardPoint = (flipL resFlipped, resFlippedErr) - | l1TowardPoint = (flipL resNormal, resNormalErr) - | l2TowardPoint = (resNormal, resNormalErr) - | otherwise = (resFlipped, resFlippedErr) +getObtuseAngleBisectorFromPointedLines :: (ProjectivePoint2 a, ProjectiveLine2 b, ProjectivePoint2 c, ProjectiveLine2 d) => (a, PPoint2Err) -> (b, PLine2Err) -> (c, PPoint2Err) -> (d, PLine2Err) -> (PLine2, (PLine2Err, PLine2Err, PLine2Err)) +getObtuseAngleBisectorFromPointedLines ppoint1 line1 ppoint2 line2 + | isCollinear line1 line2 = error "Asked to find the obtuse bisector of two colinear lines!" + | isAntiCollinear line1 line2 = error "Asked to find the obtuse bisector of two anti-colinear lines!" + | noIntersection line1 line2 = error $ "No intersection between line " <> show line1 <> " and line " <> show line2 <> ".\n" + | pointDistance <= realToFrac (ulpVal pointDistanceErr) = error $ "cannot have two identical input points:\n" <> show ppoint1 <> "\n" <> show ppoint2 <> "\n" + | point1IntersectDistance <= realToFrac (ulpVal point1IntersectDistanceErr) = error $ "intersection of plines is at first ppoint:\n" + <> show ppoint1 <> "\n" + <> show line1 <> "\n" + <> show line2 <> "\n" + | point2IntersectDistance <= realToFrac (ulpVal point2IntersectDistanceErr) = error $ "intersection of plines is at second ppoint:\n" + <> show ppoint2 <> "\n" + <> show line1 <> "\n" + <> show line2 <> "\n" + | l1TowardPoint && l2TowardPoint = flipFst $ getAcuteAngleBisectorFromLines line1 $ flipFst line2 + | l1TowardPoint = flipFst $ getAcuteAngleBisectorFromLines line1 line2 + | l2TowardPoint = getAcuteAngleBisectorFromLines line1 line2 + | otherwise = getAcuteAngleBisectorFromLines line1 $ flipFst line2 where - (resNormal, resNormalErr) = getAcuteAngleBisectorFromLines line1 line2 - (resFlipped, resFlippedErr) = getAcuteAngleBisectorFromLines line1 (flipL pl2, pl2Err) + (pointDistance, (_,_,pointDistanceErr)) = distance2PP ppoint1 ppoint2 + (point1IntersectDistance, (_,_, point1IntersectDistanceErr)) = distance2PP ppoint1 intersectionPoint + (point2IntersectDistance, (_,_, point2IntersectDistanceErr)) = distance2PP ppoint2 intersectionPoint + flipFst (a,b) = (flipL a,b) intersectionPoint = intersectionOf line1 line2 l1TowardPoint = towardIntersection ppoint1 line1 intersectionPoint l2TowardPoint = towardIntersection ppoint2 line2 intersectionPoint @@ -112,5 +123,5 @@ towardIntersection point1@(pp1, _) (pl1, _) point2@(pp2, _) | otherwise = angleFound > realToFrac (ulpVal angleErr) where (angleFound, (_,_, angleErr)) = angleBetween2PL newPLine pl1 - (d, (_,_,dErr)) = distance2PP point1 point2 + (d, (_,_, dErr)) = distance2PP point1 point2 (newPLine, _) = join2PP pp1 pp2 From 4fa0e3ddfc48ee20abbdc14c438a932e9cec6f3c Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Thu, 1 Dec 2022 23:54:34 +0000 Subject: [PATCH 111/206] cleanup comments. --- Graphics/Slicer/Math/Arcs.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/Graphics/Slicer/Math/Arcs.hs b/Graphics/Slicer/Math/Arcs.hs index ba1e21361..be0a2886b 100644 --- a/Graphics/Slicer/Math/Arcs.hs +++ b/Graphics/Slicer/Math/Arcs.hs @@ -58,14 +58,14 @@ getAcuteArcFromPoints p1 p2 p3 -- Only used for the quad case. (quad, quadErr) = eToPL $ makeLineSeg p2 $ scalePoint 0.5 $ addPoints p1 p3 --- | Get a Projective Line along the angle bisector of the intersection of the two given lines, pointing in the 'acute' direction. +-- | Get a projective line along the angle bisector of the intersection of the two given lines, pointing in the 'acute' direction. -- A wrapper of getAcuteAngleBisectorFromLines, dropping the returning of normalization error of the inputs. getInsideArc :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> (PLine2, PLine2Err) getInsideArc line1 line2 = (res, resErr) where (res, (_,_, resErr)) = getAcuteAngleBisectorFromLines line1 line2 --- | Get a Projective Line along the angle bisector of the intersection of the two given lines, pointing in the 'acute' direction. +-- | Get a projective line along the angle bisector of the intersection of the two given lines, pointing in the 'acute' direction. -- Note that we assume that the first line points toward the intersection. getAcuteAngleBisectorFromLines :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> (PLine2, (PLine2Err, PLine2Err, PLine2Err)) getAcuteAngleBisectorFromLines line1@(pl1, _) line2@(pl2, _) @@ -80,14 +80,13 @@ getAcuteAngleBisectorFromLines line1@(pl1, _) line2@(pl2, _) (npline1, npline1Err) = normalizeL pl1 (npline2, npline2Err) = normalizeL pl2 --- | Get a Projective Line along the angle bisector of the intersection of the two given lines, pointing in the 'obtuse' direction. +-- | Get a projective line along the angle bisector of the intersection of the two given lines, pointing in the 'obtuse' direction. getOutsideArc :: (ProjectivePoint2 a, ProjectiveLine2 b, ProjectivePoint2 c, ProjectiveLine2 d) => (a, PPoint2Err) -> (b, PLine2Err) -> (c, PPoint2Err) -> (d, PLine2Err) -> (PLine2, PLine2Err) getOutsideArc a b c d = (res, resErr) where (res, (_,_, resErr)) = getObtuseAngleBisectorFromPointedLines a b c d --- | Get a PLine along the angle bisector of the intersection of the two given lines, pointing in the 'obtuse' direction. --- FIXME: the outer line returned by two lines in the same direction should be two lines at a 90 degree angle to the input lines. +-- | Get a projective line along the angle bisector of the intersection of the two given lines, pointing in the 'obtuse' direction. getObtuseAngleBisectorFromPointedLines :: (ProjectivePoint2 a, ProjectiveLine2 b, ProjectivePoint2 c, ProjectiveLine2 d) => (a, PPoint2Err) -> (b, PLine2Err) -> (c, PPoint2Err) -> (d, PLine2Err) -> (PLine2, (PLine2Err, PLine2Err, PLine2Err)) getObtuseAngleBisectorFromPointedLines ppoint1 line1 ppoint2 line2 | isCollinear line1 line2 = error "Asked to find the obtuse bisector of two colinear lines!" From 4d1c6a3473af25ea562c3e89c531cf2458f75973 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Fri, 2 Dec 2022 12:40:53 +0000 Subject: [PATCH 112/206] introduce join2EP, and use it to shorten up contour.hs. --- Graphics/Slicer/Math/Contour.hs | 48 ++++++++++++++++----------------- Graphics/Slicer/Math/PGA.hs | 7 +++++ 2 files changed, 31 insertions(+), 24 deletions(-) diff --git a/Graphics/Slicer/Math/Contour.hs b/Graphics/Slicer/Math/Contour.hs index 18d441889..df561f321 100644 --- a/Graphics/Slicer/Math/Contour.hs +++ b/Graphics/Slicer/Math/Contour.hs @@ -32,7 +32,7 @@ import Data.List as DL (uncons) import Data.List.Extra (unsnoc) -import Data.Maybe(Maybe(Just,Nothing), catMaybes, fromJust, fromMaybe, isJust, mapMaybe) +import Data.Maybe (Maybe(Just,Nothing), catMaybes, fromJust, fromMaybe, isJust, mapMaybe) import Slist (len, size, slist, safeLast, safeLast, safeHead) @@ -50,9 +50,9 @@ import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum)) import Graphics.Slicer.Math.Intersections (contourIntersectionCount, noIntersection) -import Graphics.Slicer.Math.Lossy (join2PPoint2, pPointBetweenPPoints, pToEPoint2) +import Graphics.Slicer.Math.Lossy (pPointBetweenPPoints, pToEPoint2) -import Graphics.Slicer.Math.PGA (PPoint2, eToPPoint2, eToPL, join2PP, pLineIsLeft, pPointOnPerpWithErr) +import Graphics.Slicer.Math.PGA (PPoint2, eToPPoint2, eToPL, join2EP, join2PP, pLineIsLeft, pPointOnPerpWithErr) -- Unapologetically ripped from ImplicitCAD. -- Added the ability to look at line segments backwards. @@ -225,14 +225,14 @@ followingLineSeg x = followingLineSegLooped x x -- | Check if the left hand side of the first line segment of a contour is toward the inside of the contour. insideIsLeft :: Contour -> Maybe Bool insideIsLeft contour - | isJust (innerContourPoint contour) = Just $ pLineIsLeft (pl1, pl1Err) (pl2,pl2Err) == Just True + | isJust (innerContourPoint contour) = Just $ pLineIsLeft line1 (pl2, pl2Err) == Just True | otherwise = Nothing where - (p1, p2) = firstPointPairOfContour contour - myMidPoint = pPointBetweenPPoints (eToPPoint2 p1) (eToPPoint2 p2) 0.5 0.5 (pl2,(_,_, pl2Err)) = join2PP myMidPoint innerPoint - innerPoint = fromJust $ innerContourPoint contour - (pl1, pl1Err) = eToPL $ makeLineSeg p1 p2 + myMidPoint = pPointBetweenPPoints (eToPPoint2 p1) (eToPPoint2 p2) 0.5 0.5 + line1 = eToPL $ makeLineSeg p1 p2 + innerPoint = fromJust $ innerContourPoint contour + (p1, p2) = firstPointPairOfContour contour -- | Find a point on the interior of a given contour, on the perpendicular bisector of the first line segment, a given distance away from the line segment. innerContourPoint :: Contour -> Maybe PPoint2 @@ -244,7 +244,7 @@ innerContourPoint contour | otherwise = Nothing where (p1, p2) = firstPointPairOfContour contour - source = join2PPoint2 (eToPPoint2 p1) (eToPPoint2 p2) + (source, _) = join2EP p1 p2 myMidPoint = pPointBetweenPPoints (eToPPoint2 p1) (eToPPoint2 p2) 0.5 0.5 (perpPoint, (_,_,_, UlpSum perpErr)) = pPointOnPerpWithErr source myMidPoint minDistanceFromSeg (otherPoint,(_,_,_, UlpSum otherErr)) = pPointOnPerpWithErr source myMidPoint (-minDistanceFromSeg) @@ -260,17 +260,17 @@ innerContourPoint contour -- | Find a point that is guaranteed to be outside of the given contour, and is not on the same line as the first line segment of the contour. pointFarOutsideContour :: Contour -> Point2 pointFarOutsideContour contour - | not (noIntersection (pLine1, pLine1Err) (firstPLine, firstPLineErr)) = outsidePoint1 - | not (noIntersection (pLine2, pLine2Err) (firstPLine, firstPLineErr)) = outsidePoint2 - | not (noIntersection (pLine3, pLine3Err) (firstPLine, firstPLineErr)) = outsidePoint3 + | not (noIntersection line1 firstLine) = outsidePoint1 + | not (noIntersection line2 firstLine) = outsidePoint2 + | not (noIntersection line3 firstLine) = outsidePoint3 | otherwise = error "cannot get here." where minPoint = fst (minMaxPoints contour) (p1, p2) = firstPointPairOfContour contour - (firstPLine, (_,_,firstPLineErr)) = join2PP (eToPPoint2 p1) (eToPPoint2 p2) - (pLine1, (_,_, pLine1Err)) = join2PP (eToPPoint2 p1) (eToPPoint2 outsidePoint1) - (pLine2, (_,_, pLine2Err)) = join2PP (eToPPoint2 p1) (eToPPoint2 outsidePoint2) - (pLine3, (_,_, pLine3Err)) = join2PP (eToPPoint2 p1) (eToPPoint2 outsidePoint3) + firstLine = join2EP p1 p2 + line1 = join2EP p1 outsidePoint1 + line2 = join2EP p1 outsidePoint2 + line3 = join2EP p1 outsidePoint3 outsidePoint1 = Point2 (xOf minPoint - 0.1 , yOf minPoint - 0.1) outsidePoint2 = Point2 (xOf minPoint - 0.2 , yOf minPoint - 0.1) outsidePoint3 = Point2 (xOf minPoint - 0.1 , yOf minPoint - 0.2) @@ -278,9 +278,9 @@ pointFarOutsideContour contour -- | Find a point that is guaranteed to be outside of the given contour, and is not on the same line as the first line segment of the contour. pointFarOutsideContours :: Contour -> Contour -> Point2 pointFarOutsideContours contour1 contour2 - | not (noIntersection (pLine1, pLine1Err) (firstPLine, firstPLineErr)) && not (noIntersection (pLine1, pLine1Err) (secondPLine, secondPLineErr)) = outsidePoint1 - | not (noIntersection (pLine2, pLine2Err) (firstPLine, firstPLineErr)) && not (noIntersection (pLine2, pLine2Err) (secondPLine, secondPLineErr)) = outsidePoint2 - | not (noIntersection (pLine3, pLine3Err) (firstPLine, firstPLineErr)) && not (noIntersection (pLine3, pLine3Err) (secondPLine, secondPLineErr)) = outsidePoint3 + | not (noIntersection line1 firstPLine) && not (noIntersection line1 secondPLine) = outsidePoint1 + | not (noIntersection line2 firstPLine) && not (noIntersection line2 secondPLine) = outsidePoint2 + | not (noIntersection line3 firstPLine) && not (noIntersection line3 secondPLine) = outsidePoint3 | otherwise = error "cannot get here...?" where minPoint1 = fst $ minMaxPoints contour1 @@ -288,11 +288,11 @@ pointFarOutsideContours contour1 contour2 minPoint = Point2 (min (xOf minPoint1) (xOf minPoint2),min (yOf minPoint1) (yOf minPoint2)) (p1, p2) = firstPointPairOfContour contour1 (p3, p4) = firstPointPairOfContour contour2 - (firstPLine, (_,_,firstPLineErr)) = join2PP (eToPPoint2 p1) (eToPPoint2 p2) - (secondPLine, (_,_,secondPLineErr)) = join2PP (eToPPoint2 p3) (eToPPoint2 p4) - (pLine1, (_,_, pLine1Err)) = join2PP (eToPPoint2 p1) (eToPPoint2 outsidePoint1) - (pLine2, (_,_, pLine2Err)) = join2PP (eToPPoint2 p1) (eToPPoint2 outsidePoint2) - (pLine3, (_,_, pLine3Err)) = join2PP (eToPPoint2 p1) (eToPPoint2 outsidePoint3) + firstPLine = join2EP p1 p2 + secondPLine = join2EP p3 p4 + line1 = join2EP p1 outsidePoint1 + line2 = join2EP p1 outsidePoint2 + line3 = join2EP p1 outsidePoint3 outsidePoint1 = Point2 (xOf minPoint - 0.1 , yOf minPoint - 0.1) outsidePoint2 = Point2 (xOf minPoint - 0.2 , yOf minPoint - 0.1) outsidePoint3 = Point2 (xOf minPoint - 0.1 , yOf minPoint - 0.2) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 7b19de161..447133202 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -61,6 +61,7 @@ module Graphics.Slicer.Math.PGA( interpolate2PP, intersectsWithErr, intersect2PL, + join2EP, join2PP, makePPoint2, outAndErrOf, @@ -529,3 +530,9 @@ euclidianToProjectiveLine l = (res, resErr) where (res, (_, _, resErr)) = join2PP (eToPP $ startPoint l) (eToPP $ endPoint l) eToPL l = euclidianToProjectiveLine l + +joinTwoEuclidianPoints, join2EP :: Point2 -> Point2 -> (PLine2, PLine2Err) +joinTwoEuclidianPoints p1 p2 = (res, resErr) + where + (res, (_, _, resErr)) = join2PP (eToPP p1) (eToPP p2) +join2EP p1 p2 = joinTwoEuclidianPoints p1 p2 From c3a528848ae95825a5f15dba8f2296d5d471c0e6 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Fri, 2 Dec 2022 18:32:53 +0000 Subject: [PATCH 113/206] introduce join2EP, remove eToPPoint2 renaming it eToPP, and improve variable names and formatting in contour.hs. --- Graphics/Slicer/Math/Contour.hs | 26 +++++++------- Graphics/Slicer/Math/Ganja.hs | 10 +++--- Graphics/Slicer/Math/Lossy.hs | 4 +-- Graphics/Slicer/Math/PGA.hs | 7 ++-- Graphics/Slicer/Math/Skeleton/Cells.hs | 4 +-- Graphics/Slicer/Math/Skeleton/Definitions.hs | 6 ++-- tests/Math/PGA.hs | 36 ++++++++++---------- 7 files changed, 46 insertions(+), 47 deletions(-) diff --git a/Graphics/Slicer/Math/Contour.hs b/Graphics/Slicer/Math/Contour.hs index df561f321..59dfdedd9 100644 --- a/Graphics/Slicer/Math/Contour.hs +++ b/Graphics/Slicer/Math/Contour.hs @@ -52,7 +52,7 @@ import Graphics.Slicer.Math.Intersections (contourIntersectionCount, noIntersect import Graphics.Slicer.Math.Lossy (pPointBetweenPPoints, pToEPoint2) -import Graphics.Slicer.Math.PGA (PPoint2, eToPPoint2, eToPL, join2EP, join2PP, pLineIsLeft, pPointOnPerpWithErr) +import Graphics.Slicer.Math.PGA (PPoint2, eToPP, eToPL, join2EP, join2PP, pLineIsLeft, pPointOnPerpWithErr) -- Unapologetically ripped from ImplicitCAD. -- Added the ability to look at line segments backwards. @@ -225,11 +225,11 @@ followingLineSeg x = followingLineSegLooped x x -- | Check if the left hand side of the first line segment of a contour is toward the inside of the contour. insideIsLeft :: Contour -> Maybe Bool insideIsLeft contour - | isJust (innerContourPoint contour) = Just $ pLineIsLeft line1 (pl2, pl2Err) == Just True + | isJust (innerContourPoint contour) = Just $ pLineIsLeft line1 (lineToInside, lineToInsideErr) == Just True | otherwise = Nothing where - (pl2,(_,_, pl2Err)) = join2PP myMidPoint innerPoint - myMidPoint = pPointBetweenPPoints (eToPPoint2 p1) (eToPPoint2 p2) 0.5 0.5 + (lineToInside, (_,_, lineToInsideErr)) = join2PP myMidPoint innerPoint + myMidPoint = pPointBetweenPPoints (eToPP p1) (eToPP p2) 0.5 0.5 line1 = eToPL $ makeLineSeg p1 p2 innerPoint = fromJust $ innerContourPoint contour (p1, p2) = firstPointPairOfContour contour @@ -243,9 +243,9 @@ innerContourPoint contour | odd otherIntersections = error "cannot ensure other point is on the right side of the contour." | otherwise = Nothing where - (p1, p2) = firstPointPairOfContour contour - (source, _) = join2EP p1 p2 - myMidPoint = pPointBetweenPPoints (eToPPoint2 p1) (eToPPoint2 p2) 0.5 0.5 + (p1, p2) = firstPointPairOfContour contour + source = fst $ join2EP p1 p2 + myMidPoint = pPointBetweenPPoints (eToPP p1) (eToPP p2) 0.5 0.5 (perpPoint, (_,_,_, UlpSum perpErr)) = pPointOnPerpWithErr source myMidPoint minDistanceFromSeg (otherPoint,(_,_,_, UlpSum otherErr)) = pPointOnPerpWithErr source myMidPoint (-minDistanceFromSeg) numIntersections = contourIntersectionCount contour (pToEPoint2 perpPoint, outsidePoint) @@ -265,7 +265,7 @@ pointFarOutsideContour contour | not (noIntersection line3 firstLine) = outsidePoint3 | otherwise = error "cannot get here." where - minPoint = fst (minMaxPoints contour) + minPoint = fst $ minMaxPoints contour (p1, p2) = firstPointPairOfContour contour firstLine = join2EP p1 p2 line1 = join2EP p1 outsidePoint1 @@ -278,9 +278,9 @@ pointFarOutsideContour contour -- | Find a point that is guaranteed to be outside of the given contour, and is not on the same line as the first line segment of the contour. pointFarOutsideContours :: Contour -> Contour -> Point2 pointFarOutsideContours contour1 contour2 - | not (noIntersection line1 firstPLine) && not (noIntersection line1 secondPLine) = outsidePoint1 - | not (noIntersection line2 firstPLine) && not (noIntersection line2 secondPLine) = outsidePoint2 - | not (noIntersection line3 firstPLine) && not (noIntersection line3 secondPLine) = outsidePoint3 + | not (noIntersection line1 firstLine) && not (noIntersection line1 secondLine) = outsidePoint1 + | not (noIntersection line2 firstLine) && not (noIntersection line2 secondLine) = outsidePoint2 + | not (noIntersection line3 firstLine) && not (noIntersection line3 secondLine) = outsidePoint3 | otherwise = error "cannot get here...?" where minPoint1 = fst $ minMaxPoints contour1 @@ -288,8 +288,8 @@ pointFarOutsideContours contour1 contour2 minPoint = Point2 (min (xOf minPoint1) (xOf minPoint2),min (yOf minPoint1) (yOf minPoint2)) (p1, p2) = firstPointPairOfContour contour1 (p3, p4) = firstPointPairOfContour contour2 - firstPLine = join2EP p1 p2 - secondPLine = join2EP p3 p4 + firstLine = join2EP p1 p2 + secondLine = join2EP p3 p4 line1 = join2EP p1 outsidePoint1 line2 = join2EP p1 outsidePoint2 line3 = join2EP p1 outsidePoint3 diff --git a/Graphics/Slicer/Math/Ganja.hs b/Graphics/Slicer/Math/Ganja.hs index 19b7918b7..f5966ed1c 100644 --- a/Graphics/Slicer/Math/Ganja.hs +++ b/Graphics/Slicer/Math/Ganja.hs @@ -116,7 +116,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (GNum(GEPlus, GEZero), GVec(GVec), import Graphics.Slicer.Math.Lossy (eToPLine2, join2PPoint2, pPointBetweenPPoints, pToEPoint2) -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), PLine2(PLine2), PPoint2(PPoint2), PLine2Err, eToPL, eToPPoint2, flipL, normalizeL, translateRotatePPoint2WithErr, outOf, pPointOf, NPLine2(NPLine2)) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), PLine2(PLine2), PPoint2(PPoint2), PLine2Err, eToPL, eToPP, flipL, normalizeL, translateRotatePPoint2WithErr, outOf, pPointOf, NPLine2(NPLine2)) import Graphics.Slicer.Math.Skeleton.Concave (makeENode) @@ -632,12 +632,12 @@ randomStarPoly centerX centerY radianDistPairs = fromMaybe dumpError $ maybeFlip contour = makePointContour points points = pToEPoint2 <$> pointsAroundCenter pointsAroundCenter = (\(distanceFromPoint, angle) -> fst $ translateRotatePPoint2WithErr centerPPoint (coerce distanceFromPoint) (coerce angle)) <$> radianDistPairs - centerPPoint = eToPPoint2 $ Point2 (centerX, centerY) + centerPPoint = eToPP $ Point2 (centerX, centerY) dumpError = error $ "failed to flip a contour:" <> dumpGanjas [toGanja contour, toGanja (Point2 (centerX, centerY)), toGanja outsidePLine] <> "\n" where outsidePLine = join2PPoint2 myMidPoint outsidePoint - outsidePoint = (\(CPPoint2 a) -> PPoint2 a) $ eToPPoint2 $ pointFarOutsideContour contour - myMidPoint = pPointBetweenPPoints (eToPPoint2 p1) (eToPPoint2 p2) 0.5 0.5 + outsidePoint = (\(CPPoint2 a) -> PPoint2 a) $ eToPP $ pointFarOutsideContour contour + myMidPoint = pPointBetweenPPoints (eToPP p1) (eToPP p2) 0.5 0.5 (p1, p2) = firstPointPairOfContour contour randomENode :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> Positive ℝ -> Radian ℝ -> ENode @@ -650,7 +650,7 @@ randomENode x y d1 rawR1 d2 rawR2 = makeENode p1 intersectionPoint p2 pp2 = fst $ translateRotatePPoint2WithErr intersectionPPoint (coerce d2) (coerce r2) p1 = pToEPoint2 pp1 p2 = pToEPoint2 pp2 - intersectionPPoint = eToPPoint2 intersectionPoint + intersectionPPoint = eToPP intersectionPoint randomINode :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> Positive ℝ -> Radian ℝ -> Bool -> Bool -> INode randomINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 = makeINode [maybeFlippedpl1,maybeFlippedpl2] (Just $ (\(NPLine2 a,b) -> (PLine2 a,b <> outsideResErr)) bisector1) diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index c4662ea72..7001e812c 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -48,7 +48,7 @@ import Graphics.Slicer.Math.Definitions (LineSeg, Point2, makeLineSeg) import qualified Graphics.Slicer.Math.Arcs as Arcs (getFirstArc, getInsideArc) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PPoint2, ProjectiveLine2, ProjectivePoint2, angleBetween2PL, canonicalizeP, distance2PP, distance2PL, distancePPointToPLineWithErr, eToPL, eToPPoint2, interpolate2PP, join2PP, normalizeL, pPointOnPerpWithErr, pToEP, translateL) +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PPoint2, ProjectiveLine2, ProjectivePoint2, angleBetween2PL, canonicalizeP, distance2PP, distance2PL, distancePPointToPLineWithErr, eToPL, eToPP, interpolate2PP, join2PP, normalizeL, pPointOnPerpWithErr, pToEP, translateL) angleBetween :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> ℝ angleBetween pLine1 pLine2 = fst $ angleBetween2PL pLine1 pLine2 @@ -69,7 +69,7 @@ distancePPointToPLine point line = fst $ distancePPointToPLineWithErr (point, me -- | Create a projective point from a euclidian point. eToCPPoint2 :: Point2 -> CPPoint2 -eToCPPoint2 point = eToPPoint2 point +eToCPPoint2 point = eToPP point -- | Create a normalized projective line from a euclidian line segment. eToNPLine2 :: LineSeg -> NPLine2 diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 447133202..ef06e1e04 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -56,7 +56,6 @@ module Graphics.Slicer.Math.PGA( distance2PL, eToPL, eToPP, - eToPPoint2, flipL, interpolate2PP, intersectsWithErr, @@ -499,11 +498,11 @@ combineConsecutiveLineSegs lines = case lines of ------------------------------------------------ -- | Create a canonical projective point from the given euclidian point. -eToPPoint2, eToPP :: Point2 -> CPPoint2 -eToPPoint2 (Point2 (x,y)) = res +euclidianToProjectivePoint2, eToPP :: Point2 -> CPPoint2 +euclidianToProjectivePoint2 (Point2 (x,y)) = res where res = makePPoint2 x y -eToPP = eToPPoint2 +eToPP = euclidianToProjectivePoint2 -- | Create a canonical euclidian projective point from the given coordinates. makePPoint2 :: ℝ -> ℝ -> CPPoint2 diff --git a/Graphics/Slicer/Math/Skeleton/Cells.hs b/Graphics/Slicer/Math/Skeleton/Cells.hs index c27a59b06..6742ca800 100644 --- a/Graphics/Slicer/Math/Skeleton/Cells.hs +++ b/Graphics/Slicer/Math/Skeleton/Cells.hs @@ -58,7 +58,7 @@ import Graphics.Slicer.Math.Intersections (intersectionOf) import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, eToCPPoint2, eToPLine2, pToEPoint2) -import Graphics.Slicer.Math.PGA (Arcable(outOf), CPPoint2(CPPoint2), Pointable(canPoint, ePointOf, pPointOf), PIntersection(PAntiCollinear, IntersectsIn), PPoint2(PPoint2), angleBetween2PL, distance2PP, eToPL, eToPPoint2, outAndErrOf, plinesIntersectIn) +import Graphics.Slicer.Math.PGA (Arcable(outOf), CPPoint2(CPPoint2), Pointable(canPoint, ePointOf, pPointOf), PIntersection(PAntiCollinear, IntersectsIn), PPoint2(PPoint2), angleBetween2PL, distance2PP, eToPL, eToPP, outAndErrOf, plinesIntersectIn) import Graphics.Slicer.Math.PGAPrimitives (join2PP) @@ -417,7 +417,7 @@ crossoverINodes nodeTree@(NodeTree _ (INodeSet (Slist iNodes _))) cellDivision = where nodeCrosses :: INode -> Bool nodeCrosses a = Just False `elem` (intersectionSameSide pointOnSide a <$> motorcyclesInDivision cellDivision) - pointOnSide = (\(CPPoint2 a) -> PPoint2 a) $ eToPPoint2 $ pointInCell nodeTree cellDivision + pointOnSide = (\(CPPoint2 a) -> PPoint2 a) $ eToPP $ pointInCell nodeTree cellDivision pointInCell cell (CellDivide (DividingMotorcycles m _) _) | firstSegOf cell == lastCSegOf m = endPoint $ firstSegOf cell | lastSegOf cell == firstCSegOf m = startPoint $ lastSegOf cell diff --git a/Graphics/Slicer/Math/Skeleton/Definitions.hs b/Graphics/Slicer/Math/Skeleton/Definitions.hs index 4b0f7dde4..38c6cb002 100644 --- a/Graphics/Slicer/Math/Skeleton/Definitions.hs +++ b/Graphics/Slicer/Math/Skeleton/Definitions.hs @@ -55,7 +55,7 @@ import Graphics.Slicer.Math.Definitions (Contour, LineSeg(LineSeg), Point2, mapW import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum), addVecPair) -import Graphics.Slicer.Math.PGA (plinesIntersectIn, PIntersection(IntersectsIn), flipL, PLine2(PLine2), PLine2Err, pLineIsLeft, distance2PP, Pointable(canPoint, pPointOf, ePointOf), Arcable(errOfOut, hasArc, outOf), CPPoint2(CPPoint2), PPoint2(PPoint2), eToPL, eToPPoint2, outAndErrOf, pToEP, vecOfL) +import Graphics.Slicer.Math.PGA (plinesIntersectIn, PIntersection(IntersectsIn), flipL, PLine2(PLine2), PLine2Err, pLineIsLeft, distance2PP, Pointable(canPoint, pPointOf, ePointOf), Arcable(errOfOut, hasArc, outOf), CPPoint2(CPPoint2), PPoint2(PPoint2), eToPL, eToPP, outAndErrOf, pToEP, vecOfL) -- | A point where two lines segments that are part of a contour intersect, emmiting an arc toward the interior of a contour. -- FIXME: a source should have a different UlpSum for it's point and it's output. @@ -73,7 +73,7 @@ instance Arcable ENode where instance Pointable ENode where -- an ENode always contains a point. canPoint _ = True - pPointOf a = (\(CPPoint2 v) -> PPoint2 v) $ eToPPoint2 $ ePointOf a + pPointOf a = (\(CPPoint2 v) -> PPoint2 v) $ eToPP $ ePointOf a ePointOf (ENode (_,centerPoint,_) _ _) = centerPoint -- | A point in our straight skeleton where two arcs intersect, resulting in the creation of another arc. @@ -157,7 +157,7 @@ instance Arcable Motorcycle where instance Pointable Motorcycle where -- A motorcycle always contains a point. canPoint _ = True - pPointOf a = (\(CPPoint2 v) -> PPoint2 v) $ eToPPoint2 $ ePointOf a + pPointOf a = (\(CPPoint2 v) -> PPoint2 v) $ eToPP $ ePointOf a ePointOf (Motorcycle (_, LineSeg point _) _ _) = point -- | The motorcycles that are involved in dividing two cells. diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index 205700fc3..2921ea0a1 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -59,7 +59,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(GEZero, GEPlu import Graphics.Slicer.Math.Lossy (angleBetween, canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenPLines, distancePPointToPLine, eToCPPoint2, eToPLine2, getFirstArc, join2PPoint2, normalizePLine2, pPointOnPerp) -- Our 2D Projective Geometric Algebra library. -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PLine2Err(PLine2Err), canonicalizeP, distance2PP, distancePPointToPLineWithErr, eToPL, eToPP, eToPPoint2, interpolate2PP, intersect2PL, translateL, translateRotatePPoint2WithErr, angleBetween2PL, flipL, join2PP, makePPoint2, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, distancePPointToPLineWithErr, errOfOut, pPointOnPerpWithErr, outOf, pPointOf, outputIntersectsLineSeg) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PLine2Err(PLine2Err), canonicalizeP, distance2PP, distancePPointToPLineWithErr, eToPL, eToPP, eToPP, interpolate2PP, intersect2PL, translateL, translateRotatePPoint2WithErr, angleBetween2PL, flipL, join2PP, makePPoint2, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, distancePPointToPLineWithErr, errOfOut, pPointOnPerpWithErr, outOf, pPointOf, outputIntersectsLineSeg) -- The primitives of our PGA only library, and error estimation code. @@ -333,7 +333,7 @@ geomAlgSpec = do prop_ScalarDotScalar :: ℝ -> ℝ -> ℝ -> ℝ -> Bool prop_ScalarDotScalar v1 v2 v3 v4 = scalarPart (rawPPoint2 (v1,v2) ⋅ rawPPoint2 (v3,v4)) == (-1) where - rawPPoint2 (x,y) = (\(CPPoint2 v) -> v) $ eToPPoint2 (Point2 (x,y)) + rawPPoint2 (x,y) = (\(CPPoint2 v) -> v) $ eToPP (Point2 (x,y)) -- | A property test making sure that the wedge product of two PLines along two different axises is always in e1e2. prop_TwoAxisAlignedLines :: NonZero ℝ -> NonZero ℝ -> NonZero ℝ -> NonZero ℝ -> Expectation @@ -372,7 +372,7 @@ proj2DGeomAlgSpec = do it "A line constructed from a line segment is correct" $ eToPLine2 (LineSeg (Point2 (0,0)) (Point2 (1,1))) --> pl1 it "A line constructed from by joining two points is correct" $ - join2PPoint2 (eToPPoint2 (Point2 (0,0))) (eToPPoint2 (Point2 (1,1))) --> pl1 + join2PPoint2 (eToPP (Point2 (0,0))) (eToPP (Point2 (1,1))) --> pl1 where pl1 = PLine2 $ GVec [GVal 1 (singleton (GEPlus 1)), GVal (-1) (singleton (GEPlus 2))] @@ -424,18 +424,18 @@ prop_perpAt90Degrees x y rawX2 y2 rawD -- | A property test making sure the distance between a point an an axis is equal to the corresponding euclidian component of the point. prop_DistanceToAxis :: NonZero ℝ -> NonZero ℝ -> Bool -> Expectation prop_DistanceToAxis v v2 xAxis - | xAxis = distancePPointToPLine (eToPPoint2 $ Point2 (coerce v2,coerce v)) (eToPLine2 $ LineSeg (Point2 (0,0)) (Point2 (1,0))) --> abs (coerce v) - | otherwise = distancePPointToPLine (eToPPoint2 $ Point2 (coerce v,coerce v2)) (eToPLine2 $ LineSeg (Point2 (0,0)) (Point2 (0,1))) --> abs (coerce v) + | xAxis = distancePPointToPLine (eToPP $ Point2 (coerce v2,coerce v)) (eToPLine2 $ LineSeg (Point2 (0,0)) (Point2 (1,0))) --> abs (coerce v) + | otherwise = distancePPointToPLine (eToPP $ Point2 (coerce v,coerce v2)) (eToPLine2 $ LineSeg (Point2 (0,0)) (Point2 (0,1))) --> abs (coerce v) -- | A property test making sure two points on the same side of an axis show as being on the same side of the axis. prop_SameSideOfAxis :: NonZero ℝ -> NonZero ℝ -> Positive ℝ -> Positive ℝ -> Positive ℝ -> Bool -> Bool -> Expectation prop_SameSideOfAxis rawV1 rawV2 rawP1 rawP2 rawMagnitude xAxis positiveSide | xAxis = if positiveSide - then pPointsOnSameSideOfPLine (eToPPoint2 $ Point2 (v1,p1)) (eToPPoint2 $ Point2 (v2,p2)) (eToPLine2 $ LineSeg (Point2 (0,0)) (Point2 (mag,0))) --> Just True - else pPointsOnSameSideOfPLine (eToPPoint2 $ Point2 (v1,-p1)) (eToPPoint2 $ Point2 (v2,-p2)) (eToPLine2 $ LineSeg (Point2 (0,0)) (Point2 (mag,0))) --> Just True + then pPointsOnSameSideOfPLine (eToPP $ Point2 (v1,p1)) (eToPP $ Point2 (v2,p2)) (eToPLine2 $ LineSeg (Point2 (0,0)) (Point2 (mag,0))) --> Just True + else pPointsOnSameSideOfPLine (eToPP $ Point2 (v1,-p1)) (eToPP $ Point2 (v2,-p2)) (eToPLine2 $ LineSeg (Point2 (0,0)) (Point2 (mag,0))) --> Just True | otherwise = if positiveSide - then pPointsOnSameSideOfPLine (eToPPoint2 $ Point2 (p1,v1)) (eToPPoint2 $ Point2 (p2,v2)) (eToPLine2 $ LineSeg (Point2 (0,0)) (Point2 (0,1))) --> Just True - else pPointsOnSameSideOfPLine (eToPPoint2 $ Point2 (-p1,v1)) (eToPPoint2 $ Point2 (-p1,v2)) (eToPLine2 $ LineSeg (Point2 (0,0)) (Point2 (0,1))) --> Just True + then pPointsOnSameSideOfPLine (eToPP $ Point2 (p1,v1)) (eToPP $ Point2 (p2,v2)) (eToPLine2 $ LineSeg (Point2 (0,0)) (Point2 (0,1))) --> Just True + else pPointsOnSameSideOfPLine (eToPP $ Point2 (-p1,v1)) (eToPP $ Point2 (-p1,v2)) (eToPLine2 $ LineSeg (Point2 (0,0)) (Point2 (0,1))) --> Just True where p1 = coerce rawP1 p2 = coerce rawP2 @@ -448,11 +448,11 @@ prop_SameSideOfAxis rawV1 rawV2 rawP1 rawP2 rawMagnitude xAxis positiveSide prop_OtherSideOfAxis :: NonZero ℝ -> NonZero ℝ -> Positive ℝ -> Positive ℝ -> Bool -> Bool -> Expectation prop_OtherSideOfAxis v1 v2 p1 p2 xAxis positive | xAxis = if positive - then pPointsOnSameSideOfPLine (eToPPoint2 (Point2 (coerce v1,coerce p1))) (eToPPoint2 (Point2 (coerce v2,-(coerce p2)))) (eToPLine2 (LineSeg (Point2 (0,0)) (Point2 (1,0)))) --> Just False - else pPointsOnSameSideOfPLine (eToPPoint2 (Point2 (coerce v1,-(coerce p1)))) (eToPPoint2 (Point2 (coerce v2,coerce p2))) (eToPLine2 (LineSeg (Point2 (0,0)) (Point2 (1,0)))) --> Just False + then pPointsOnSameSideOfPLine (eToPP (Point2 (coerce v1,coerce p1))) (eToPP (Point2 (coerce v2,-(coerce p2)))) (eToPLine2 (LineSeg (Point2 (0,0)) (Point2 (1,0)))) --> Just False + else pPointsOnSameSideOfPLine (eToPP (Point2 (coerce v1,-(coerce p1)))) (eToPP (Point2 (coerce v2,coerce p2))) (eToPLine2 (LineSeg (Point2 (0,0)) (Point2 (1,0)))) --> Just False | otherwise = if positive - then pPointsOnSameSideOfPLine (eToPPoint2 (Point2 (coerce p1,coerce v1))) (eToPPoint2 (Point2 (-(coerce p2),coerce v2))) (eToPLine2 (LineSeg (Point2 (0,0)) (Point2 (0,1)))) --> Just False - else pPointsOnSameSideOfPLine (eToPPoint2 (Point2 (-(coerce p1),coerce v1))) (eToPPoint2 (Point2 (coerce p1,coerce v2))) (eToPLine2 (LineSeg (Point2 (0,0)) (Point2 (0,1)))) --> Just False + then pPointsOnSameSideOfPLine (eToPP (Point2 (coerce p1,coerce v1))) (eToPP (Point2 (-(coerce p2),coerce v2))) (eToPLine2 (LineSeg (Point2 (0,0)) (Point2 (0,1)))) --> Just False + else pPointsOnSameSideOfPLine (eToPP (Point2 (-(coerce p1),coerce v1))) (eToPP (Point2 (coerce p1,coerce v2))) (eToPLine2 (LineSeg (Point2 (0,0)) (Point2 (0,1)))) --> Just False -- | Ensure that a PLine translated, then translated back is approximately the same PLine. prop_PerpTranslateID :: ℝ -> ℝ -> NonZero ℝ -> NonZero ℝ -> NonZero ℝ -> Bool @@ -922,10 +922,10 @@ prop_TriangleNoDivides centerX centerY rawRadians rawDists = findDivisions trian pLine = eToPL firstSeg firstPoints = firstPointPairOfContour triangle (p1, p2) = firstPointPairOfContour triangle - (myMidPoint,_) = interpolate2PP (eToPPoint2 p1) (eToPPoint2 p2) 0.5 0.5 + (myMidPoint,_) = interpolate2PP (eToPP p1) (eToPP p2) 0.5 0.5 -- we normalize this for Ganja.js. (NPLine2 pLineToInside) = normalizePLine2 $ join2PPoint2 myMidPoint innerPoint - (NPLine2 pLineToOutside) = normalizePLine2 $ join2PPoint2 innerPoint $ (\(CPPoint2 a) -> PPoint2 a) $ eToPPoint2 outsidePoint + (NPLine2 pLineToOutside) = normalizePLine2 $ join2PPoint2 innerPoint $ (\(CPPoint2 a) -> PPoint2 a) $ eToPP outsidePoint innerPoint = fromMaybe (dumpError2) maybeInnerPoint minPoint = fst $ minMaxPoints triangle outsidePoint = Point2 (xOf minPoint - 0.00000001 , yOf minPoint - 0.00000001) @@ -1348,7 +1348,7 @@ prop_eNodeAwayFromIntersection2 x y d1 rawR1 d2 rawR2 = l2TowardIntersection --> prop_translateRotateMoves :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> Expectation prop_translateRotateMoves x y rawD rawR = distanceBetweenPPoints (fst $ translateRotatePPoint2WithErr pPoint d r) cPPoint /= 0 --> True where - pPoint = eToPPoint2 $ Point2 (x,y) + pPoint = eToPP $ Point2 (x,y) cPPoint = makePPoint2 x y r,d::ℝ r = coerce rawR @@ -1429,7 +1429,7 @@ prop_PLineIntersectsAtXAxis x y rawX2 y2 m errSum = ulpVal $ axisIntersectionErr <> distanceErr (foundDistance, (_,_,distanceErr)) = distance2PP (axisIntersectionPoint, mempty) (intersectionPPoint2, intersectionErr) axisIntersectionErr = snd $ fromJust axisIntersection - axisIntersectionPoint = eToPPoint2 $ Point2 ((fromRight (error "not right?") $ fst $ fromJust axisIntersection), 0) + axisIntersectionPoint = eToPP $ Point2 ((fromRight (error "not right?") $ fst $ fromJust axisIntersection), 0) axisIntersection = xIntercept (randomPLine1, pline1Err) (intersectionPPoint2, (_,_,intersectionErr)) = intersect2PL randomPLine1 axisPLine (randomPLine1, pline1Err) = randomPL x y rawX2 (coerce y2) @@ -1458,7 +1458,7 @@ prop_PLineIntersectsAtYAxis x y x2 rawY2 m errSum = ulpVal $ axisIntersectionErr <> distanceErr (foundDistance, (_,_,distanceErr)) = distance2PP (axisIntersectionPoint,mempty) (intersectionPPoint2, intersectionErr) axisIntersectionErr = snd $ fromJust axisIntersection - axisIntersectionPoint = eToPPoint2 $ Point2 (0,(fromRight (error "not right?") $ fst $ fromJust axisIntersection)) + axisIntersectionPoint = eToPP $ Point2 (0,(fromRight (error "not right?") $ fst $ fromJust axisIntersection)) axisIntersection = yIntercept (randomPLine1, pline1Err) (intersectionPPoint2, (_,_,intersectionErr)) = intersect2PL randomPLine1 axisPLine (randomPLine1, pline1Err) = randomPL (coerce x) y (coerce x2) (coerce y2) From c4723d903ffb0adcac5ada4c3bce9bf115c92ff9 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Fri, 2 Dec 2022 19:33:07 +0000 Subject: [PATCH 114/206] fix spacing and variable names. --- Graphics/Slicer/Math/Contour.hs | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/Graphics/Slicer/Math/Contour.hs b/Graphics/Slicer/Math/Contour.hs index 59dfdedd9..b3c350c8f 100644 --- a/Graphics/Slicer/Math/Contour.hs +++ b/Graphics/Slicer/Math/Contour.hs @@ -46,13 +46,13 @@ import Graphics.Implicit.Definitions (ℝ) import Graphics.Slicer.Math.Definitions (Contour(PointContour, LineSegContour), Point2(Point2), LineSeg, lineSegsOfContour, minMaxPoints, xOf, yOf, startPoint, endPoint, fudgeFactor, makeLineSeg) -import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum)) +import Graphics.Slicer.Math.GeometricAlgebra (ulpVal) import Graphics.Slicer.Math.Intersections (contourIntersectionCount, noIntersection) import Graphics.Slicer.Math.Lossy (pPointBetweenPPoints, pToEPoint2) -import Graphics.Slicer.Math.PGA (PPoint2, eToPP, eToPL, join2EP, join2PP, pLineIsLeft, pPointOnPerpWithErr) +import Graphics.Slicer.Math.PGA (PPoint2, eToPP, join2EP, join2PP, pLineIsLeft, pPointOnPerpWithErr) -- Unapologetically ripped from ImplicitCAD. -- Added the ability to look at line segments backwards. @@ -228,29 +228,29 @@ insideIsLeft contour | isJust (innerContourPoint contour) = Just $ pLineIsLeft line1 (lineToInside, lineToInsideErr) == Just True | otherwise = Nothing where - (lineToInside, (_,_, lineToInsideErr)) = join2PP myMidPoint innerPoint - myMidPoint = pPointBetweenPPoints (eToPP p1) (eToPP p2) 0.5 0.5 - line1 = eToPL $ makeLineSeg p1 p2 - innerPoint = fromJust $ innerContourPoint contour - (p1, p2) = firstPointPairOfContour contour + (lineToInside, (_,_, lineToInsideErr)) = join2PP midPoint innerPoint + midPoint = pPointBetweenPPoints (eToPP p1) (eToPP p2) 0.5 0.5 + line1 = join2EP p1 p2 + innerPoint = fromJust $ innerContourPoint contour + (p1, p2) = firstPointPairOfContour contour -- | Find a point on the interior of a given contour, on the perpendicular bisector of the first line segment, a given distance away from the line segment. innerContourPoint :: Contour -> Maybe PPoint2 innerContourPoint contour - | odd numIntersections && perpErr < realToFrac minDistanceFromSeg = Just perpPoint + | odd numIntersections && realToFrac (ulpVal perpErr) < minDistanceFromSeg = Just perpPoint | odd numIntersections = error "cannot ensure perp point is on right side of contour." - | odd otherIntersections && otherErr < realToFrac minDistanceFromSeg = Just otherPoint + | odd otherIntersections && realToFrac (ulpVal otherErr) < minDistanceFromSeg = Just otherPoint | odd otherIntersections = error "cannot ensure other point is on the right side of the contour." | otherwise = Nothing where - (p1, p2) = firstPointPairOfContour contour - source = fst $ join2EP p1 p2 - myMidPoint = pPointBetweenPPoints (eToPP p1) (eToPP p2) 0.5 0.5 - (perpPoint, (_,_,_, UlpSum perpErr)) = pPointOnPerpWithErr source myMidPoint minDistanceFromSeg - (otherPoint,(_,_,_, UlpSum otherErr)) = pPointOnPerpWithErr source myMidPoint (-minDistanceFromSeg) numIntersections = contourIntersectionCount contour (pToEPoint2 perpPoint, outsidePoint) otherIntersections = contourIntersectionCount contour (pToEPoint2 otherPoint, outsidePoint) - outsidePoint = pointFarOutsideContour contour + (perpPoint, (_,_,_, perpErr)) = pPointOnPerpWithErr source midPoint minDistanceFromSeg + (otherPoint, (_,_,_, otherErr)) = pPointOnPerpWithErr source midPoint (-minDistanceFromSeg) + midPoint = pPointBetweenPPoints (eToPP p1) (eToPP p2) 0.5 0.5 + source = fst $ join2EP p1 p2 + outsidePoint = pointFarOutsideContour contour + (p1, p2) = firstPointPairOfContour contour -- | the minimum measurable distance of a point from a line segment -- FIXME: make this smaller, make more errors. -- FIXME: magic number From fd2fdca83cd07d012ce1c5118dc4140cebeaaf9a Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Fri, 2 Dec 2022 20:36:54 +0000 Subject: [PATCH 115/206] move contourIntersectionCount into ContourIntersectionos.hs. --- Graphics/Slicer/Math/Contour.hs | 6 ++- Graphics/Slicer/Math/ContourIntersections.hs | 54 ++++++++++++++++++++ Graphics/Slicer/Math/Intersections.hs | 34 +++--------- hslice.cabal | 1 + 4 files changed, 67 insertions(+), 28 deletions(-) create mode 100644 Graphics/Slicer/Math/ContourIntersections.hs diff --git a/Graphics/Slicer/Math/Contour.hs b/Graphics/Slicer/Math/Contour.hs index b3c350c8f..7d51e7b41 100644 --- a/Graphics/Slicer/Math/Contour.hs +++ b/Graphics/Slicer/Math/Contour.hs @@ -44,11 +44,13 @@ import Slist.Size (Size(Infinity)) import Graphics.Implicit.Definitions (ℝ) -import Graphics.Slicer.Math.Definitions (Contour(PointContour, LineSegContour), Point2(Point2), LineSeg, lineSegsOfContour, minMaxPoints, xOf, yOf, startPoint, endPoint, fudgeFactor, makeLineSeg) +import Graphics.Slicer.Math.ContourIntersections (contourIntersectionCount) + +import Graphics.Slicer.Math.Definitions (Contour(PointContour, LineSegContour), Point2(Point2), LineSeg(endPoint, startPoint), fudgeFactor, lineSegsOfContour, makeLineSeg, minMaxPoints, xOf, yOf) import Graphics.Slicer.Math.GeometricAlgebra (ulpVal) -import Graphics.Slicer.Math.Intersections (contourIntersectionCount, noIntersection) +import Graphics.Slicer.Math.Intersections (noIntersection) import Graphics.Slicer.Math.Lossy (pPointBetweenPPoints, pToEPoint2) diff --git a/Graphics/Slicer/Math/ContourIntersections.hs b/Graphics/Slicer/Math/ContourIntersections.hs new file mode 100644 index 000000000..e3dbdc5db --- /dev/null +++ b/Graphics/Slicer/Math/ContourIntersections.hs @@ -0,0 +1,54 @@ +{- ORMOLU_DISABLE -} +{- + - Copyright 2022 Julia Longtin + - + - This program is free software: you can redistribute it and/or modify + - it under the terms of the GNU Affero General Public License as published by + - the Free Software Foundation, either version 3 of the License, or + - (at your option) any later version. + - + - This program is distributed in the hope that it will be useful, + - but WITHOUT ANY WARRANTY; without even the implied warranty of + - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + - GNU Affero General Public License for more details. + + - You should have received a copy of the GNU Affero General Public License + - along with this program. If not, see . + -} + +{- Purpose of this file: to hold the logic and routines responsible for checking for intersections with contours, or portions of contours. -} + +module Graphics.Slicer.Math.ContourIntersections ( + contourIntersectionCount + ) where + +import Prelude (Either(Left), Int, (<$>), ($), zip) + +import Data.Maybe (Maybe(Just), catMaybes) + +import Slist.Type (Slist) + +import Slist (len, slist) + +import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, lineSegsOfContour, makeLineSeg, mapWithNeighbors) + +import Graphics.Slicer.Math.Intersections (filterIntersections) + +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2Err, intersectsWithErr) + +-- | return the number of intersections with a given contour when traveling in a straight line from the beginning of the given line segment to the end of the line segment. +-- Not for use when line segments can overlap or are collinear with one of the line segments that are a part of the contour. +contourIntersectionCount :: Contour -> (Point2, Point2) -> Int +contourIntersectionCount contour (start, end) = len $ getIntersections contour (start, end) + where + getIntersections :: Contour -> (Point2, Point2) -> Slist (LineSeg, Either Point2 CPPoint2) + getIntersections c (pt1, pt2) = slist $ catMaybes $ mapWithNeighbors filterIntersections $ openCircuit $ zip (lineSegsOfContour contour) $ intersectsWithErr targetSeg <$> segs + where + segs :: [Either LineSeg (NPLine2, PLine2Err)] + segs = Left <$> lineSegsOfContour c + targetSeg :: Either LineSeg (NPLine2, PLine2Err) + targetSeg = Left $ makeLineSeg pt1 pt2 + openCircuit v = Just <$> v + + + diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index 60352941b..a2fbbbcc7 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -18,23 +18,19 @@ {- Purpose of this file: to hold the logic and routines responsible for checking for intersections with contours, or portions of contours. -} -module Graphics.Slicer.Math.Intersections (getMotorcycleSegSetIntersections, getMotorcycleContourIntersections, contourIntersectionCount, getPLine2Intersections, intersectionOf, intersectionBetween, noIntersection, isCollinear, isAntiCollinear, isParallel, isAntiParallel) where +module Graphics.Slicer.Math.Intersections (filterIntersections, getMotorcycleSegSetIntersections, getMotorcycleContourIntersections, getPLine2Intersections, intersectionOf, intersectionBetween, noIntersection, isCollinear, isAntiCollinear, isParallel, isAntiParallel) where -import Prelude (Bool, Either(Left,Right), error, otherwise, show, (&&), (<>), ($), (<$>), (/=), zip, Int, (<), (*), (||), (==), fst, length, mempty, odd, realToFrac) +import Prelude (Bool, Either(Left,Right), error, otherwise, show, (&&), (<>), ($), (<$>), (/=), zip, (<), (*), (||), (==), fst, length, mempty, odd, realToFrac) -import Data.Maybe( Maybe(Just,Nothing), catMaybes, isJust, fromJust) +import Data.Maybe (Maybe(Just,Nothing), catMaybes, isJust, fromJust) import Data.List as L (filter) -import Slist.Type (Slist) - -import Slist (len, slist) - import Graphics.Slicer.Definitions (ℝ) -import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, mapWithNeighbors, startPoint, distance, lineSegsOfContour, endPoint, fudgeFactor, makeLineSeg) +import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, mapWithNeighbors, startPoint, distance, lineSegsOfContour, endPoint, fudgeFactor) -import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum)) +import Graphics.Slicer.Math.GeometricAlgebra (ulpVal) import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), Intersection(HitEndPoint, HitStartPoint, NoIntersection), PLine2, PLine2Err, PPoint2Err, ProjectiveLine2, distance2PL, intersectsWithErr, outputIntersectsLineSeg, plinesIntersectIn, pToEP) @@ -79,20 +75,6 @@ getMotorcycleContourIntersections m@(Motorcycle (inSeg, outSeg) _ _) c = stripIn -- filter out inSeg and outSeg outSeg fun (seg,_) = seg /= inSeg && seg /= outSeg --- | return the number of intersections with a given contour when traveling in a straight line from the beginning of the given line segment to the end of the line segment. --- Not for use when line segments can overlap or are collinear with one of the line segments that are a part of the contour. -contourIntersectionCount :: Contour -> (Point2, Point2) -> Int -contourIntersectionCount contour (start, end) = len $ getIntersections contour (start, end) - where - getIntersections :: Contour -> (Point2, Point2) -> Slist (LineSeg, Either Point2 CPPoint2) - getIntersections c (pt1, pt2) = slist $ catMaybes $ mapWithNeighbors filterIntersections $ openCircuit $ zip (lineSegsOfContour contour) $ intersectsWithErr targetSeg <$> segs - where - segs :: [Either LineSeg (NPLine2, PLine2Err)] - segs = Left <$> lineSegsOfContour c - targetSeg :: Either LineSeg (NPLine2, PLine2Err) - targetSeg = Left $ makeLineSeg pt1 pt2 - openCircuit v = Just <$> v - -- | Get the intersections between a PLine2 and a contour as a series of points. always returns an even number of intersections. -- FIXME: accept error on this first pLine! getPLine2Intersections :: PLine2 -> Contour -> [Point2] @@ -194,13 +176,13 @@ intersectionOf pl1 pl2 = saneIntersection $ plinesIntersectIn pl1 pl2 intersectionBetween :: PLine2 -> PLine2 -> Maybe (Either PLine2 (CPPoint2, PPoint2Err)) intersectionBetween pl1 pl2 = saneIntersection $ plinesIntersectIn (pl1,mempty) (pl2,mempty) where - (foundDistance, (_,_,UlpSum foundErr)) = distance2PL pl1 pl2 + (foundDistance, (_,_, foundErr)) = distance2PL pl1 pl2 saneIntersection PAntiCollinear = Just $ Left pl1 saneIntersection PCollinear = Just $ Left pl1 - saneIntersection PParallel = if foundDistance < realToFrac foundErr + saneIntersection PParallel = if foundDistance < realToFrac (ulpVal foundErr) then Just $ Left pl1 else Nothing - saneIntersection PAntiParallel = if foundDistance < realToFrac foundErr + saneIntersection PAntiParallel = if foundDistance < realToFrac (ulpVal foundErr) then Just $ Left pl1 else Nothing saneIntersection (IntersectsIn p (_,_, pErr)) = Just $ Right (p,pErr) diff --git a/hslice.cabal b/hslice.cabal index cde9bacc6..a932b7f2d 100644 --- a/hslice.cabal +++ b/hslice.cabal @@ -29,6 +29,7 @@ library Graphics.Slicer.Math.Arcs Graphics.Slicer.Math.CheckFacets Graphics.Slicer.Math.Contour + Graphics.Slicer.Math.ContourIntersections Graphics.Slicer.Math.Definitions Graphics.Slicer.Math.Facet Graphics.Slicer.Math.Ganja From f6fcb3ebbfa4dc49329316e01c91c3f20a6e38b7 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Fri, 2 Dec 2022 21:57:46 +0000 Subject: [PATCH 116/206] move getPLine2Intersections into ContourIntersections.hs, and change its name to getLineContourIntersections. --- Graphics/Slicer/Machine/Infill.hs | 4 +-- Graphics/Slicer/Math/ContourIntersections.hs | 27 +++++++++++++++++--- Graphics/Slicer/Math/Intersections.hs | 26 +++---------------- 3 files changed, 28 insertions(+), 29 deletions(-) diff --git a/Graphics/Slicer/Machine/Infill.hs b/Graphics/Slicer/Machine/Infill.hs index 6c4682810..8e7217e1f 100644 --- a/Graphics/Slicer/Machine/Infill.hs +++ b/Graphics/Slicer/Machine/Infill.hs @@ -35,7 +35,7 @@ import Graphics.Slicer.Definitions (ℝ) import Graphics.Slicer.Math.Definitions (Point2(Point2), Contour, LineSeg, addPoints, distance, makeLineSeg, minMaxPoints, xOf, yOf, roundToFifth) -import Graphics.Slicer.Math.Intersections (getPLine2Intersections) +import Graphics.Slicer.Math.ContourIntersections (getLineContourIntersections) import Graphics.Slicer.Math.Line (makeLineSegs) @@ -66,7 +66,7 @@ infillLineSegInside contour childContours line allLines :: [LineSeg] allLines = makeLineSegs allPoints where - allPoints = (filterTooShort . sort) $ concatMap (getPLine2Intersections line) (contour:childContours) + allPoints = (filterTooShort . sort) $ concatMap (getLineContourIntersections line) (contour:childContours) filterTooShort :: [Point2] -> [Point2] filterTooShort [] = [] filterTooShort [a] = [a] diff --git a/Graphics/Slicer/Math/ContourIntersections.hs b/Graphics/Slicer/Math/ContourIntersections.hs index e3dbdc5db..42c53d868 100644 --- a/Graphics/Slicer/Math/ContourIntersections.hs +++ b/Graphics/Slicer/Math/ContourIntersections.hs @@ -19,10 +19,11 @@ {- Purpose of this file: to hold the logic and routines responsible for checking for intersections with contours, or portions of contours. -} module Graphics.Slicer.Math.ContourIntersections ( - contourIntersectionCount + contourIntersectionCount, + getLineContourIntersections ) where -import Prelude (Either(Left), Int, (<$>), ($), zip) +import Prelude (Either(Left, Right), Int, Show(show), (<$>), (<>), ($), error, fst, length, mempty, odd, otherwise, zip) import Data.Maybe (Maybe(Just), catMaybes) @@ -34,7 +35,7 @@ import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, lineSegsOfCon import Graphics.Slicer.Math.Intersections (filterIntersections) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2Err, intersectsWithErr) +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PLine2Err, intersectsWithErr, pToEP) -- | return the number of intersections with a given contour when traveling in a straight line from the beginning of the given line segment to the end of the line segment. -- Not for use when line segments can overlap or are collinear with one of the line segments that are a part of the contour. @@ -50,5 +51,23 @@ contourIntersectionCount contour (start, end) = len $ getIntersections contour ( targetSeg = Left $ makeLineSeg pt1 pt2 openCircuit v = Just <$> v +-- | Get the intersections between a PLine2 and a contour as a series of points. always returns an even number of intersections. +-- FIXME: accept error on this first pLine! +getLineContourIntersections :: PLine2 -> Contour -> [Point2] +getLineContourIntersections pLine c + | odd $ length res = error $ "odd number of transitions: " <> show (length res) <> "\n" <> show c <> "\n" <> show pLine <> "\n" <> show res <> "\n" + | otherwise = res + where + res = getPoints $ catMaybes $ mapWithNeighbors filterIntersections $ openCircuit $ zip (lineSegsOfContour c) $ intersectsWithErr targetLine <$> segs + where + segs :: [Either LineSeg (NPLine2, PLine2Err)] + segs = Left <$> lineSegsOfContour c + targetLine :: Either LineSeg (PLine2, PLine2Err) + targetLine = Right (pLine, mempty) + openCircuit v = Just <$> v + getPoints :: [(LineSeg, Either Point2 CPPoint2)] -> [Point2] + getPoints vs = getPoint <$> vs + where + getPoint (_, Left v) = v + getPoint (_, Right v) = fst $ pToEP v - diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index a2fbbbcc7..551cc5834 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -18,9 +18,9 @@ {- Purpose of this file: to hold the logic and routines responsible for checking for intersections with contours, or portions of contours. -} -module Graphics.Slicer.Math.Intersections (filterIntersections, getMotorcycleSegSetIntersections, getMotorcycleContourIntersections, getPLine2Intersections, intersectionOf, intersectionBetween, noIntersection, isCollinear, isAntiCollinear, isParallel, isAntiParallel) where +module Graphics.Slicer.Math.Intersections (filterIntersections, getMotorcycleSegSetIntersections, getMotorcycleContourIntersections, intersectionOf, intersectionBetween, noIntersection, isCollinear, isAntiCollinear, isParallel, isAntiParallel) where -import Prelude (Bool, Either(Left,Right), error, otherwise, show, (&&), (<>), ($), (<$>), (/=), zip, (<), (*), (||), (==), fst, length, mempty, odd, realToFrac) +import Prelude (Bool, Either(Left,Right), error, otherwise, show, (&&), (<>), ($), (<$>), (/=), zip, (<), (*), (||), (==), mempty, realToFrac) import Data.Maybe (Maybe(Just,Nothing), catMaybes, isJust, fromJust) @@ -32,7 +32,7 @@ import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, mapWithNeighb import Graphics.Slicer.Math.GeometricAlgebra (ulpVal) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), Intersection(HitEndPoint, HitStartPoint, NoIntersection), PLine2, PLine2Err, PPoint2Err, ProjectiveLine2, distance2PL, intersectsWithErr, outputIntersectsLineSeg, plinesIntersectIn, pToEP) +import Graphics.Slicer.Math.PGA (CPPoint2, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), Intersection(HitEndPoint, HitStartPoint, NoIntersection), PLine2, PLine2Err, PPoint2Err, ProjectiveLine2, distance2PL, outputIntersectsLineSeg, plinesIntersectIn) import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle)) @@ -75,26 +75,6 @@ getMotorcycleContourIntersections m@(Motorcycle (inSeg, outSeg) _ _) c = stripIn -- filter out inSeg and outSeg outSeg fun (seg,_) = seg /= inSeg && seg /= outSeg --- | Get the intersections between a PLine2 and a contour as a series of points. always returns an even number of intersections. --- FIXME: accept error on this first pLine! -getPLine2Intersections :: PLine2 -> Contour -> [Point2] -getPLine2Intersections pLine c - | odd $ length res = error $ "odd number of transitions: " <> show (length res) <> "\n" <> show c <> "\n" <> show pLine <> "\n" <> show res <> "\n" - | otherwise = res - where - res = getPoints $ catMaybes $ mapWithNeighbors filterIntersections $ openCircuit $ zip (lineSegsOfContour c) $ intersectsWithErr targetLine <$> segs - where - segs :: [Either LineSeg (NPLine2, PLine2Err)] - segs = Left <$> lineSegsOfContour c - targetLine :: Either LineSeg (PLine2, PLine2Err) - targetLine = Right (pLine, mempty) - openCircuit v = Just <$> v - getPoints :: [(LineSeg, Either Point2 CPPoint2)] -> [Point2] - getPoints vs = getPoint <$> vs - where - getPoint (_, Left v) = v - getPoint (_, Right v) = fst $ pToEP v - -- | filter the intersections given. -- The purpose of this function is to ensure we only count the crossing of a line (segment) across a contour's edge more than once. so if it hits a sttartpoint, make sure we don't count the endpoint.. etc. -- FIXME: does not take into account (anti)collinear line segments correctly. From b273d825389f40f5ffc536072f6c225a36a63165 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 3 Dec 2022 00:14:27 +0000 Subject: [PATCH 117/206] make getLineContourIntersections use the ProjectiveLine2 Typeclass and accept error quotents. --- Graphics/Slicer/Machine/Infill.hs | 32 +++++++++----------- Graphics/Slicer/Math/ContourIntersections.hs | 17 ++++++----- 2 files changed, 24 insertions(+), 25 deletions(-) diff --git a/Graphics/Slicer/Machine/Infill.hs b/Graphics/Slicer/Machine/Infill.hs index 8e7217e1f..66fcc87ac 100644 --- a/Graphics/Slicer/Machine/Infill.hs +++ b/Graphics/Slicer/Machine/Infill.hs @@ -33,15 +33,13 @@ import Data.Maybe (Maybe(Just, Nothing), mapMaybe) import Graphics.Slicer.Definitions (ℝ) -import Graphics.Slicer.Math.Definitions (Point2(Point2), Contour, LineSeg, addPoints, distance, makeLineSeg, minMaxPoints, xOf, yOf, roundToFifth) +import Graphics.Slicer.Math.Definitions (Point2(Point2), Contour, LineSeg, addPoints, distance, minMaxPoints, xOf, yOf, roundToFifth) import Graphics.Slicer.Math.ContourIntersections (getLineContourIntersections) import Graphics.Slicer.Math.Line (makeLineSegs) -import Graphics.Slicer.Math.Lossy (eToPLine2) - -import Graphics.Slicer.Math.PGA (PLine2) +import Graphics.Slicer.Math.PGA (PLine2, PLine2Err, join2EP) -- | what direction to put down infill lines. data InfillType = Diag1 | Diag2 | Vert | Horiz @@ -58,7 +56,7 @@ makeInfill contour insideContours ls layerType = mapMaybe (infillLineSegInside c infillCover Diag2 = coveringPLinesNegative contour ls -- Get the segments of an infill line that are inside of a contour, skipping space occluded by any of the child contours. -infillLineSegInside :: Contour -> [Contour] -> PLine2 -> Maybe [LineSeg] +infillLineSegInside :: Contour -> [Contour] -> (PLine2, PLine2Err) -> Maybe [LineSeg] infillLineSegInside contour childContours line | not (null allLines) = Just $ (allLines !!) <$> [0,2..length allLines - 1] | otherwise = Nothing @@ -73,10 +71,10 @@ infillLineSegInside contour childContours line filterTooShort (a:b:xs) = if roundToFifth (distance a b) == 0 then filterTooShort xs else a:filterTooShort (b:xs) -- Generate lines covering the entire contour, where each one is aligned with a +1 slope, which is to say, lines parallel to a line where x = y. -coveringPLinesPositive :: Contour -> ℝ -> [PLine2] -coveringPLinesPositive contour ls = eToPLine2 . makeSeg <$> [0,lss..(xMax-xMinRaw)+(yMax-yMin)+lss] +coveringPLinesPositive :: Contour -> ℝ -> [(PLine2, PLine2Err)] +coveringPLinesPositive contour ls = makeLine <$> [0,lss..(xMax-xMinRaw)+(yMax-yMin)+lss] where - makeSeg a = makeLineSeg (f a) $ addPoints (f a) slope + makeLine a = join2EP (f a) $ addPoints (f a) slope (minPoint, maxPoint) = minMaxPoints contour slope = Point2 (1,1) f v = Point2 (v-xDiff,0) @@ -93,10 +91,10 @@ coveringPLinesPositive contour ls = eToPLine2 . makeSeg <$> [0,lss..(xMax-xMinRa lss = sqrt $ ls*ls+ls*ls -- Generate lines covering the entire contour, where each one is aligned with a -1 slope, which is to say, lines parallel to a line where x = -y. -coveringPLinesNegative :: Contour -> ℝ -> [PLine2] -coveringPLinesNegative contour ls = eToPLine2 . makeSeg <$> [0,lss..(xMax-xMin)+(yMax-yMin)+lss] +coveringPLinesNegative :: Contour -> ℝ -> [(PLine2, PLine2Err)] +coveringPLinesNegative contour ls = makeLine <$> [0,lss..(xMax-xMin)+(yMax-yMin)+lss] where - makeSeg a = makeLineSeg (f a) $ addPoints (f a) slope + makeLine a = join2EP (f a) $ addPoints (f a) slope (minPoint, maxPoint) = minMaxPoints contour slope = Point2 (1,-1) f v = Point2 (v+yDiff,0) @@ -113,10 +111,10 @@ coveringPLinesNegative contour ls = eToPLine2 . makeSeg <$> [0,lss..(xMax-xMin)+ lss = sqrt $ ls*ls+ls*ls -- Generate lines covering the entire contour, where each line is aligned with the Y axis, which is to say, parallel to the Y basis vector. -coveringPLinesVertical :: Contour -> ℝ -> [PLine2] -coveringPLinesVertical contour ls = eToPLine2 . makeSeg <$> [xMin,xMin+ls..xMax] +coveringPLinesVertical :: Contour -> ℝ -> [(PLine2, PLine2Err)] +coveringPLinesVertical contour ls = makeLine <$> [xMin,xMin+ls..xMax] where - makeSeg a = makeLineSeg (f a) $ addPoints (f a) slope + makeLine a = join2EP (f a) $ addPoints (f a) slope (minPoint, maxPoint) = minMaxPoints contour slope = Point2 (0,1) f v = Point2 (v,0) @@ -128,10 +126,10 @@ coveringPLinesVertical contour ls = eToPLine2 . makeSeg <$> [xMin,xMin+ls..xMax] xMax = xOf maxPoint -- Generate lines covering the entire contour, where each line is aligned with the X axis, which is to say, parallel to the X basis vector. -coveringPLinesHorizontal :: Contour -> ℝ -> [PLine2] -coveringPLinesHorizontal contour ls = eToPLine2 . makeSeg <$> [yMin,yMin+ls..yMax] +coveringPLinesHorizontal :: Contour -> ℝ -> [(PLine2, PLine2Err)] +coveringPLinesHorizontal contour ls = makeLine <$> [yMin,yMin+ls..yMax] where - makeSeg a = makeLineSeg (f a) $ addPoints (f a) slope + makeLine a = join2EP (f a) $ addPoints (f a) slope (minPoint, maxPoint) = minMaxPoints contour slope = Point2 (1,0) f v = Point2 (0,v) diff --git a/Graphics/Slicer/Math/ContourIntersections.hs b/Graphics/Slicer/Math/ContourIntersections.hs index 42c53d868..b5fbedff1 100644 --- a/Graphics/Slicer/Math/ContourIntersections.hs +++ b/Graphics/Slicer/Math/ContourIntersections.hs @@ -23,7 +23,7 @@ module Graphics.Slicer.Math.ContourIntersections ( getLineContourIntersections ) where -import Prelude (Either(Left, Right), Int, Show(show), (<$>), (<>), ($), error, fst, length, mempty, odd, otherwise, zip) +import Prelude (Either(Left, Right), Int, Show(show), (<$>), (<>), ($), error, fst, length, odd, otherwise, zip) import Data.Maybe (Maybe(Just), catMaybes) @@ -35,7 +35,7 @@ import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, lineSegsOfCon import Graphics.Slicer.Math.Intersections (filterIntersections) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PLine2Err, intersectsWithErr, pToEP) +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2Err, ProjectiveLine2, intersectsWithErr, normalizeL, pToEP) -- | return the number of intersections with a given contour when traveling in a straight line from the beginning of the given line segment to the end of the line segment. -- Not for use when line segments can overlap or are collinear with one of the line segments that are a part of the contour. @@ -51,19 +51,20 @@ contourIntersectionCount contour (start, end) = len $ getIntersections contour ( targetSeg = Left $ makeLineSeg pt1 pt2 openCircuit v = Just <$> v --- | Get the intersections between a PLine2 and a contour as a series of points. always returns an even number of intersections. +-- | Get the intersections between a Line and a contour as a series of points. always returns an even number of intersections. -- FIXME: accept error on this first pLine! -getLineContourIntersections :: PLine2 -> Contour -> [Point2] -getLineContourIntersections pLine c - | odd $ length res = error $ "odd number of transitions: " <> show (length res) <> "\n" <> show c <> "\n" <> show pLine <> "\n" <> show res <> "\n" +getLineContourIntersections :: (ProjectiveLine2 a) => (a, PLine2Err) -> Contour -> [Point2] +getLineContourIntersections (line, lineErr) c + | odd $ length res = error $ "odd number of transitions: " <> show (length res) <> "\n" <> show c <> "\n" <> show line <> "\n" <> show res <> "\n" | otherwise = res where res = getPoints $ catMaybes $ mapWithNeighbors filterIntersections $ openCircuit $ zip (lineSegsOfContour c) $ intersectsWithErr targetLine <$> segs where segs :: [Either LineSeg (NPLine2, PLine2Err)] segs = Left <$> lineSegsOfContour c - targetLine :: Either LineSeg (PLine2, PLine2Err) - targetLine = Right (pLine, mempty) + targetLine :: Either LineSeg (NPLine2, PLine2Err) + targetLine = Right (nLine, lineErr <> nLineErr) + (nLine, nLineErr) = normalizeL line openCircuit v = Just <$> v getPoints :: [(LineSeg, Either Point2 CPPoint2)] -> [Point2] getPoints vs = getPoint <$> vs From 5da3264e3273c00f10ccf2b1baee4d5a6aa04c2a Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 3 Dec 2022 13:02:18 +0000 Subject: [PATCH 118/206] one more use of the ProjectiveLine2 typeclass. --- Graphics/Slicer/Machine/Contour.hs | 2 +- Graphics/Slicer/Machine/Infill.hs | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/Graphics/Slicer/Machine/Contour.hs b/Graphics/Slicer/Machine/Contour.hs index 0adffc56e..f50a628f2 100644 --- a/Graphics/Slicer/Machine/Contour.hs +++ b/Graphics/Slicer/Machine/Contour.hs @@ -39,7 +39,7 @@ import Graphics.Slicer.Math.Lossy (eToPLine2, pToEPoint2) import Graphics.Slicer.Math.PGA (combineConsecutiveLineSegs, eToPL, translateL) -import Graphics.Slicer.Definitions(ℝ) +import Graphics.Slicer.Definitions (ℝ) --------------------------------------------------------------- -------------------- Contour Optimizer ------------------------ diff --git a/Graphics/Slicer/Machine/Infill.hs b/Graphics/Slicer/Machine/Infill.hs index 66fcc87ac..d7a3c093d 100644 --- a/Graphics/Slicer/Machine/Infill.hs +++ b/Graphics/Slicer/Machine/Infill.hs @@ -39,7 +39,7 @@ import Graphics.Slicer.Math.ContourIntersections (getLineContourIntersections) import Graphics.Slicer.Math.Line (makeLineSegs) -import Graphics.Slicer.Math.PGA (PLine2, PLine2Err, join2EP) +import Graphics.Slicer.Math.PGA (PLine2, PLine2Err, ProjectiveLine2, join2EP) -- | what direction to put down infill lines. data InfillType = Diag1 | Diag2 | Vert | Horiz @@ -56,7 +56,7 @@ makeInfill contour insideContours ls layerType = mapMaybe (infillLineSegInside c infillCover Diag2 = coveringPLinesNegative contour ls -- Get the segments of an infill line that are inside of a contour, skipping space occluded by any of the child contours. -infillLineSegInside :: Contour -> [Contour] -> (PLine2, PLine2Err) -> Maybe [LineSeg] +infillLineSegInside :: (ProjectiveLine2 a) => Contour -> [Contour] -> (a, PLine2Err) -> Maybe [LineSeg] infillLineSegInside contour childContours line | not (null allLines) = Just $ (allLines !!) <$> [0,2..length allLines - 1] | otherwise = Nothing From 96e8f848be0096c4230d2d4dc0f704dfd638ec50 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 3 Dec 2022 16:35:53 +0000 Subject: [PATCH 119/206] split Ganja.hs random geometry components into RandomGeometry.hs --- Graphics/Slicer/Math/Ganja.hs | 447 +--------------------- Graphics/Slicer/Math/PGAPrimitives.hs | 6 +- Graphics/Slicer/Math/RandomGeometry.hs | 508 +++++++++++++++++++++++++ hslice.cabal | 1 + tests/GoldenSpec/Spec.hs | 4 +- tests/Math/PGA.hs | 5 +- 6 files changed, 531 insertions(+), 440 deletions(-) create mode 100644 Graphics/Slicer/Math/RandomGeometry.hs diff --git a/Graphics/Slicer/Math/Ganja.hs b/Graphics/Slicer/Math/Ganja.hs index f5966ed1c..ba3bcd70e 100644 --- a/Graphics/Slicer/Math/Ganja.hs +++ b/Graphics/Slicer/Math/Ganja.hs @@ -81,46 +81,32 @@ -- so we can define a Num instance for Positive. {-# OPTIONS_GHC -Wno-orphans #-} -module Graphics.Slicer.Math.Ganja (GanjaAble, ListThree, Radian(Radian), edgesOf, generationsOf, toGanja, dumpGanja, dumpGanjas, randomPL, randomTriangle, randomSquare, randomRectangle, randomConvexDualRightQuad, randomConvexSingleRightQuad, randomConvexBisectableQuad, randomConvexQuad, randomConcaveChevronQuad, randomENode, randomINode, randomPLine, randomPLineWithErr, randomLineSeg, cellFrom, remainderFrom, onlyOne, onlyOneOf, randomPLineThroughOrigin, randomLineSegFromOriginNotX1Y1, randomX1Y1LineSegToOrigin, randomX1Y1LineSegToPoint, randomLineSegFromPointNotX1Y1, randomPLineThroughPoint) where +module Graphics.Slicer.Math.Ganja ( + GanjaAble, + toGanja, + dumpGanja, + dumpGanjas + ) where -import Prelude (Bool, Enum, Eq, Fractional, Num, Ord, Show, String, Int, (<>), (<>), (<$>), ($), (>=), (==), abs, concat, error, fromInteger, fromRational, fst, mempty, mod, otherwise, replicate, show, signum, snd, zip, (.), (+), (-), (*), (<), (/), (>), (<=), (&&), (/=)) +import Prelude (String, (<>), (<>), (<$>), ($), (>=), (==), (.), (/=), concat, error, fst, otherwise, show, snd, zip) -import Data.Coerce (coerce) +import Data.Maybe (Maybe(Nothing), catMaybes, maybeToList) -import Data.List (sort) - -import Data.List.Unique (allUnique) - -import Data.Maybe (Maybe(Nothing, Just), catMaybes, fromMaybe, maybeToList) - -import Math.Tau (tau) - -import Numeric(showFFloat, pi) +import Numeric(showFFloat) import Slist.Type (Slist(Slist)) import Slist (last, len) -import Test.QuickCheck (Arbitrary, Positive(Positive), NonZero(NonZero), arbitrary, shrink, suchThat, vector) - --- The numeric type in HSlice. -import Graphics.Slicer (ℝ) +import Graphics.Slicer.Math.Contour (pointsOfContour) -import Graphics.Slicer.Math.Arcs (getOutsideArc) - -import Graphics.Slicer.Math.Contour (makePointContour, maybeFlipContour, pointsOfContour, firstPointPairOfContour, pointFarOutsideContour) - -import Graphics.Slicer.Math.Definitions (Contour, Point2(Point2), LineSeg, endPoint, mapWithFollower, startPoint, makeLineSeg) +import Graphics.Slicer.Math.Definitions (Contour, Point2(Point2), LineSeg, endPoint, mapWithFollower, startPoint) import Graphics.Slicer.Math.GeometricAlgebra (GNum(GEPlus, GEZero), GVec(GVec), getVal, valOf) -import Graphics.Slicer.Math.Lossy (eToPLine2, join2PPoint2, pPointBetweenPPoints, pToEPoint2) - -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), PLine2(PLine2), PPoint2(PPoint2), PLine2Err, eToPL, eToPP, flipL, normalizeL, translateRotatePPoint2WithErr, outOf, pPointOf, NPLine2(NPLine2)) - -import Graphics.Slicer.Math.Skeleton.Concave (makeENode) +import Graphics.Slicer.Math.PGA (PLine2(PLine2), PPoint2(PPoint2), outOf) -import Graphics.Slicer.Math.Skeleton.Definitions(Cell(Cell), ENode, ENodeSet(ENodeSet), INode(INode), INodeSet(INodeSet), Motorcycle(Motorcycle), NodeTree(NodeTree), StraightSkeleton(StraightSkeleton), RemainingContour(RemainingContour), CellDivide(CellDivide), DividingMotorcycles(DividingMotorcycles), getFirstLineSeg, getLastLineSeg, makeINode) +import Graphics.Slicer.Math.Skeleton.Definitions(Cell(Cell), ENode, ENodeSet(ENodeSet), INode(INode), INodeSet(INodeSet), Motorcycle(Motorcycle), NodeTree(NodeTree), StraightSkeleton(StraightSkeleton), RemainingContour(RemainingContour), CellDivide(CellDivide), DividingMotorcycles(DividingMotorcycles), getFirstLineSeg, getLastLineSeg) import Graphics.Slicer.Math.Skeleton.Face(Face(Face)) @@ -357,410 +343,3 @@ ganjaFooterEnd = " ],{\n" <> "}));\n" <> "});\n" --- moved the below here from the test suite, so that we can drop lines from the test suite into ghci directly. - --- A type for a list of three items. so we can gather a list of exactly three distances / radians. -newtype ListThree a = ListThree {getListThree :: [a]} - deriving (Show, Ord, Eq) - -instance (Arbitrary a) => Arbitrary (ListThree a) where - arbitrary = ListThree <$> vector 3 - --- Radians are always positive, and always between 0 and tau+minfloat. -newtype Radian a = Radian {getRadian :: ℝ} - deriving (Show, Ord, Eq, Enum) - -instance Arbitrary (Radian a) where - arbitrary = Radian <$> (arbitrary `suchThat` (\a -> a > 0 && a <= tau)) - shrink (Radian x) = [ Radian x' | x' <- shrink x , x' > 0 ] - -instance Num (Radian a) where - (+) (Radian r1) (Radian r2) = Radian $ wrapIfNeeded $ r1 + r2 - where - wrapIfNeeded :: ℝ -> ℝ - wrapIfNeeded v - | v <= tau = v - | otherwise = v-tau - (-) (Radian r1) (Radian r2) = Radian $ wrapIfNeeded $ r1 - r2 - where - wrapIfNeeded :: ℝ -> ℝ - wrapIfNeeded v - | v > 0 = v - | otherwise = v+tau - (*) (Radian r1) (Radian r2) = Radian $ recursiveWrap $ r1 * r2 - where - recursiveWrap :: ℝ -> ℝ - recursiveWrap v - | v <= tau = v - | otherwise = recursiveWrap $ v-tau - abs r1 = r1 - fromInteger v = Radian $ fromInteger $ mod v 6 - signum _ = 1 - --- | so we can do some arithmatic on positive numbers. --- FIXME: Yes, this is an orphan instance. -instance (Ord a, Num a) => Num (Positive a) where - (+) (Positive r1) (Positive r2) = Positive $ r1 + r2 - (-) (Positive r1) (Positive r2) - | r1 < r2 = Positive $ r1 - r2 - | otherwise = error "tried to produce a negative number." - (*) (Positive r1) (Positive r2) = Positive $ r1 * r2 - abs r1 = r1 - fromInteger v = Positive $ fromInteger v - signum _ = 1 - -instance Fractional (Radian a) where - (/) (Radian r1) (Radian r2) = Radian $ r1 / r2 - fromRational a = Radian $ fromRational a - -instance (Ord a, Num a, Fractional a) => Fractional (Positive a) where - (/) (Positive r1) (Positive r2) = Positive $ r1 / r2 - fromRational a = Positive $ fromRational a - --- | Generate a random triangle. -randomTriangle :: ℝ -> ℝ -> ListThree (Radian ℝ) -> ListThree (Positive ℝ) -> Contour -randomTriangle centerX centerY rawRadians rawDists = randomStarPoly centerX centerY $ makePairs dists radians - where - radians :: [Radian ℝ] - radians = coerce rawRadians - dists :: [Positive ℝ] - dists = coerce rawDists - --- | Generate a random square. -randomSquare :: ℝ -> ℝ -> Radian ℝ -> Positive ℝ -> Contour -randomSquare centerX centerY tilt distanceToCorner = randomStarPoly centerX centerY $ makePairs distances radians - where - radians = - [ - tilt - , tilt + Radian (tau/4) - , tilt + Radian (tau/2) - , tilt + Radian (pi+(pi/2)) - ] - distances = replicate 4 distanceToCorner - --- | Generate a random rectangle. -randomRectangle :: ℝ -> ℝ -> Radian ℝ -> Radian ℝ -> Positive ℝ -> Contour -randomRectangle centerX centerY rawFirstTilt secondTilt distanceToCorner = randomStarPoly centerX centerY $ makePairs distances radians - where - -- Workaround: since first and second may be unique, but may not be 0, add them! - firstTilt - | rawFirstTilt == secondTilt = rawFirstTilt + secondTilt - | otherwise = rawFirstTilt - radians :: [Radian ℝ] - radians = - [ - firstTilt - , secondTilt - , flipRadian firstTilt - , flipRadian secondTilt - ] - flipRadian :: Radian ℝ -> Radian ℝ - flipRadian v - | v < Radian pi = v + Radian pi - | otherwise = v - Radian pi - distances = replicate 4 distanceToCorner - --- | Generate a random convex four sided polygon, with two right angles. -randomConvexDualRightQuad :: ℝ -> ℝ -> Radian ℝ -> Radian ℝ -> Radian ℝ -> Positive ℝ -> Contour -randomConvexDualRightQuad centerX centerY rawFirstTilt rawSecondTilt rawThirdTilt distanceToCorner = randomStarPoly centerX centerY $ makePairs distances radians - where - -- Workaround: since first and second may be unique, but may not be 0, multiply them! - [firstTilt, secondTilt, thirdTilt] = sort $ ensureUnique $ clipRadian <$> sort [rawFirstTilt, rawSecondTilt, rawThirdTilt] - ensureUnique :: [Radian ℝ] -> [Radian ℝ] - ensureUnique vals - | allUnique vals = vals - | otherwise = ensureUnique $ sort [v*m | m <- [2,3,5] | v <- vals] - radians :: [Radian ℝ] - radians = - [ - firstTilt - , secondTilt - , thirdTilt - , flipRadian secondTilt - ] - flipRadian :: Radian ℝ -> Radian ℝ - flipRadian v - | v < Radian pi = v + Radian pi - | otherwise = v - Radian pi - clipRadian v - | v > Radian pi = v - Radian pi - | otherwise = v - distances = replicate 4 distanceToCorner - --- | Generate a random convex four sided polygon, with one right angle. -randomConvexSingleRightQuad :: ℝ -> ℝ -> Radian ℝ -> Radian ℝ -> Radian ℝ -> Positive ℝ -> Positive ℝ -> Contour -randomConvexSingleRightQuad centerX centerY rawFirstTilt rawSecondTilt rawThirdTilt rawFirstDistanceToCorner rawSecondDistanceToCorner = randomStarPoly centerX centerY $ makePairs distances radians - where - -- Workaround: since first and second may be unique, but may not be 0, multiply them! - [firstDistanceToCorner, secondDistanceToCorner] = sort $ ensureUniqueDistance $ sort [rawFirstDistanceToCorner, rawSecondDistanceToCorner] - ensureUniqueDistance :: [Positive ℝ] -> [Positive ℝ] - ensureUniqueDistance vals - | allUnique vals = vals - | otherwise = ensureUniqueDistance $ sort [v*m | m <- [2,3] | v <- vals] - -- Workaround: since first and second may be unique, but may not be 0, multiply them! - [firstTilt, secondTilt, thirdTilt] = sort $ ensureUnique $ clipRadian <$> sort [rawFirstTilt, rawSecondTilt, rawThirdTilt] - ensureUnique :: [Radian ℝ] -> [Radian ℝ] - ensureUnique vals - | allUnique vals = vals - | otherwise = ensureUnique $ sort [v*m | m <- [2,3,5] | v <- vals] - radians :: [Radian ℝ] - radians = - [ - firstTilt - , secondTilt - , thirdTilt - , flipRadian secondTilt - ] - flipRadian :: Radian ℝ -> Radian ℝ - flipRadian v - | v < Radian pi = v + Radian pi - | otherwise = v - Radian pi - clipRadian v - | v > Radian pi = v - Radian pi - | otherwise = v - distances = firstDistanceToCorner : replicate 3 secondDistanceToCorner - --- | Generate a random convex four sided polygon, with the property that it can be folded down an axis. -randomConvexBisectableQuad :: ℝ -> ℝ -> Radian ℝ -> Radian ℝ -> Positive ℝ -> Positive ℝ -> Contour -randomConvexBisectableQuad centerX centerY rawFirstTilt rawSecondTilt rawFirstDistanceToCorner rawSecondDistanceToCorner = randomStarPoly centerX centerY $ makePairs distances radians - where - -- Workaround: since first and second may be unique, but may not be 0, multiply them! - [firstDistanceToCorner, secondDistanceToCorner] = sort $ ensureUniqueDistance $ sort [rawFirstDistanceToCorner, rawSecondDistanceToCorner] - ensureUniqueDistance :: [Positive ℝ] -> [Positive ℝ] - ensureUniqueDistance vals - | allUnique vals = vals - | otherwise = ensureUniqueDistance $ sort [v*m | m <- [2,3] | v <- vals] - -- Workaround: since first and second may be unique, but may not be 0, multiply them! - [firstTilt, secondTilt] = sort $ ensureUnique $ clipRadian <$> sort [rawFirstTilt, rawSecondTilt] - ensureUnique :: [Radian ℝ] -> [Radian ℝ] - ensureUnique vals - | allUnique vals = vals - | otherwise = ensureUnique $ sort [v*m | m <- [2,3] | v <- vals] - thirdTilt = secondTilt + (secondTilt - firstTilt) - radians :: [Radian ℝ] - radians = - [ - firstTilt - , secondTilt - , thirdTilt - , flipRadian secondTilt - ] - flipRadian :: Radian ℝ -> Radian ℝ - flipRadian v - | v < Radian pi = v + Radian pi - | otherwise = v - Radian pi - clipRadian v - | v > Radian pi = v - Radian pi - | otherwise = v - distances = [firstDistanceToCorner, secondDistanceToCorner, firstDistanceToCorner, secondDistanceToCorner] - --- | Generate a random convex four sided polygon. -randomConvexQuad :: ℝ -> ℝ -> Radian ℝ -> Radian ℝ -> Radian ℝ -> Positive ℝ -> Positive ℝ -> Positive ℝ -> Contour -randomConvexQuad centerX centerY rawFirstTilt rawSecondTilt rawThirdTilt rawFirstDistanceToCorner rawSecondDistanceToCorner rawThirdDistanceToCorner = randomStarPoly centerX centerY $ makePairs distances radians - where - -- Workaround: since first and second may be unique, but may not be 0, multiply them! - [firstDistanceToCorner, secondDistanceToCorner, thirdDistanceToCorner] = sort $ ensureUniqueDistance $ sort [rawFirstDistanceToCorner, rawSecondDistanceToCorner, rawThirdDistanceToCorner] - ensureUniqueDistance :: [Positive ℝ] -> [Positive ℝ] - ensureUniqueDistance vals - | allUnique vals = vals - | otherwise = ensureUniqueDistance $ sort [v*m | m <- [2,3,5] | v <- vals] - -- Workaround: since first and second may be unique, but may not be 0, multiply them! - [firstTilt, secondTilt, thirdTilt] = sort $ ensureUnique $ clipRadian <$> sort [rawFirstTilt, rawSecondTilt, rawThirdTilt] - ensureUnique :: [Radian ℝ] -> [Radian ℝ] - ensureUnique vals - | allUnique vals = vals - | otherwise = ensureUnique $ sort [v*m | m <- [2,3,5] | v <- vals] - radians :: [Radian ℝ] - radians = - [ - firstTilt - , secondTilt - , thirdTilt - , flipRadian secondTilt - ] - flipRadian :: Radian ℝ -> Radian ℝ - flipRadian v - | v < Radian pi = v + Radian pi - | otherwise = v - Radian pi - clipRadian v - | v > Radian pi = v - Radian pi - | otherwise = v - distances = [firstDistanceToCorner, thirdDistanceToCorner, secondDistanceToCorner, thirdDistanceToCorner] - --- | Generate a concave four sided polygon, with the convex motorcycle impacting the opposing bend (a 'dart' per wikipedia. a chevron, or a ^.) --- Note: the center point is always outside of this polygon. -randomConcaveChevronQuad :: ℝ -> ℝ -> Radian ℝ -> Radian ℝ -> Positive ℝ -> Positive ℝ -> Contour -randomConcaveChevronQuad centerX centerY rawFirstTilt rawSecondTilt rawFirstDistanceToCorner rawSecondDistanceToCorner = randomStarPoly centerX centerY $ makePairs distances radians - where - -- Workaround: since first and second may be unique, but may not be 0, multiply them! - [firstDistanceToCorner, secondDistanceToCorner] = sort $ ensureUniqueDistance $ sort [rawFirstDistanceToCorner, rawSecondDistanceToCorner] - ensureUniqueDistance :: [Positive ℝ] -> [Positive ℝ] - ensureUniqueDistance vals - | allUnique vals = vals - | otherwise = ensureUniqueDistance $ sort [v*m | m <- [2,3] | v <- vals] - thirdDistanceToCorner = secondDistanceToCorner / 2 - -- Workaround: since first and second may be unique, but may not be 0, multiply them! - [firstTilt, secondTilt] = sort $ ensureUnique $ clipRadian <$> sort [rawFirstTilt, rawSecondTilt] - ensureUnique :: [Radian ℝ] -> [Radian ℝ] - ensureUnique vals - | allUnique vals = vals - | otherwise = ensureUnique $ sort [v*m | m <- [2,3] | v <- vals] - radians :: [Radian ℝ] - radians = - [ - firstTilt - , secondTilt - , flipRadian firstTilt - , secondTilt - ] - flipRadian :: Radian ℝ -> Radian ℝ - flipRadian v - | v < Radian pi = v + Radian pi - | otherwise = v - Radian pi - clipRadian v - | v > Radian pi = v - Radian pi - | otherwise = v - distances = [firstDistanceToCorner, secondDistanceToCorner, firstDistanceToCorner, thirdDistanceToCorner] - --- | generate a random polygon. --- Idea stolen from: https://stackoverflow.com/questions/8997099/algorithm-to-generate-random-2d-polygon --- note: the centerPoint is assumed to be inside of the contour. -randomStarPoly :: ℝ -> ℝ -> [(Positive ℝ,Radian ℝ)] -> Contour -randomStarPoly centerX centerY radianDistPairs = fromMaybe dumpError $ maybeFlipContour contour - where - contour = makePointContour points - points = pToEPoint2 <$> pointsAroundCenter - pointsAroundCenter = (\(distanceFromPoint, angle) -> fst $ translateRotatePPoint2WithErr centerPPoint (coerce distanceFromPoint) (coerce angle)) <$> radianDistPairs - centerPPoint = eToPP $ Point2 (centerX, centerY) - dumpError = error $ "failed to flip a contour:" <> dumpGanjas [toGanja contour, toGanja (Point2 (centerX, centerY)), toGanja outsidePLine] <> "\n" - where - outsidePLine = join2PPoint2 myMidPoint outsidePoint - outsidePoint = (\(CPPoint2 a) -> PPoint2 a) $ eToPP $ pointFarOutsideContour contour - myMidPoint = pPointBetweenPPoints (eToPP p1) (eToPP p2) 0.5 0.5 - (p1, p2) = firstPointPairOfContour contour - -randomENode :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> Positive ℝ -> Radian ℝ -> ENode -randomENode x y d1 rawR1 d2 rawR2 = makeENode p1 intersectionPoint p2 - where - r1 = rawR1 / 2 - r2 = r1 + (rawR2 / 2) - intersectionPoint = Point2 (x,y) - pp1 = fst $ translateRotatePPoint2WithErr intersectionPPoint (coerce d1) (coerce r1) - pp2 = fst $ translateRotatePPoint2WithErr intersectionPPoint (coerce d2) (coerce r2) - p1 = pToEPoint2 pp1 - p2 = pToEPoint2 pp2 - intersectionPPoint = eToPP intersectionPoint - -randomINode :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> Positive ℝ -> Radian ℝ -> Bool -> Bool -> INode -randomINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 = makeINode [maybeFlippedpl1,maybeFlippedpl2] (Just $ (\(NPLine2 a,b) -> (PLine2 a,b <> outsideResErr)) bisector1) - where - r1 = rawR1 / 2 - r2 = r1 + (rawR2 / 2) - pl1 = (\(NPLine2 a,b) -> (PLine2 a,b)) $ normalizeL $ eToPLine2 $ getFirstLineSeg eNode - pl2 = (\(NPLine2 a,b) -> (PLine2 a,b)) $ normalizeL $ flipL $ eToPLine2 $ getLastLineSeg eNode - intersectionPPoint = pPointOf eNode - eNode = randomENode x y d1 rawR1 d2 rawR2 - pp1 = fst $ translateRotatePPoint2WithErr intersectionPPoint (coerce d1) (coerce r1) - pp2 = fst $ translateRotatePPoint2WithErr intersectionPPoint (coerce d2) (coerce r2) - maybeFlippedpl1 = (if flipIn1 then flipL (fst pl1) else (fst pl1), snd pl1) - maybeFlippedpl2 = (if flipIn2 then flipL (fst pl2) else (fst pl2), snd pl2) - bisector1 = normalizeL outsideRes - (outsideRes, outsideResErr) = getOutsideArc (pp1, mempty) (normalizeL $ fst maybeFlippedpl1) (pp2, mempty) (normalizeL $ fst maybeFlippedpl2) - --- | A helper function. constructs a random PLine. -randomPLine :: ℝ -> ℝ -> NonZero ℝ -> NonZero ℝ -> PLine2 -randomPLine x y dx dy = fst $ randomPLineWithErr x y dx dy - --- | A helper function. constructs a random PLine. -randomPLineWithErr :: ℝ -> ℝ -> NonZero ℝ -> NonZero ℝ -> (PLine2, PLine2Err) -randomPLineWithErr x y dx dy = eToPL $ makeLineSeg (Point2 (x, y)) (Point2 (coerce dx, coerce dy)) - --- | A helper function. constructs a random PLine. -randomPL :: ℝ -> ℝ -> NonZero ℝ -> NonZero ℝ -> (PLine2, PLine2Err) -randomPL x y dx dy = eToPL $ makeLineSeg (Point2 (x, y)) (Point2 (coerce dx, coerce dy)) - --- | A helper function. constructs a random LineSeg. -randomLineSeg :: ℝ -> ℝ -> ℝ -> ℝ -> LineSeg -randomLineSeg x y dx dy = makeLineSeg (Point2 (x, y)) (Point2 (dx,dy)) - - --- | A PLine that does not follow the X = Y line, and does not follow the other given line. -randomPLineThroughOrigin :: ℝ -> ℝ -> (PLine2, PLine2Err) -randomPLineThroughOrigin x y = eToPL $ makeLineSeg (Point2 (x,y)) (Point2 (0,0)) - --- | A PLine that does not follow the X = Y line, and does not follow the other given line. -randomPLineThroughPoint :: ℝ -> ℝ -> ℝ -> (PLine2, PLine2Err) -randomPLineThroughPoint x y d = eToPL $ makeLineSeg (Point2 (x,y)) (Point2 (d,d)) - --- | A line segment ending at the origin. additionally, guaranteed not to be on the X = Y line. -randomLineSegFromPointNotX1Y1 :: ℝ -> ℝ -> ℝ -> LineSeg -randomLineSegFromPointNotX1Y1 rawX rawY d = res - where - res = makeLineSeg (Point2 (d, d)) (Point2 (x, y)) - (x, y) - | rawX == 0 && rawY == 0 = (0,0.1) - | rawX == rawY = (rawX,0.1) - | otherwise = (rawX, rawY) - --- | A line segment ending at the origin. additionally, guaranteed not to be on the X = Y line. -randomLineSegFromOriginNotX1Y1 :: ℝ -> ℝ -> LineSeg -randomLineSegFromOriginNotX1Y1 rawX rawY = res - where - res = makeLineSeg (Point2 (0, 0)) (Point2 (x, y)) - (x, y) - | rawX == 0 && rawY == 0 = (0,0.1) - | rawX == rawY = (rawX,0.1) - | otherwise = (rawX, rawY) - -randomX1Y1LineSegToOrigin :: NonZero ℝ -> LineSeg -randomX1Y1LineSegToOrigin rawD = res - where - res = makeLineSeg (Point2 (d,d)) (Point2 (0,0)) - d :: ℝ - d = coerce rawD - -randomX1Y1LineSegToPoint :: NonZero ℝ -> ℝ -> LineSeg -randomX1Y1LineSegToPoint rawD1 d2 = res - where - res = makeLineSeg (Point2 (d1,d1)) (Point2 (d2,d2)) - d1 :: ℝ - d1 = coerce rawD1 - --- | combine two lists. for feeding into randomStarPoly. -makePairs :: [a] -> [b] -> [(a,b)] -makePairs (a:as) (b:bs) = (a,b) : makePairs as bs -makePairs (_:_) [] = error "out of inputs" -makePairs [] (_:_) = [] -makePairs [] [] = [] - -cellFrom :: Maybe (a,b) -> a -cellFrom (Just (v,_)) = v -cellFrom Nothing = error "whoops" - -remainderFrom :: Maybe (a,b) -> b -remainderFrom (Just (_,v)) = v -remainderFrom Nothing = error "whoops" - -onlyOne :: [a] -> a -onlyOne as = case as of - [] -> error "none" - [a] -> a - (_:_) -> error "too many" - -onlyOneOf :: [a] -> a -onlyOneOf as = case as of - [] -> error "none" - (a:_) -> a - -edgesOf :: Slist Face -> [LineSeg] -edgesOf faces = unwrap <$> (\(Slist a _) -> a) faces - where - unwrap :: Face -> LineSeg - unwrap (Face edge _ _ _) = edge - -generationsOf :: Maybe StraightSkeleton -> Int -generationsOf Nothing = 0 -generationsOf (Just (StraightSkeleton (Slist [] _) _)) = 0 -generationsOf (Just (StraightSkeleton a@(Slist [_] _) _)) = len a -generationsOf a = error $ "what is this?" <> show a <> "\n" diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index dee793de3..3d60837e9 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -60,7 +60,7 @@ module Graphics.Slicer.Math.PGAPrimitives yIntercept ) where -import Prelude(Bool(False), Eq((==),(/=)), Monoid(mempty), Ord, Semigroup((<>)), Show(show), ($), (+), (*), (/), (<$>), (&&), abs, error, filter, fst, negate, otherwise, realToFrac, snd, sqrt) +import Prelude(Bool(False), Eq((==),(/=)), Monoid(mempty), Ord, Semigroup((<>)), Show(show), ($), (+), (*), (/), (<$>), (&&), (-), abs, error, filter, fst, negate, otherwise, realToFrac, snd, sqrt) import Control.DeepSeq (NFData) @@ -389,8 +389,8 @@ pLineErrAtPPoint (line, lineErr) errPoint xMin, xMax, yMin, yMax :: ℝ xMax = xInterceptDistance + realToFrac (ulpVal rawXInterceptFuzz) yMax = yInterceptDistance + realToFrac (ulpVal rawYInterceptFuzz) - xMin = xInterceptDistance - yMin = yInterceptDistance + xMin = xInterceptDistance - realToFrac (ulpVal rawXInterceptFuzz) + yMin = yInterceptDistance - realToFrac (ulpVal rawYInterceptFuzz) rawYInterceptFuzz = snd $ fromJust $ yIntercept (nPLine, nPLineErr) rawXInterceptFuzz = snd $ fromJust $ xIntercept (nPLine, nPLineErr) yInterceptDistance = abs $ fromRight 0 $ fst $ fromJust $ xIntercept (nPLine, nPLineErr) diff --git a/Graphics/Slicer/Math/RandomGeometry.hs b/Graphics/Slicer/Math/RandomGeometry.hs new file mode 100644 index 000000000..0a5e11c39 --- /dev/null +++ b/Graphics/Slicer/Math/RandomGeometry.hs @@ -0,0 +1,508 @@ +{- ORMOLU_DISABLE -} +{- + - Copyright 2016 Noah Halford and Catherine Moresco + - Copyright 2019 Julia Longtin + - + - This program is free software: you can redistribute it and/or modify + - it under the terms of the GNU Affero General Public License as published by + - the Free Software Foundation, either version 3 of the License, or + - (at your option) any later version. + - + - This program is distributed in the hope that it will be useful, + - but WITHOUT ANY WARRANTY; without even the implied warranty of + - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + - GNU Affero General Public License for more details. + - + - You should have received a copy of the GNU Affero General Public License + - along with this program. If not, see . + -} + +{- Utility functions for generating random bits of geometry. Used by the test suite. -} + +-- For Parallel lists. +{-# LANGUAGE ParallelListComp #-} + +-- So we can derive ENum. +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- So we can define a Num instance for Positive. +{-# OPTIONS_GHC -Wno-orphans #-} + +module Graphics.Slicer.Math.RandomGeometry ( + ListThree, + Radian(Radian), + edgesOf, + generationsOf, + randomPL, + randomTriangle, + randomSquare, + randomRectangle, + randomConvexDualRightQuad, + randomConvexSingleRightQuad, + randomConvexBisectableQuad, + randomConvexQuad, + randomConcaveChevronQuad, + randomENode, + randomINode, + randomPLine, + randomPLineWithErr, + randomLineSeg, + cellFrom, + remainderFrom, + onlyOne, + onlyOneOf, + randomPLineThroughOrigin, + randomLineSegFromOriginNotX1Y1, + randomX1Y1LineSegToOrigin, + randomX1Y1LineSegToPoint, + randomLineSegFromPointNotX1Y1, + randomPLineThroughPoint) where + +import Prelude (Bool, Enum, Eq, Fractional, Num, Ord, Show, Int, (<>), (<>), (<$>), ($), (==), (+), (-), (*), (<), (/), (>), (<=), (&&), abs, error, fromInteger, fromRational, fst, mempty, mod, otherwise, replicate, show, signum, snd) + +import Data.Coerce (coerce) + +import Data.List (sort) + +import Data.List.Unique (allUnique) + +import Data.Maybe (Maybe(Nothing, Just), fromMaybe) + +import Math.Tau (tau) + +import Numeric (pi) + +import Slist.Type (Slist(Slist)) + +import Slist (len) + +import Test.QuickCheck (Arbitrary, Positive(Positive), NonZero(NonZero), arbitrary, shrink, suchThat, vector) + +-- The numeric type in HSlice. +import Graphics.Slicer (ℝ) + +import Graphics.Slicer.Math.Arcs (getOutsideArc) + +import Graphics.Slicer.Math.Contour (makePointContour, maybeFlipContour, firstPointPairOfContour, pointFarOutsideContour) + +import Graphics.Slicer.Math.Definitions (Contour, Point2(Point2), LineSeg, makeLineSeg) + +import Graphics.Slicer.Math.Ganja (dumpGanjas, toGanja) + +import Graphics.Slicer.Math.Lossy (eToPLine2, join2PPoint2, pPointBetweenPPoints, pToEPoint2) + +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), PLine2(PLine2), PPoint2(PPoint2), PLine2Err, eToPL, eToPP, flipL, normalizeL, translateRotatePPoint2WithErr, pPointOf, NPLine2(NPLine2)) + +import Graphics.Slicer.Math.Skeleton.Concave (makeENode) + +import Graphics.Slicer.Math.Skeleton.Definitions(ENode, INode, StraightSkeleton(StraightSkeleton), getFirstLineSeg, getLastLineSeg, makeINode) + +import Graphics.Slicer.Math.Skeleton.Face(Face(Face)) + +-- moved the below here from the test suite, so that we can drop lines from the test suite into ghci directly. + +-- A type for a list of three items. so we can gather a list of exactly three distances / radians. +newtype ListThree a = ListThree {getListThree :: [a]} + deriving (Show, Ord, Eq) + +instance (Arbitrary a) => Arbitrary (ListThree a) where + arbitrary = ListThree <$> vector 3 + +-- Radians are always positive, and always between 0 and tau+minfloat. +newtype Radian a = Radian {getRadian :: ℝ} + deriving (Show, Ord, Eq, Enum) + +instance Arbitrary (Radian a) where + arbitrary = Radian <$> (arbitrary `suchThat` (\a -> a > 0 && a <= tau)) + shrink (Radian x) = [ Radian x' | x' <- shrink x , x' > 0 ] + +instance Num (Radian a) where + (+) (Radian r1) (Radian r2) = Radian $ wrapIfNeeded $ r1 + r2 + where + wrapIfNeeded :: ℝ -> ℝ + wrapIfNeeded v + | v <= tau = v + | otherwise = v-tau + (-) (Radian r1) (Radian r2) = Radian $ wrapIfNeeded $ r1 - r2 + where + wrapIfNeeded :: ℝ -> ℝ + wrapIfNeeded v + | v > 0 = v + | otherwise = v+tau + (*) (Radian r1) (Radian r2) = Radian $ recursiveWrap $ r1 * r2 + where + recursiveWrap :: ℝ -> ℝ + recursiveWrap v + | v <= tau = v + | otherwise = recursiveWrap $ v-tau + abs r1 = r1 + fromInteger v = Radian $ fromInteger $ mod v 6 + signum _ = 1 + +-- | so we can do some arithmatic on positive numbers. +-- FIXME: Yes, this is an orphan instance. +instance (Ord a, Num a) => Num (Positive a) where + (+) (Positive r1) (Positive r2) = Positive $ r1 + r2 + (-) (Positive r1) (Positive r2) + | r1 < r2 = Positive $ r1 - r2 + | otherwise = error "tried to produce a negative number." + (*) (Positive r1) (Positive r2) = Positive $ r1 * r2 + abs r1 = r1 + fromInteger v = Positive $ fromInteger v + signum _ = 1 + +instance Fractional (Radian a) where + (/) (Radian r1) (Radian r2) = Radian $ r1 / r2 + fromRational a = Radian $ fromRational a + +instance (Ord a, Num a, Fractional a) => Fractional (Positive a) where + (/) (Positive r1) (Positive r2) = Positive $ r1 / r2 + fromRational a = Positive $ fromRational a + +-- | Generate a random triangle. +randomTriangle :: ℝ -> ℝ -> ListThree (Radian ℝ) -> ListThree (Positive ℝ) -> Contour +randomTriangle centerX centerY rawRadians rawDists = randomStarPoly centerX centerY $ makePairs dists radians + where + radians :: [Radian ℝ] + radians = coerce rawRadians + dists :: [Positive ℝ] + dists = coerce rawDists + +-- | Generate a random square. +randomSquare :: ℝ -> ℝ -> Radian ℝ -> Positive ℝ -> Contour +randomSquare centerX centerY tilt distanceToCorner = randomStarPoly centerX centerY $ makePairs distances radians + where + radians = + [ + tilt + , tilt + Radian (tau/4) + , tilt + Radian (tau/2) + , tilt + Radian (pi+(pi/2)) + ] + distances = replicate 4 distanceToCorner + +-- | Generate a random rectangle. +randomRectangle :: ℝ -> ℝ -> Radian ℝ -> Radian ℝ -> Positive ℝ -> Contour +randomRectangle centerX centerY rawFirstTilt secondTilt distanceToCorner = randomStarPoly centerX centerY $ makePairs distances radians + where + -- Workaround: since first and second may be unique, but may not be 0, add them! + firstTilt + | rawFirstTilt == secondTilt = rawFirstTilt + secondTilt + | otherwise = rawFirstTilt + radians :: [Radian ℝ] + radians = + [ + firstTilt + , secondTilt + , flipRadian firstTilt + , flipRadian secondTilt + ] + flipRadian :: Radian ℝ -> Radian ℝ + flipRadian v + | v < Radian pi = v + Radian pi + | otherwise = v - Radian pi + distances = replicate 4 distanceToCorner + +-- | Generate a random convex four sided polygon, with two right angles. +randomConvexDualRightQuad :: ℝ -> ℝ -> Radian ℝ -> Radian ℝ -> Radian ℝ -> Positive ℝ -> Contour +randomConvexDualRightQuad centerX centerY rawFirstTilt rawSecondTilt rawThirdTilt distanceToCorner = randomStarPoly centerX centerY $ makePairs distances radians + where + -- Workaround: since first and second may be unique, but may not be 0, multiply them! + [firstTilt, secondTilt, thirdTilt] = sort $ ensureUnique $ clipRadian <$> sort [rawFirstTilt, rawSecondTilt, rawThirdTilt] + ensureUnique :: [Radian ℝ] -> [Radian ℝ] + ensureUnique vals + | allUnique vals = vals + | otherwise = ensureUnique $ sort [v*m | m <- [2,3,5] | v <- vals] + radians :: [Radian ℝ] + radians = + [ + firstTilt + , secondTilt + , thirdTilt + , flipRadian secondTilt + ] + flipRadian :: Radian ℝ -> Radian ℝ + flipRadian v + | v < Radian pi = v + Radian pi + | otherwise = v - Radian pi + clipRadian v + | v > Radian pi = v - Radian pi + | otherwise = v + distances = replicate 4 distanceToCorner + +-- | Generate a random convex four sided polygon, with one right angle. +randomConvexSingleRightQuad :: ℝ -> ℝ -> Radian ℝ -> Radian ℝ -> Radian ℝ -> Positive ℝ -> Positive ℝ -> Contour +randomConvexSingleRightQuad centerX centerY rawFirstTilt rawSecondTilt rawThirdTilt rawFirstDistanceToCorner rawSecondDistanceToCorner = randomStarPoly centerX centerY $ makePairs distances radians + where + -- Workaround: since first and second may be unique, but may not be 0, multiply them! + [firstDistanceToCorner, secondDistanceToCorner] = sort $ ensureUniqueDistance $ sort [rawFirstDistanceToCorner, rawSecondDistanceToCorner] + ensureUniqueDistance :: [Positive ℝ] -> [Positive ℝ] + ensureUniqueDistance vals + | allUnique vals = vals + | otherwise = ensureUniqueDistance $ sort [v*m | m <- [2,3] | v <- vals] + -- Workaround: since first and second may be unique, but may not be 0, multiply them! + [firstTilt, secondTilt, thirdTilt] = sort $ ensureUnique $ clipRadian <$> sort [rawFirstTilt, rawSecondTilt, rawThirdTilt] + ensureUnique :: [Radian ℝ] -> [Radian ℝ] + ensureUnique vals + | allUnique vals = vals + | otherwise = ensureUnique $ sort [v*m | m <- [2,3,5] | v <- vals] + radians :: [Radian ℝ] + radians = + [ + firstTilt + , secondTilt + , thirdTilt + , flipRadian secondTilt + ] + flipRadian :: Radian ℝ -> Radian ℝ + flipRadian v + | v < Radian pi = v + Radian pi + | otherwise = v - Radian pi + clipRadian v + | v > Radian pi = v - Radian pi + | otherwise = v + distances = firstDistanceToCorner : replicate 3 secondDistanceToCorner + +-- | Generate a random convex four sided polygon, with the property that it can be folded down an axis. +randomConvexBisectableQuad :: ℝ -> ℝ -> Radian ℝ -> Radian ℝ -> Positive ℝ -> Positive ℝ -> Contour +randomConvexBisectableQuad centerX centerY rawFirstTilt rawSecondTilt rawFirstDistanceToCorner rawSecondDistanceToCorner = randomStarPoly centerX centerY $ makePairs distances radians + where + -- Workaround: since first and second may be unique, but may not be 0, multiply them! + [firstDistanceToCorner, secondDistanceToCorner] = sort $ ensureUniqueDistance $ sort [rawFirstDistanceToCorner, rawSecondDistanceToCorner] + ensureUniqueDistance :: [Positive ℝ] -> [Positive ℝ] + ensureUniqueDistance vals + | allUnique vals = vals + | otherwise = ensureUniqueDistance $ sort [v*m | m <- [2,3] | v <- vals] + -- Workaround: since first and second may be unique, but may not be 0, multiply them! + [firstTilt, secondTilt] = sort $ ensureUnique $ clipRadian <$> sort [rawFirstTilt, rawSecondTilt] + ensureUnique :: [Radian ℝ] -> [Radian ℝ] + ensureUnique vals + | allUnique vals = vals + | otherwise = ensureUnique $ sort [v*m | m <- [2,3] | v <- vals] + thirdTilt = secondTilt + (secondTilt - firstTilt) + radians :: [Radian ℝ] + radians = + [ + firstTilt + , secondTilt + , thirdTilt + , flipRadian secondTilt + ] + flipRadian :: Radian ℝ -> Radian ℝ + flipRadian v + | v < Radian pi = v + Radian pi + | otherwise = v - Radian pi + clipRadian v + | v > Radian pi = v - Radian pi + | otherwise = v + distances = [firstDistanceToCorner, secondDistanceToCorner, firstDistanceToCorner, secondDistanceToCorner] + +-- | Generate a random convex four sided polygon. +randomConvexQuad :: ℝ -> ℝ -> Radian ℝ -> Radian ℝ -> Radian ℝ -> Positive ℝ -> Positive ℝ -> Positive ℝ -> Contour +randomConvexQuad centerX centerY rawFirstTilt rawSecondTilt rawThirdTilt rawFirstDistanceToCorner rawSecondDistanceToCorner rawThirdDistanceToCorner = randomStarPoly centerX centerY $ makePairs distances radians + where + -- Workaround: since first and second may be unique, but may not be 0, multiply them! + [firstDistanceToCorner, secondDistanceToCorner, thirdDistanceToCorner] = sort $ ensureUniqueDistance $ sort [rawFirstDistanceToCorner, rawSecondDistanceToCorner, rawThirdDistanceToCorner] + ensureUniqueDistance :: [Positive ℝ] -> [Positive ℝ] + ensureUniqueDistance vals + | allUnique vals = vals + | otherwise = ensureUniqueDistance $ sort [v*m | m <- [2,3,5] | v <- vals] + -- Workaround: since first and second may be unique, but may not be 0, multiply them! + [firstTilt, secondTilt, thirdTilt] = sort $ ensureUnique $ clipRadian <$> sort [rawFirstTilt, rawSecondTilt, rawThirdTilt] + ensureUnique :: [Radian ℝ] -> [Radian ℝ] + ensureUnique vals + | allUnique vals = vals + | otherwise = ensureUnique $ sort [v*m | m <- [2,3,5] | v <- vals] + radians :: [Radian ℝ] + radians = + [ + firstTilt + , secondTilt + , thirdTilt + , flipRadian secondTilt + ] + flipRadian :: Radian ℝ -> Radian ℝ + flipRadian v + | v < Radian pi = v + Radian pi + | otherwise = v - Radian pi + clipRadian v + | v > Radian pi = v - Radian pi + | otherwise = v + distances = [firstDistanceToCorner, thirdDistanceToCorner, secondDistanceToCorner, thirdDistanceToCorner] + +-- | Generate a concave four sided polygon, with the convex motorcycle impacting the opposing bend (a 'dart' per wikipedia. a chevron, or a ^.) +-- Note: the center point is always outside of this polygon. +randomConcaveChevronQuad :: ℝ -> ℝ -> Radian ℝ -> Radian ℝ -> Positive ℝ -> Positive ℝ -> Contour +randomConcaveChevronQuad centerX centerY rawFirstTilt rawSecondTilt rawFirstDistanceToCorner rawSecondDistanceToCorner = randomStarPoly centerX centerY $ makePairs distances radians + where + -- Workaround: since first and second may be unique, but may not be 0, multiply them! + [firstDistanceToCorner, secondDistanceToCorner] = sort $ ensureUniqueDistance $ sort [rawFirstDistanceToCorner, rawSecondDistanceToCorner] + ensureUniqueDistance :: [Positive ℝ] -> [Positive ℝ] + ensureUniqueDistance vals + | allUnique vals = vals + | otherwise = ensureUniqueDistance $ sort [v*m | m <- [2,3] | v <- vals] + thirdDistanceToCorner = secondDistanceToCorner / 2 + -- Workaround: since first and second may be unique, but may not be 0, multiply them! + [firstTilt, secondTilt] = sort $ ensureUnique $ clipRadian <$> sort [rawFirstTilt, rawSecondTilt] + ensureUnique :: [Radian ℝ] -> [Radian ℝ] + ensureUnique vals + | allUnique vals = vals + | otherwise = ensureUnique $ sort [v*m | m <- [2,3] | v <- vals] + radians :: [Radian ℝ] + radians = + [ + firstTilt + , secondTilt + , flipRadian firstTilt + , secondTilt + ] + flipRadian :: Radian ℝ -> Radian ℝ + flipRadian v + | v < Radian pi = v + Radian pi + | otherwise = v - Radian pi + clipRadian v + | v > Radian pi = v - Radian pi + | otherwise = v + distances = [firstDistanceToCorner, secondDistanceToCorner, firstDistanceToCorner, thirdDistanceToCorner] + +-- | generate a random polygon. +-- Idea stolen from: https://stackoverflow.com/questions/8997099/algorithm-to-generate-random-2d-polygon +-- note: the centerPoint is assumed to be inside of the contour. +randomStarPoly :: ℝ -> ℝ -> [(Positive ℝ,Radian ℝ)] -> Contour +randomStarPoly centerX centerY radianDistPairs = fromMaybe dumpError $ maybeFlipContour contour + where + contour = makePointContour points + points = pToEPoint2 <$> pointsAroundCenter + pointsAroundCenter = (\(distanceFromPoint, angle) -> fst $ translateRotatePPoint2WithErr centerPPoint (coerce distanceFromPoint) (coerce angle)) <$> radianDistPairs + centerPPoint = eToPP $ Point2 (centerX, centerY) + dumpError = error $ "failed to flip a contour:" <> dumpGanjas [toGanja contour, toGanja (Point2 (centerX, centerY)), toGanja outsidePLine] <> "\n" + where + outsidePLine = join2PPoint2 myMidPoint outsidePoint + outsidePoint = (\(CPPoint2 a) -> PPoint2 a) $ eToPP $ pointFarOutsideContour contour + myMidPoint = pPointBetweenPPoints (eToPP p1) (eToPP p2) 0.5 0.5 + (p1, p2) = firstPointPairOfContour contour + +randomENode :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> Positive ℝ -> Radian ℝ -> ENode +randomENode x y d1 rawR1 d2 rawR2 = makeENode p1 intersectionPoint p2 + where + r1 = rawR1 / 2 + r2 = r1 + (rawR2 / 2) + intersectionPoint = Point2 (x,y) + pp1 = fst $ translateRotatePPoint2WithErr intersectionPPoint (coerce d1) (coerce r1) + pp2 = fst $ translateRotatePPoint2WithErr intersectionPPoint (coerce d2) (coerce r2) + p1 = pToEPoint2 pp1 + p2 = pToEPoint2 pp2 + intersectionPPoint = eToPP intersectionPoint + +randomINode :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> Positive ℝ -> Radian ℝ -> Bool -> Bool -> INode +randomINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 = makeINode [maybeFlippedpl1,maybeFlippedpl2] (Just $ (\(NPLine2 a,b) -> (PLine2 a,b <> outsideResErr)) bisector1) + where + r1 = rawR1 / 2 + r2 = r1 + (rawR2 / 2) + pl1 = (\(NPLine2 a,b) -> (PLine2 a,b)) $ normalizeL $ eToPLine2 $ getFirstLineSeg eNode + pl2 = (\(NPLine2 a,b) -> (PLine2 a,b)) $ normalizeL $ flipL $ eToPLine2 $ getLastLineSeg eNode + intersectionPPoint = pPointOf eNode + eNode = randomENode x y d1 rawR1 d2 rawR2 + pp1 = fst $ translateRotatePPoint2WithErr intersectionPPoint (coerce d1) (coerce r1) + pp2 = fst $ translateRotatePPoint2WithErr intersectionPPoint (coerce d2) (coerce r2) + maybeFlippedpl1 = (if flipIn1 then flipL (fst pl1) else (fst pl1), snd pl1) + maybeFlippedpl2 = (if flipIn2 then flipL (fst pl2) else (fst pl2), snd pl2) + bisector1 = normalizeL outsideRes + (outsideRes, outsideResErr) = getOutsideArc (pp1, mempty) (normalizeL $ fst maybeFlippedpl1) (pp2, mempty) (normalizeL $ fst maybeFlippedpl2) + +-- | A helper function. constructs a random PLine. +randomPLine :: ℝ -> ℝ -> NonZero ℝ -> NonZero ℝ -> PLine2 +randomPLine x y dx dy = fst $ randomPLineWithErr x y dx dy + +-- | A helper function. constructs a random PLine. +randomPLineWithErr :: ℝ -> ℝ -> NonZero ℝ -> NonZero ℝ -> (PLine2, PLine2Err) +randomPLineWithErr x y dx dy = eToPL $ makeLineSeg (Point2 (x, y)) (Point2 (coerce dx, coerce dy)) + +-- | A helper function. constructs a random PLine. +randomPL :: ℝ -> ℝ -> NonZero ℝ -> NonZero ℝ -> (PLine2, PLine2Err) +randomPL x y dx dy = eToPL $ makeLineSeg (Point2 (x, y)) (Point2 (coerce dx, coerce dy)) + +-- | A helper function. constructs a random LineSeg. +randomLineSeg :: ℝ -> ℝ -> ℝ -> ℝ -> LineSeg +randomLineSeg x y dx dy = makeLineSeg (Point2 (x, y)) (Point2 (dx,dy)) + + +-- | A PLine that does not follow the X = Y line, and does not follow the other given line. +randomPLineThroughOrigin :: ℝ -> ℝ -> (PLine2, PLine2Err) +randomPLineThroughOrigin x y = eToPL $ makeLineSeg (Point2 (x,y)) (Point2 (0,0)) + +-- | A PLine that does not follow the X = Y line, and does not follow the other given line. +randomPLineThroughPoint :: ℝ -> ℝ -> ℝ -> (PLine2, PLine2Err) +randomPLineThroughPoint x y d = eToPL $ makeLineSeg (Point2 (x,y)) (Point2 (d,d)) + +-- | A line segment ending at the origin. additionally, guaranteed not to be on the X = Y line. +randomLineSegFromPointNotX1Y1 :: ℝ -> ℝ -> ℝ -> LineSeg +randomLineSegFromPointNotX1Y1 rawX rawY d = res + where + res = makeLineSeg (Point2 (d, d)) (Point2 (x, y)) + (x, y) + | rawX == 0 && rawY == 0 = (0,0.1) + | rawX == rawY = (rawX,0.1) + | otherwise = (rawX, rawY) + +-- | A line segment ending at the origin. additionally, guaranteed not to be on the X = Y line. +randomLineSegFromOriginNotX1Y1 :: ℝ -> ℝ -> LineSeg +randomLineSegFromOriginNotX1Y1 rawX rawY = res + where + res = makeLineSeg (Point2 (0, 0)) (Point2 (x, y)) + (x, y) + | rawX == 0 && rawY == 0 = (0,0.1) + | rawX == rawY = (rawX,0.1) + | otherwise = (rawX, rawY) + +randomX1Y1LineSegToOrigin :: NonZero ℝ -> LineSeg +randomX1Y1LineSegToOrigin rawD = res + where + res = makeLineSeg (Point2 (d,d)) (Point2 (0,0)) + d :: ℝ + d = coerce rawD + +randomX1Y1LineSegToPoint :: NonZero ℝ -> ℝ -> LineSeg +randomX1Y1LineSegToPoint rawD1 d2 = res + where + res = makeLineSeg (Point2 (d1,d1)) (Point2 (d2,d2)) + d1 :: ℝ + d1 = coerce rawD1 + +-- | combine two lists. for feeding into randomStarPoly. +makePairs :: [a] -> [b] -> [(a,b)] +makePairs (a:as) (b:bs) = (a,b) : makePairs as bs +makePairs (_:_) [] = error "out of inputs" +makePairs [] (_:_) = [] +makePairs [] [] = [] + +cellFrom :: Maybe (a,b) -> a +cellFrom (Just (v,_)) = v +cellFrom Nothing = error "whoops" + +remainderFrom :: Maybe (a,b) -> b +remainderFrom (Just (_,v)) = v +remainderFrom Nothing = error "whoops" + +onlyOne :: [a] -> a +onlyOne as = case as of + [] -> error "none" + [a] -> a + (_:_) -> error "too many" + +onlyOneOf :: [a] -> a +onlyOneOf as = case as of + [] -> error "none" + (a:_) -> a + +edgesOf :: Slist Face -> [LineSeg] +edgesOf faces = unwrap <$> (\(Slist a _) -> a) faces + where + unwrap :: Face -> LineSeg + unwrap (Face edge _ _ _) = edge + +generationsOf :: Maybe StraightSkeleton -> Int +generationsOf Nothing = 0 +generationsOf (Just (StraightSkeleton (Slist [] _) _)) = 0 +generationsOf (Just (StraightSkeleton a@(Slist [_] _) _)) = len a +generationsOf a = error $ "what is this?" <> show a <> "\n" diff --git a/hslice.cabal b/hslice.cabal index a932b7f2d..907379242 100644 --- a/hslice.cabal +++ b/hslice.cabal @@ -39,6 +39,7 @@ library Graphics.Slicer.Math.Line Graphics.Slicer.Math.PGA Graphics.Slicer.Math.PGAPrimitives + Graphics.Slicer.Math.RandomGeometry Graphics.Slicer.Math.Skeleton.Cells Graphics.Slicer.Math.Skeleton.Concave Graphics.Slicer.Math.Skeleton.Definitions diff --git a/tests/GoldenSpec/Spec.hs b/tests/GoldenSpec/Spec.hs index 02074eefb..725e83689 100644 --- a/tests/GoldenSpec/Spec.hs +++ b/tests/GoldenSpec/Spec.hs @@ -36,9 +36,9 @@ import Graphics.Slicer.Math.Skeleton.Skeleton (findStraightSkeleton) import Graphics.Slicer.Math.Contour (makePointContour) -- A euclidian point. -import Graphics.Slicer.Math.Definitions(Point2(Point2), LineSeg(LineSeg)) +import Graphics.Slicer.Math.Definitions (Point2(Point2), LineSeg(LineSeg)) -import Graphics.Slicer.Math.Ganja(cellFrom, remainderFrom, onlyOne) +import Graphics.Slicer.Math.RandomGeometry (cellFrom, remainderFrom, onlyOne) import Graphics.Slicer.Math.Skeleton.Cells (UnsupportedReason, findFirstCellOfContour, findNextCell, findDivisions, getNodeTreeOfCell, nodeTreesFromDivision) diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index 2921ea0a1..b66ef00d0 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -88,7 +88,10 @@ import Graphics.Slicer.Math.Skeleton.Skeleton (findStraightSkeleton) import Math.Util ((-->), (-/>)) -- Our debugging library, for making the below simpler to read, and drop into command lines. -import Graphics.Slicer.Math.Ganja (ListThree, Radian(Radian), cellFrom, edgesOf, generationsOf, randomPL, randomTriangle, randomRectangle, randomSquare, randomConvexQuad, randomConvexSingleRightQuad, randomConvexDualRightQuad, randomConvexBisectableQuad, randomConcaveChevronQuad, randomENode, randomINode, randomLineSeg, randomPLine, randomPLineWithErr, remainderFrom, onlyOne, onlyOneOf, dumpGanjas, toGanja, randomPLineThroughOrigin, randomX1Y1LineSegToOrigin, randomLineSegFromOriginNotX1Y1, randomX1Y1LineSegToPoint, randomLineSegFromPointNotX1Y1, randomPLineThroughPoint) +import Graphics.Slicer.Math.Ganja (dumpGanjas, toGanja) + +-- Our Geometry generation library. For random shaped geometry. +import Graphics.Slicer.Math.RandomGeometry (ListThree, Radian(Radian), cellFrom, edgesOf, generationsOf, randomPL, randomTriangle, randomRectangle, randomSquare, randomConvexQuad, randomConvexSingleRightQuad, randomConvexDualRightQuad, randomConvexBisectableQuad, randomConcaveChevronQuad, randomENode, randomINode, randomLineSeg, randomPLine, randomPLineWithErr, remainderFrom, onlyOne, onlyOneOf, randomPLineThroughOrigin, randomX1Y1LineSegToOrigin, randomLineSegFromOriginNotX1Y1, randomX1Y1LineSegToPoint, randomLineSegFromPointNotX1Y1, randomPLineThroughPoint) -- Default all numbers in this file to being of the type ImplicitCAD uses for values. default (ℝ) From 4d0661623ce31a53a7358443a0f2589e6225bbcb Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 3 Dec 2022 16:45:06 +0000 Subject: [PATCH 120/206] put functions in order. --- Graphics/Slicer/Math/RandomGeometry.hs | 33 +++++++++++++------------- 1 file changed, 17 insertions(+), 16 deletions(-) diff --git a/Graphics/Slicer/Math/RandomGeometry.hs b/Graphics/Slicer/Math/RandomGeometry.hs index 0a5e11c39..58496dee4 100644 --- a/Graphics/Slicer/Math/RandomGeometry.hs +++ b/Graphics/Slicer/Math/RandomGeometry.hs @@ -31,32 +31,33 @@ module Graphics.Slicer.Math.RandomGeometry ( ListThree, Radian(Radian), + cellFrom, edgesOf, generationsOf, - randomPL, - randomTriangle, - randomSquare, - randomRectangle, - randomConvexDualRightQuad, - randomConvexSingleRightQuad, + onlyOne, + onlyOneOf, + randomConcaveChevronQuad, randomConvexBisectableQuad, + randomConvexDualRightQuad, randomConvexQuad, - randomConcaveChevronQuad, + randomConvexSingleRightQuad, randomENode, randomINode, - randomPLine, - randomPLineWithErr, randomLineSeg, - cellFrom, - remainderFrom, - onlyOne, - onlyOneOf, - randomPLineThroughOrigin, randomLineSegFromOriginNotX1Y1, + randomLineSegFromPointNotX1Y1, + randomPL, + randomPLine, + randomPLineThroughOrigin, + randomPLineThroughPoint, + randomPLineWithErr, + randomRectangle, + randomSquare, + randomTriangle, randomX1Y1LineSegToOrigin, randomX1Y1LineSegToPoint, - randomLineSegFromPointNotX1Y1, - randomPLineThroughPoint) where + remainderFrom, + ) where import Prelude (Bool, Enum, Eq, Fractional, Num, Ord, Show, Int, (<>), (<>), (<$>), ($), (==), (+), (-), (*), (<), (/), (>), (<=), (&&), abs, error, fromInteger, fromRational, fst, mempty, mod, otherwise, replicate, show, signum, snd) From 8a1ed0d4bb8221946d819015ee798b28db8906af Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 3 Dec 2022 17:27:40 +0000 Subject: [PATCH 121/206] move getMotorcycleContourIntersections to ContourIntersections.hs --- Graphics/Slicer/Math/Contour.hs | 2 +- Graphics/Slicer/Math/ContourIntersections.hs | 25 +++++++++++++++++--- Graphics/Slicer/Math/Intersections.hs | 25 ++++---------------- Graphics/Slicer/Math/RandomGeometry.hs | 2 +- Graphics/Slicer/Math/Skeleton/Motorcycles.hs | 3 ++- 5 files changed, 31 insertions(+), 26 deletions(-) diff --git a/Graphics/Slicer/Math/Contour.hs b/Graphics/Slicer/Math/Contour.hs index 7d51e7b41..19261924d 100644 --- a/Graphics/Slicer/Math/Contour.hs +++ b/Graphics/Slicer/Math/Contour.hs @@ -46,7 +46,7 @@ import Graphics.Implicit.Definitions (ℝ) import Graphics.Slicer.Math.ContourIntersections (contourIntersectionCount) -import Graphics.Slicer.Math.Definitions (Contour(PointContour, LineSegContour), Point2(Point2), LineSeg(endPoint, startPoint), fudgeFactor, lineSegsOfContour, makeLineSeg, minMaxPoints, xOf, yOf) +import Graphics.Slicer.Math.Definitions (Contour(PointContour, LineSegContour), Point2(Point2), LineSeg(endPoint, startPoint), fudgeFactor, lineSegsOfContour, makeLineSeg, minMaxPoints, xOf, yOf) import Graphics.Slicer.Math.GeometricAlgebra (ulpVal) diff --git a/Graphics/Slicer/Math/ContourIntersections.hs b/Graphics/Slicer/Math/ContourIntersections.hs index b5fbedff1..b417faaec 100644 --- a/Graphics/Slicer/Math/ContourIntersections.hs +++ b/Graphics/Slicer/Math/ContourIntersections.hs @@ -20,10 +20,13 @@ module Graphics.Slicer.Math.ContourIntersections ( contourIntersectionCount, - getLineContourIntersections + getLineContourIntersections, + getMotorcycleContourIntersections ) where -import Prelude (Either(Left, Right), Int, Show(show), (<$>), (<>), ($), error, fst, length, odd, otherwise, zip) +import Prelude (Either(Left, Right), Int, Show(show), (<$>), (<>), ($), (/=), (&&), error, fst, length, odd, otherwise, zip) + +import Data.List (filter) import Data.Maybe (Maybe(Just), catMaybes) @@ -35,7 +38,9 @@ import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, lineSegsOfCon import Graphics.Slicer.Math.Intersections (filterIntersections) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2Err, ProjectiveLine2, intersectsWithErr, normalizeL, pToEP) +import Graphics.Slicer.Math.PGA (CPPoint2, Intersection, NPLine2, PIntersection, PLine2Err, ProjectiveLine2, intersectsWithErr, normalizeL, outputIntersectsLineSeg, pToEP) + +import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle)) -- | return the number of intersections with a given contour when traveling in a straight line from the beginning of the given line segment to the end of the line segment. -- Not for use when line segments can overlap or are collinear with one of the line segments that are a part of the contour. @@ -72,3 +77,17 @@ getLineContourIntersections (line, lineErr) c getPoint (_, Left v) = v getPoint (_, Right v) = fst $ pToEP v +-- | Get all possible intersections between the motorcycle and the contour. +-- Filters out the input and output segment of the motorcycle. +getMotorcycleContourIntersections :: Motorcycle -> Contour -> [(LineSeg, Either Point2 CPPoint2)] +getMotorcycleContourIntersections m@(Motorcycle (inSeg, outSeg) _ _) c = stripInSegOutSeg $ catMaybes $ mapWithNeighbors filterIntersections $ openCircuit $ zip contourLines $ willIntersect <$> contourLines + where + willIntersect :: LineSeg -> Either Intersection PIntersection + willIntersect mySeg = outputIntersectsLineSeg m mySeg + openCircuit v = Just <$> v + contourLines = lineSegsOfContour c + stripInSegOutSeg :: [(LineSeg, Either Point2 CPPoint2)] -> [(LineSeg, Either Point2 CPPoint2)] + stripInSegOutSeg = filter fun + where + -- filter out inSeg and outSeg outSeg + fun (seg,_) = seg /= inSeg && seg /= outSeg diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index 551cc5834..60e392457 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -18,17 +18,17 @@ {- Purpose of this file: to hold the logic and routines responsible for checking for intersections with contours, or portions of contours. -} -module Graphics.Slicer.Math.Intersections (filterIntersections, getMotorcycleSegSetIntersections, getMotorcycleContourIntersections, intersectionOf, intersectionBetween, noIntersection, isCollinear, isAntiCollinear, isParallel, isAntiParallel) where +module Graphics.Slicer.Math.Intersections (filterIntersections, getMotorcycleSegSetIntersections, intersectionOf, intersectionBetween, noIntersection, isCollinear, isAntiCollinear, isParallel, isAntiParallel) where import Prelude (Bool, Either(Left,Right), error, otherwise, show, (&&), (<>), ($), (<$>), (/=), zip, (<), (*), (||), (==), mempty, realToFrac) -import Data.Maybe (Maybe(Just,Nothing), catMaybes, isJust, fromJust) +import Data.List (filter) -import Data.List as L (filter) +import Data.Maybe (Maybe(Just,Nothing), catMaybes, isJust, fromJust) import Graphics.Slicer.Definitions (ℝ) -import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, mapWithNeighbors, startPoint, distance, lineSegsOfContour, endPoint, fudgeFactor) +import Graphics.Slicer.Math.Definitions (LineSeg, Point2, mapWithNeighbors, startPoint, distance, endPoint, fudgeFactor) import Graphics.Slicer.Math.GeometricAlgebra (ulpVal) @@ -55,26 +55,11 @@ getMotorcycleSegSetIntersections m@(Motorcycle (inSeg, outSeg) _ _) segs = strip shortCircuitItem (Just seg, Just intersection) = Just (seg, intersection) shortCircuitItem item = error $ "cannot short circuit item: " <> show item <> "\n" stripInSegOutSeg :: [(LineSeg, Either Point2 CPPoint2)] -> [(LineSeg, Either Point2 CPPoint2)] - stripInSegOutSeg = L.filter fun + stripInSegOutSeg = filter fun where -- make sure neither of these segments are inSeg or outSeg fun (seg,_) = seg /= inSeg && seg /= outSeg --- | Get all possible intersections between the motorcycle and the contour. --- Filters out the input and output segment of the motorcycle. -getMotorcycleContourIntersections :: Motorcycle -> Contour -> [(LineSeg, Either Point2 CPPoint2)] -getMotorcycleContourIntersections m@(Motorcycle (inSeg, outSeg) _ _) c = stripInSegOutSeg $ catMaybes $ mapWithNeighbors filterIntersections $ openCircuit $ zip contourLines $ willIntersect <$> contourLines - where - willIntersect :: LineSeg -> Either Intersection PIntersection - willIntersect mySeg = outputIntersectsLineSeg m mySeg - openCircuit v = Just <$> v - contourLines = lineSegsOfContour c - stripInSegOutSeg :: [(LineSeg, Either Point2 CPPoint2)] -> [(LineSeg, Either Point2 CPPoint2)] - stripInSegOutSeg = L.filter fun - where - -- filter out inSeg and outSeg outSeg - fun (seg,_) = seg /= inSeg && seg /= outSeg - -- | filter the intersections given. -- The purpose of this function is to ensure we only count the crossing of a line (segment) across a contour's edge more than once. so if it hits a sttartpoint, make sure we don't count the endpoint.. etc. -- FIXME: does not take into account (anti)collinear line segments correctly. diff --git a/Graphics/Slicer/Math/RandomGeometry.hs b/Graphics/Slicer/Math/RandomGeometry.hs index 58496dee4..55c4996c8 100644 --- a/Graphics/Slicer/Math/RandomGeometry.hs +++ b/Graphics/Slicer/Math/RandomGeometry.hs @@ -56,7 +56,7 @@ module Graphics.Slicer.Math.RandomGeometry ( randomTriangle, randomX1Y1LineSegToOrigin, randomX1Y1LineSegToPoint, - remainderFrom, + remainderFrom ) where import Prelude (Bool, Enum, Eq, Fractional, Num, Ord, Show, Int, (<>), (<>), (<$>), ($), (==), (+), (-), (*), (<), (/), (>), (<=), (&&), abs, error, fromInteger, fromRational, fst, mempty, mod, otherwise, replicate, show, signum, snd) diff --git a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs index 9e2d6e45d..49cef5869 100644 --- a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs +++ b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs @@ -44,9 +44,10 @@ import Graphics.Slicer.Definitions (ℝ) import Graphics.Slicer.Math.Contour (pointsOfContour) +import Graphics.Slicer.Math.ContourIntersections (getMotorcycleContourIntersections) import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, mapWithNeighbors, startPoint, endPoint, makeLineSeg) -import Graphics.Slicer.Math.Intersections (getMotorcycleSegSetIntersections, getMotorcycleContourIntersections, intersectionOf, isAntiCollinear, noIntersection) +import Graphics.Slicer.Math.Intersections (getMotorcycleSegSetIntersections, intersectionOf, isAntiCollinear, noIntersection) import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, pPointBetweenPPoints, distanceBetweenPPoints, eToCPPoint2, eToPLine2, normalizePLine2, pToEPoint2) From b381baa757c9208566e4844ae0019981033da890 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 3 Dec 2022 18:02:24 +0000 Subject: [PATCH 122/206] use outputIntersectsLineSeg directly, instead of wrapping it. --- Graphics/Slicer/Math/ContourIntersections.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/Graphics/Slicer/Math/ContourIntersections.hs b/Graphics/Slicer/Math/ContourIntersections.hs index b417faaec..716a9fe4d 100644 --- a/Graphics/Slicer/Math/ContourIntersections.hs +++ b/Graphics/Slicer/Math/ContourIntersections.hs @@ -38,7 +38,7 @@ import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, lineSegsOfCon import Graphics.Slicer.Math.Intersections (filterIntersections) -import Graphics.Slicer.Math.PGA (CPPoint2, Intersection, NPLine2, PIntersection, PLine2Err, ProjectiveLine2, intersectsWithErr, normalizeL, outputIntersectsLineSeg, pToEP) +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2Err, ProjectiveLine2, intersectsWithErr, normalizeL, outputIntersectsLineSeg, pToEP) import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle)) @@ -80,10 +80,8 @@ getLineContourIntersections (line, lineErr) c -- | Get all possible intersections between the motorcycle and the contour. -- Filters out the input and output segment of the motorcycle. getMotorcycleContourIntersections :: Motorcycle -> Contour -> [(LineSeg, Either Point2 CPPoint2)] -getMotorcycleContourIntersections m@(Motorcycle (inSeg, outSeg) _ _) c = stripInSegOutSeg $ catMaybes $ mapWithNeighbors filterIntersections $ openCircuit $ zip contourLines $ willIntersect <$> contourLines +getMotorcycleContourIntersections m@(Motorcycle (inSeg, outSeg) _ _) c = stripInSegOutSeg $ catMaybes $ mapWithNeighbors filterIntersections $ openCircuit $ zip contourLines $ outputIntersectsLineSeg m <$> contourLines where - willIntersect :: LineSeg -> Either Intersection PIntersection - willIntersect mySeg = outputIntersectsLineSeg m mySeg openCircuit v = Just <$> v contourLines = lineSegsOfContour c stripInSegOutSeg :: [(LineSeg, Either Point2 CPPoint2)] -> [(LineSeg, Either Point2 CPPoint2)] From 13597e0132de049d8b901944fa2957bb714b3840 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 3 Dec 2022 18:48:36 +0000 Subject: [PATCH 123/206] move getMotorcycleSegSetIntersections to contourInterseections.hs. --- Graphics/Slicer/Math/ContourIntersections.hs | 32 +++++++++++++++-- Graphics/Slicer/Math/Intersections.hs | 38 +++----------------- Graphics/Slicer/Math/Skeleton/Motorcycles.hs | 5 +-- 3 files changed, 37 insertions(+), 38 deletions(-) diff --git a/Graphics/Slicer/Math/ContourIntersections.hs b/Graphics/Slicer/Math/ContourIntersections.hs index 716a9fe4d..f4b56618e 100644 --- a/Graphics/Slicer/Math/ContourIntersections.hs +++ b/Graphics/Slicer/Math/ContourIntersections.hs @@ -21,14 +21,15 @@ module Graphics.Slicer.Math.ContourIntersections ( contourIntersectionCount, getLineContourIntersections, - getMotorcycleContourIntersections + getMotorcycleContourIntersections, + getMotorcycleSegSetIntersections ) where import Prelude (Either(Left, Right), Int, Show(show), (<$>), (<>), ($), (/=), (&&), error, fst, length, odd, otherwise, zip) import Data.List (filter) -import Data.Maybe (Maybe(Just), catMaybes) +import Data.Maybe (Maybe(Just, Nothing), catMaybes) import Slist.Type (Slist) @@ -38,7 +39,7 @@ import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, lineSegsOfCon import Graphics.Slicer.Math.Intersections (filterIntersections) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2Err, ProjectiveLine2, intersectsWithErr, normalizeL, outputIntersectsLineSeg, pToEP) +import Graphics.Slicer.Math.PGA (CPPoint2, Intersection, NPLine2, PIntersection, PLine2Err, ProjectiveLine2, intersectsWithErr, normalizeL, outputIntersectsLineSeg, pToEP) import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle)) @@ -89,3 +90,28 @@ getMotorcycleContourIntersections m@(Motorcycle (inSeg, outSeg) _ _) c = stripIn where -- filter out inSeg and outSeg outSeg fun (seg,_) = seg /= inSeg && seg /= outSeg + +-- | Get all possible intersections between the motorcycle and the given list of segments. +-- Filters out the input and output segment of the motorcycle. +getMotorcycleSegSetIntersections :: Motorcycle -> [LineSeg] -> [(LineSeg, Either Point2 CPPoint2)] +getMotorcycleSegSetIntersections m@(Motorcycle (inSeg, outSeg) _ _) segs = stripInSegOutSeg $ catMaybes $ mapWithNeighbors filterIntersections $ shortCircuit $ zip bufferedLineSegs $ mightIntersect <$> bufferedLineSegs + where + -- since this is a list of segments, we terminate the list with Nothings, so that the saneIntersections pattern matching logic can deal with "there is no neighbor, but i hit a start/end point" + bufferedLineSegs :: [Maybe LineSeg] + bufferedLineSegs = Nothing : (Just <$> segs) <> [Nothing] + mightIntersect :: Maybe LineSeg -> Maybe (Either Intersection PIntersection) + mightIntersect maybeSeg = case maybeSeg of + Nothing -> Nothing + (Just seg) -> Just $ outputIntersectsLineSeg m seg + shortCircuit :: [(Maybe LineSeg, Maybe (Either Intersection PIntersection))] -> [Maybe (LineSeg, Either Intersection PIntersection)] + shortCircuit items = shortCircuitItem <$> items + where + shortCircuitItem (Nothing, Nothing) = Nothing + shortCircuitItem (Just seg, Just intersection) = Just (seg, intersection) + shortCircuitItem item = error $ "cannot short circuit item: " <> show item <> "\n" + stripInSegOutSeg :: [(LineSeg, Either Point2 CPPoint2)] -> [(LineSeg, Either Point2 CPPoint2)] + stripInSegOutSeg = filter fun + where + -- make sure neither of these segments are inSeg or outSeg + fun (seg,_) = seg /= inSeg && seg /= outSeg + diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index 60e392457..370a54f4e 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -18,47 +18,19 @@ {- Purpose of this file: to hold the logic and routines responsible for checking for intersections with contours, or portions of contours. -} -module Graphics.Slicer.Math.Intersections (filterIntersections, getMotorcycleSegSetIntersections, intersectionOf, intersectionBetween, noIntersection, isCollinear, isAntiCollinear, isParallel, isAntiParallel) where +module Graphics.Slicer.Math.Intersections (filterIntersections, intersectionOf, intersectionBetween, noIntersection, isCollinear, isAntiCollinear, isParallel, isAntiParallel) where -import Prelude (Bool, Either(Left,Right), error, otherwise, show, (&&), (<>), ($), (<$>), (/=), zip, (<), (*), (||), (==), mempty, realToFrac) +import Prelude (Bool, Either(Left,Right), error, otherwise, show, (<>), ($), (<), (*), (||), (==), mempty, realToFrac) -import Data.List (filter) - -import Data.Maybe (Maybe(Just,Nothing), catMaybes, isJust, fromJust) +import Data.Maybe (Maybe(Just,Nothing), isJust, fromJust) import Graphics.Slicer.Definitions (ℝ) -import Graphics.Slicer.Math.Definitions (LineSeg, Point2, mapWithNeighbors, startPoint, distance, endPoint, fudgeFactor) +import Graphics.Slicer.Math.Definitions (LineSeg, Point2, startPoint, distance, endPoint, fudgeFactor) import Graphics.Slicer.Math.GeometricAlgebra (ulpVal) -import Graphics.Slicer.Math.PGA (CPPoint2, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), Intersection(HitEndPoint, HitStartPoint, NoIntersection), PLine2, PLine2Err, PPoint2Err, ProjectiveLine2, distance2PL, outputIntersectsLineSeg, plinesIntersectIn) - -import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle)) - --- | Get all possible intersections between the motorcycle and the given list of segments. --- Filters out the input and output segment of the motorcycle. -getMotorcycleSegSetIntersections :: Motorcycle -> [LineSeg] -> [(LineSeg, Either Point2 CPPoint2)] -getMotorcycleSegSetIntersections m@(Motorcycle (inSeg, outSeg) _ _) segs = stripInSegOutSeg $ catMaybes $ mapWithNeighbors filterIntersections $ shortCircuit $ zip bufferedLineSegs $ mightIntersect <$> bufferedLineSegs - where - -- since this is a list of segments, we terminate the list with Nothings, so that the saneIntersections pattern matching logic can deal with "there is no neighbor, but i hit a start/end point" - bufferedLineSegs :: [Maybe LineSeg] - bufferedLineSegs = Nothing : (Just <$> segs) <> [Nothing] - mightIntersect :: Maybe LineSeg -> Maybe (Either Intersection PIntersection) - mightIntersect maybeSeg = case maybeSeg of - Nothing -> Nothing - (Just seg) -> Just $ outputIntersectsLineSeg m seg - shortCircuit :: [(Maybe LineSeg, Maybe (Either Intersection PIntersection))] -> [Maybe (LineSeg, Either Intersection PIntersection)] - shortCircuit items = shortCircuitItem <$> items - where - shortCircuitItem (Nothing, Nothing) = Nothing - shortCircuitItem (Just seg, Just intersection) = Just (seg, intersection) - shortCircuitItem item = error $ "cannot short circuit item: " <> show item <> "\n" - stripInSegOutSeg :: [(LineSeg, Either Point2 CPPoint2)] -> [(LineSeg, Either Point2 CPPoint2)] - stripInSegOutSeg = filter fun - where - -- make sure neither of these segments are inSeg or outSeg - fun (seg,_) = seg /= inSeg && seg /= outSeg +import Graphics.Slicer.Math.PGA (CPPoint2, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), Intersection(HitEndPoint, HitStartPoint, NoIntersection), PLine2, PLine2Err, PPoint2Err, ProjectiveLine2, distance2PL, plinesIntersectIn) -- | filter the intersections given. -- The purpose of this function is to ensure we only count the crossing of a line (segment) across a contour's edge more than once. so if it hits a sttartpoint, make sure we don't count the endpoint.. etc. diff --git a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs index 49cef5869..9a33870ba 100644 --- a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs +++ b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs @@ -44,10 +44,11 @@ import Graphics.Slicer.Definitions (ℝ) import Graphics.Slicer.Math.Contour (pointsOfContour) -import Graphics.Slicer.Math.ContourIntersections (getMotorcycleContourIntersections) +import Graphics.Slicer.Math.ContourIntersections (getMotorcycleContourIntersections, getMotorcycleSegSetIntersections) + import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, mapWithNeighbors, startPoint, endPoint, makeLineSeg) -import Graphics.Slicer.Math.Intersections (getMotorcycleSegSetIntersections, intersectionOf, isAntiCollinear, noIntersection) +import Graphics.Slicer.Math.Intersections (intersectionOf, isAntiCollinear, noIntersection) import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, pPointBetweenPPoints, distanceBetweenPPoints, eToCPPoint2, eToPLine2, normalizePLine2, pToEPoint2) From b058235f2f045884bba2d9881bf440d5ebab2029 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 3 Dec 2022 20:04:00 +0000 Subject: [PATCH 124/206] move filterInntersections into ContourIntersections.hs. --- Graphics/Slicer/Math/ContourIntersections.hs | 76 +++++++++++++++++-- Graphics/Slicer/Math/Intersections.hs | 79 +------------------- 2 files changed, 75 insertions(+), 80 deletions(-) diff --git a/Graphics/Slicer/Math/ContourIntersections.hs b/Graphics/Slicer/Math/ContourIntersections.hs index f4b56618e..dfcb090be 100644 --- a/Graphics/Slicer/Math/ContourIntersections.hs +++ b/Graphics/Slicer/Math/ContourIntersections.hs @@ -25,21 +25,21 @@ module Graphics.Slicer.Math.ContourIntersections ( getMotorcycleSegSetIntersections ) where -import Prelude (Either(Left, Right), Int, Show(show), (<$>), (<>), ($), (/=), (&&), error, fst, length, odd, otherwise, zip) +import Prelude (Either(Left, Right), Int, Show(show), (<$>), (<>), ($), (/=), (&&), (<), (*), error, fst, length, odd, otherwise, zip) import Data.List (filter) -import Data.Maybe (Maybe(Just, Nothing), catMaybes) +import Data.Maybe (Maybe(Just, Nothing), catMaybes, fromJust, isJust) import Slist.Type (Slist) import Slist (len, slist) -import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, lineSegsOfContour, makeLineSeg, mapWithNeighbors) +import Graphics.Slicer.Definitions (ℝ) -import Graphics.Slicer.Math.Intersections (filterIntersections) +import Graphics.Slicer.Math.Definitions (Contour, LineSeg(endPoint, startPoint), Point2, distance, fudgeFactor, lineSegsOfContour, makeLineSeg, mapWithNeighbors) -import Graphics.Slicer.Math.PGA (CPPoint2, Intersection, NPLine2, PIntersection, PLine2Err, ProjectiveLine2, intersectsWithErr, normalizeL, outputIntersectsLineSeg, pToEP) +import Graphics.Slicer.Math.PGA (CPPoint2, Intersection(HitEndPoint, HitStartPoint, NoIntersection), NPLine2, PIntersection(IntersectsIn, PAntiCollinear, PAntiParallel, PCollinear, PParallel), PLine2Err, ProjectiveLine2, intersectsWithErr, normalizeL, outputIntersectsLineSeg, pToEP) import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle)) @@ -115,3 +115,69 @@ getMotorcycleSegSetIntersections m@(Motorcycle (inSeg, outSeg) _ _) segs = strip -- make sure neither of these segments are inSeg or outSeg fun (seg,_) = seg /= inSeg && seg /= outSeg +-- | filter the intersections given. +-- The purpose of this function is to ensure we only count the crossing of a line (segment) across a contour's edge more than once. so if it hits a sttartpoint, make sure we don't count the endpoint.. etc. +-- FIXME: does not take into account (anti)collinear line segments correctly. +filterIntersections :: Maybe (LineSeg, Either Intersection PIntersection) -> Maybe (LineSeg, Either Intersection PIntersection) -> Maybe (LineSeg, Either Intersection PIntersection) -> Maybe (LineSeg, Either Point2 CPPoint2) +filterIntersections _ (Just (seg, Right (IntersectsIn p _))) _ = Just (seg, Right p) +filterIntersections _ (Just (_ , Left (NoIntersection _ _))) _ = Nothing +filterIntersections _ (Just (_ , Right PParallel)) _ = Nothing +filterIntersections _ (Just (_ , Right PAntiParallel)) _ = Nothing +-- when we hit a end -> start -> end, look at the distance to tell where we hit. +filterIntersections (Just (seg1, Left (HitEndPoint l1 ))) (Just (seg2, Left (HitStartPoint _ ))) (Just (seg3 , Left (HitEndPoint l2))) + | distance (endPoint seg1) (startPoint seg2) < fudgeFactor*15 = Just (seg2, Left $ endPoint l1) + | distance (startPoint seg2) (endPoint seg3) < fudgeFactor*15 = Just (seg2, Left $ endPoint l2) + | otherwise = error "wtf" + -- only count the first start point, when going in one direction.. +filterIntersections _ (Just (seg , Left (HitStartPoint _ ))) (Just (_ , Left (HitEndPoint l1))) = Just (seg, Left $ endPoint l1) +filterIntersections (Just (_ , Left (HitStartPoint _ ))) (Just (_ , Left (HitEndPoint _ ))) _ = Nothing +-- and only count the first start point, when going in the other direction. +filterIntersections (Just (_ , Left (HitEndPoint l1 ))) (Just (seg , Left (HitStartPoint _ ))) _ = Just (seg, Left $ endPoint l1) +filterIntersections _ (Just (_ , Left (HitEndPoint _ ))) (Just (_ , Left (HitStartPoint _ ))) = Nothing +-- Ignore the end and start point that comes before / after a collinear section. +filterIntersections (Just (_, Right PCollinear )) (Just (_ , Left (HitStartPoint _ ))) _ = Nothing +filterIntersections _ (Just (_ , Left (HitEndPoint _ ))) (Just (_ , Right PCollinear )) = Nothing +filterIntersections (Just (_, Right PCollinear )) (Just (_ , Left (HitEndPoint _ ))) _ = Nothing +filterIntersections _ (Just (_ , Left (HitStartPoint _ ))) (Just (_ , Right PCollinear )) = Nothing +-- Ignore the end and start point that comes before / after an anticollinear section. +filterIntersections (Just (_, Right PAntiCollinear )) (Just (_ , Left (HitStartPoint _ ))) _ = Nothing +filterIntersections _ (Just (_ , Left (HitEndPoint _ ))) (Just (_ , Right PAntiCollinear )) = Nothing +filterIntersections (Just (_, Right PAntiCollinear )) (Just (_ , Left (HitEndPoint _ ))) _ = Nothing +filterIntersections _ (Just (_ , Left (HitStartPoint _ ))) (Just (_ , Right PAntiCollinear )) = Nothing +-- FIXME: we should return the (anti-)collinear segments so they can be stitched out, not just ignore them. +filterIntersections _ (Just (_ , Right PCollinear )) _ = Nothing +filterIntersections _ (Just (_ , Right PAntiCollinear )) _ = Nothing +-- And now handle the end segments, where there is nothing on the other side. +-- FIXME: these can't all be endpoint. +filterIntersections _ Nothing _ = Nothing +filterIntersections (Just (_ , Left (NoIntersection _ _))) (Just (seg , Left (HitEndPoint l1))) Nothing = Just (seg, Left $ endPoint l1) +filterIntersections Nothing (Just (seg , Left (HitEndPoint l1))) (Just (_ , Left (NoIntersection _ _))) = Just (seg, Left $ endPoint l1) +filterIntersections Nothing (Just (seg , Left (HitStartPoint l1))) (Just (_ , Left (NoIntersection _ _))) = Just (seg, Left $ startPoint l1) +filterIntersections (Just (_ , Left (NoIntersection _ _))) (Just (seg , Left (HitStartPoint l1))) Nothing = Just (seg, Left $ startPoint l1) +-- a segment, alone. +filterIntersections Nothing (Just (seg , Left (HitEndPoint l1))) Nothing = Just (seg, Left $ endPoint l1) +filterIntersections Nothing (Just (seg , Left (HitStartPoint l1))) Nothing = Just (seg, Left $ startPoint l1) +-- FIXME: what are these for? +filterIntersections Nothing (Just (seg , Left (HitStartPoint l1))) (Just (_ , Right _)) = Just (seg, Left $ startPoint l1) +filterIntersections Nothing (Just (seg , Left (HitEndPoint l1))) (Just (_ , Right _)) = Just (seg, Left $ endPoint l1) +filterIntersections (Just (_ , Right _)) (Just (seg , Left (HitStartPoint l1))) Nothing = Just (seg, Left $ startPoint l1) +filterIntersections (Just (_ , Right _)) (Just (seg , Left (HitEndPoint l1))) Nothing = Just (seg, Left $ endPoint l1) +filterIntersections l1 l2 l3 = error + $ "insane result of filterIntersections\n" + <> show l1 <> "\n" + <> (if isJust l1 + then "Endpoint: " <> show (endPoint $ lSeg $ fromJust l1) <> "\nLength: " <> show (lineLength $ fromJust l1) <> "\n" + else "") + <> show l2 <> "\n" + <> (if isJust l2 + then "Endpoint: " <> show (endPoint $ lSeg $ fromJust l2) <> "\nLength: " <> show (lineLength $ fromJust l2) <> "\n" + else "") + <> show l3 <> "\n" + <> (if isJust l3 + then "Endpoint: " <> show (endPoint $ lSeg $ fromJust l3) <> "\nLength: " <> show (lineLength $ fromJust l3) <> "\n" + else "") + where + lSeg :: (LineSeg, Either Intersection PIntersection) -> LineSeg + lSeg (myseg,_) = myseg + lineLength :: (LineSeg, Either Intersection PIntersection) -> ℝ + lineLength (mySeg, _) = distance (startPoint mySeg) (endPoint mySeg) diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index 370a54f4e..733c09d3f 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -18,86 +18,15 @@ {- Purpose of this file: to hold the logic and routines responsible for checking for intersections with contours, or portions of contours. -} -module Graphics.Slicer.Math.Intersections (filterIntersections, intersectionOf, intersectionBetween, noIntersection, isCollinear, isAntiCollinear, isParallel, isAntiParallel) where +module Graphics.Slicer.Math.Intersections (intersectionOf, intersectionBetween, noIntersection, isCollinear, isAntiCollinear, isParallel, isAntiParallel) where -import Prelude (Bool, Either(Left,Right), error, otherwise, show, (<>), ($), (<), (*), (||), (==), mempty, realToFrac) +import Prelude (Bool, Either(Left, Right), (<>), ($), (<), (||), (==), error, show, mempty, realToFrac) -import Data.Maybe (Maybe(Just,Nothing), isJust, fromJust) - -import Graphics.Slicer.Definitions (ℝ) - -import Graphics.Slicer.Math.Definitions (LineSeg, Point2, startPoint, distance, endPoint, fudgeFactor) +import Data.Maybe (Maybe(Just, Nothing)) import Graphics.Slicer.Math.GeometricAlgebra (ulpVal) -import Graphics.Slicer.Math.PGA (CPPoint2, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), Intersection(HitEndPoint, HitStartPoint, NoIntersection), PLine2, PLine2Err, PPoint2Err, ProjectiveLine2, distance2PL, plinesIntersectIn) - --- | filter the intersections given. --- The purpose of this function is to ensure we only count the crossing of a line (segment) across a contour's edge more than once. so if it hits a sttartpoint, make sure we don't count the endpoint.. etc. --- FIXME: does not take into account (anti)collinear line segments correctly. -filterIntersections :: Maybe (LineSeg, Either Intersection PIntersection) -> Maybe (LineSeg, Either Intersection PIntersection) -> Maybe (LineSeg, Either Intersection PIntersection) -> Maybe (LineSeg, Either Point2 CPPoint2) -filterIntersections _ (Just (seg, Right (IntersectsIn p _))) _ = Just (seg, Right p) -filterIntersections _ (Just (_ , Left (NoIntersection _ _))) _ = Nothing -filterIntersections _ (Just (_ , Right PParallel)) _ = Nothing -filterIntersections _ (Just (_ , Right PAntiParallel)) _ = Nothing --- when we hit a end -> start -> end, look at the distance to tell where we hit. -filterIntersections (Just (seg1, Left (HitEndPoint l1 ))) (Just (seg2, Left (HitStartPoint _ ))) (Just (seg3 , Left (HitEndPoint l2))) - | distance (endPoint seg1) (startPoint seg2) < fudgeFactor*15 = Just (seg2, Left $ endPoint l1) - | distance (startPoint seg2) (endPoint seg3) < fudgeFactor*15 = Just (seg2, Left $ endPoint l2) - | otherwise = error "wtf" - -- only count the first start point, when going in one direction.. -filterIntersections _ (Just (seg , Left (HitStartPoint _ ))) (Just (_ , Left (HitEndPoint l1))) = Just (seg, Left $ endPoint l1) -filterIntersections (Just (_ , Left (HitStartPoint _ ))) (Just (_ , Left (HitEndPoint _ ))) _ = Nothing --- and only count the first start point, when going in the other direction. -filterIntersections (Just (_ , Left (HitEndPoint l1 ))) (Just (seg , Left (HitStartPoint _ ))) _ = Just (seg, Left $ endPoint l1) -filterIntersections _ (Just (_ , Left (HitEndPoint _ ))) (Just (_ , Left (HitStartPoint _ ))) = Nothing --- Ignore the end and start point that comes before / after a collinear section. -filterIntersections (Just (_, Right PCollinear )) (Just (_ , Left (HitStartPoint _ ))) _ = Nothing -filterIntersections _ (Just (_ , Left (HitEndPoint _ ))) (Just (_ , Right PCollinear )) = Nothing -filterIntersections (Just (_, Right PCollinear )) (Just (_ , Left (HitEndPoint _ ))) _ = Nothing -filterIntersections _ (Just (_ , Left (HitStartPoint _ ))) (Just (_ , Right PCollinear )) = Nothing --- Ignore the end and start point that comes before / after an anticollinear section. -filterIntersections (Just (_, Right PAntiCollinear )) (Just (_ , Left (HitStartPoint _ ))) _ = Nothing -filterIntersections _ (Just (_ , Left (HitEndPoint _ ))) (Just (_ , Right PAntiCollinear )) = Nothing -filterIntersections (Just (_, Right PAntiCollinear )) (Just (_ , Left (HitEndPoint _ ))) _ = Nothing -filterIntersections _ (Just (_ , Left (HitStartPoint _ ))) (Just (_ , Right PAntiCollinear )) = Nothing --- FIXME: we should return the (anti-)collinear segments so they can be stitched out, not just ignore them. -filterIntersections _ (Just (_ , Right PCollinear )) _ = Nothing -filterIntersections _ (Just (_ , Right PAntiCollinear )) _ = Nothing --- And now handle the end segments, where there is nothing on the other side. --- FIXME: these can't all be endpoint. -filterIntersections _ Nothing _ = Nothing -filterIntersections (Just (_ , Left (NoIntersection _ _))) (Just (seg , Left (HitEndPoint l1))) Nothing = Just (seg, Left $ endPoint l1) -filterIntersections Nothing (Just (seg , Left (HitEndPoint l1))) (Just (_ , Left (NoIntersection _ _))) = Just (seg, Left $ endPoint l1) -filterIntersections Nothing (Just (seg , Left (HitStartPoint l1))) (Just (_ , Left (NoIntersection _ _))) = Just (seg, Left $ startPoint l1) -filterIntersections (Just (_ , Left (NoIntersection _ _))) (Just (seg , Left (HitStartPoint l1))) Nothing = Just (seg, Left $ startPoint l1) --- a segment, alone. -filterIntersections Nothing (Just (seg , Left (HitEndPoint l1))) Nothing = Just (seg, Left $ endPoint l1) -filterIntersections Nothing (Just (seg , Left (HitStartPoint l1))) Nothing = Just (seg, Left $ startPoint l1) --- FIXME: what are these for? -filterIntersections Nothing (Just (seg , Left (HitStartPoint l1))) (Just (_ , Right _)) = Just (seg, Left $ startPoint l1) -filterIntersections Nothing (Just (seg , Left (HitEndPoint l1))) (Just (_ , Right _)) = Just (seg, Left $ endPoint l1) -filterIntersections (Just (_ , Right _)) (Just (seg , Left (HitStartPoint l1))) Nothing = Just (seg, Left $ startPoint l1) -filterIntersections (Just (_ , Right _)) (Just (seg , Left (HitEndPoint l1))) Nothing = Just (seg, Left $ endPoint l1) -filterIntersections l1 l2 l3 = error - $ "insane result of filterIntersections\n" - <> show l1 <> "\n" - <> (if isJust l1 - then "Endpoint: " <> show (endPoint $ lSeg $ fromJust l1) <> "\nLength: " <> show (lineLength $ fromJust l1) <> "\n" - else "") - <> show l2 <> "\n" - <> (if isJust l2 - then "Endpoint: " <> show (endPoint $ lSeg $ fromJust l2) <> "\nLength: " <> show (lineLength $ fromJust l2) <> "\n" - else "") - <> show l3 <> "\n" - <> (if isJust l3 - then "Endpoint: " <> show (endPoint $ lSeg $ fromJust l3) <> "\nLength: " <> show (lineLength $ fromJust l3) <> "\n" - else "") - where - lSeg :: (LineSeg, Either Intersection PIntersection) -> LineSeg - lSeg (myseg,_) = myseg - lineLength :: (LineSeg, Either Intersection PIntersection) -> ℝ - lineLength (mySeg, _) = distance (startPoint mySeg) (endPoint mySeg) +import Graphics.Slicer.Math.PGA (CPPoint2, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), PLine2, PLine2Err, PPoint2Err, ProjectiveLine2, distance2PL, plinesIntersectIn) -- | Get the intersection point of two lines we know have an intersection point. intersectionOf :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> (CPPoint2, PPoint2Err) From f512815255edf954056be42897ddca7563419a84 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 3 Dec 2022 21:25:43 +0000 Subject: [PATCH 125/206] use concatMap. --- Graphics/Slicer/Math/ContourIntersections.hs | 13 ++++---- Graphics/Slicer/Math/Ganja.hs | 34 +++++++++++--------- 2 files changed, 24 insertions(+), 23 deletions(-) diff --git a/Graphics/Slicer/Math/ContourIntersections.hs b/Graphics/Slicer/Math/ContourIntersections.hs index dfcb090be..4df653ec5 100644 --- a/Graphics/Slicer/Math/ContourIntersections.hs +++ b/Graphics/Slicer/Math/ContourIntersections.hs @@ -58,7 +58,6 @@ contourIntersectionCount contour (start, end) = len $ getIntersections contour ( openCircuit v = Just <$> v -- | Get the intersections between a Line and a contour as a series of points. always returns an even number of intersections. --- FIXME: accept error on this first pLine! getLineContourIntersections :: (ProjectiveLine2 a) => (a, PLine2Err) -> Contour -> [Point2] getLineContourIntersections (line, lineErr) c | odd $ length res = error $ "odd number of transitions: " <> show (length res) <> "\n" <> show c <> "\n" <> show line <> "\n" <> show res <> "\n" @@ -71,12 +70,12 @@ getLineContourIntersections (line, lineErr) c targetLine :: Either LineSeg (NPLine2, PLine2Err) targetLine = Right (nLine, lineErr <> nLineErr) (nLine, nLineErr) = normalizeL line - openCircuit v = Just <$> v - getPoints :: [(LineSeg, Either Point2 CPPoint2)] -> [Point2] - getPoints vs = getPoint <$> vs - where - getPoint (_, Left v) = v - getPoint (_, Right v) = fst $ pToEP v + openCircuit v = Just <$> v + getPoints :: [(LineSeg, Either Point2 CPPoint2)] -> [Point2] + getPoints vs = getPoint <$> vs + where + getPoint (_, Left v) = v + getPoint (_, Right v) = fst $ pToEP v -- | Get all possible intersections between the motorcycle and the contour. -- Filters out the input and output segment of the motorcycle. diff --git a/Graphics/Slicer/Math/Ganja.hs b/Graphics/Slicer/Math/Ganja.hs index ba3bcd70e..b049c3b0d 100644 --- a/Graphics/Slicer/Math/Ganja.hs +++ b/Graphics/Slicer/Math/Ganja.hs @@ -83,16 +83,18 @@ module Graphics.Slicer.Math.Ganja ( GanjaAble, - toGanja, dumpGanja, - dumpGanjas + dumpGanjas, + toGanja ) where import Prelude (String, (<>), (<>), (<$>), ($), (>=), (==), (.), (/=), concat, error, fst, otherwise, show, snd, zip) +import Data.List (concatMap) + import Data.Maybe (Maybe(Nothing), catMaybes, maybeToList) -import Numeric(showFFloat) +import Numeric (showFFloat) import Slist.Type (Slist(Slist)) @@ -170,7 +172,7 @@ instance GanjaAble Contour where toGanja contour varname = (invars, inrefs) where contourPoints = pointsOfContour contour - (invars, inrefs) = (concat $ fst <$> res, concat (snd <$> res) <> " 0x882288,\n" <> linePairs) + (invars, inrefs) = (concatMap fst res, concatMap snd res <> " 0x882288,\n" <> linePairs) where linePairs = concat $ mapWithFollower (\(_,a) (_,b) -> " [" <> varname <> a <> "," <> varname <> b <> "],\n") pairs res = (\(a,b) -> toGanja a (varname <> b)) <$> pairs @@ -210,12 +212,12 @@ instance GanjaAble Motorcycle where instance GanjaAble Cell where toGanja (Cell segsDivides) varname = (invars, inrefs) where - (invars, inrefs) = (concat $ fst <$> res, concat $ snd <$> res) + (invars, inrefs) = (concatMap fst res, concatMap snd res) where res = (\(a,b) -> a (varname <> b)) <$> pairs pairs = zip allSides allStrings allStrings = [ c : s | s <- "": allStrings, c <- ['a'..'z'] <> ['0'..'9'] ] - allSegs = concat $ listFromSlist . fst <$> segsDivides + allSegs = concatMap (listFromSlist . fst) segsDivides allDivides = catMaybes $ listFromSlist $ snd <$> segsDivides allSides = (toGanja <$> allSegs) <> (toGanja <$> allDivides) listFromSlist (Slist a _) = a @@ -223,7 +225,7 @@ instance GanjaAble Cell where instance GanjaAble CellDivide where toGanja (CellDivide (DividingMotorcycles firstMotorcycle (Slist moreMotorcycles _)) _) varname = (invars, inrefs) where - (invars, inrefs) = (concat $ fst <$> res, concat $ snd <$> res) + (invars, inrefs) = (concatMap fst res, concatMap snd res) where res = (\(a,b) -> toGanja a (varname <> b)) <$> zip allMotorcycles allStrings allStrings = [ c : s | s <- "": allStrings, c <- ['a'..'z'] <> ['0'..'9'] ] @@ -232,20 +234,20 @@ instance GanjaAble CellDivide where instance GanjaAble RemainingContour where toGanja (RemainingContour (Slist segsDivides _)) varname = (invars, inrefs) where - (invars, inrefs) = (concat $ fst <$> res, concat $ snd <$> res) + (invars, inrefs) = (concatMap fst res, concatMap snd res) where res = (\(a,b) -> a (varname <> b)) <$> pairs pairs = zip allSides allStrings allStrings = [ c : s | s <- "": allStrings, c <- ['a'..'z'] <> ['0'..'9'] ] - allSegs = concat $ listFromSlist . fst <$> segsDivides - allDivides = concat $ snd <$> segsDivides + allSegs = concatMap (listFromSlist . fst) segsDivides + allDivides = concatMap snd segsDivides allSides = (toGanja <$> allSegs) <> (toGanja <$> allDivides) listFromSlist (Slist a _) = a instance GanjaAble INode where toGanja (INode firstPLine secondPLine (Slist rawMorePLines _) outPLine) varname = (invars, inrefs) where - (invars, inrefs) = (concat $ fst <$> res, concat $ snd <$> res) + (invars, inrefs) = (concatMap fst res, concatMap snd res) where res = (\(a,b) -> toGanja (fst a) (varname <> b)) <$> zip allPLines allStrings allStrings = [ c : s | s <- "": allStrings, c <- ['a'..'z'] <> ['0'..'9'] ] @@ -258,7 +260,7 @@ instance GanjaAble StraightSkeleton where instance GanjaAble NodeTree where toGanja (NodeTree (ENodeSet eNodeSides) iNodeSet) varname = (invars, inrefs) where - (invars, inrefs) = (concat $ fst <$> res, concat $ snd <$> res) + (invars, inrefs) = (concatMap fst res, concatMap snd res) where res = (\(a,b) -> a (varname <> b)) <$> pairs pairs = zip (allEdges <> allINodes) allStrings @@ -285,7 +287,7 @@ instance GanjaAble NodeTree where instance GanjaAble Face where toGanja (Face edge firstArc (Slist arcs _) lastArc) varname = (invars, inrefs) where - (invars, inrefs) = (concat $ fst <$> res, concat $ snd <$> res) + (invars, inrefs) = (concatMap fst res, concatMap snd res) where res = (\(a,b) -> a (varname <> b)) <$> pairs pairs = zip (toGanja edge : allPLines) allStrings @@ -295,9 +297,9 @@ instance GanjaAble Face where instance GanjaAble (Slist Face) where toGanja (Slist faces _) varname = (invars, inrefs) where - (invars, inrefs) = (concat $ fst <$> res, concat $ snd <$> res) + (invars, inrefs) = (concatMap fst res, concatMap snd res) where - allArcs = concat $ (\(Face _ firstArc (Slist arcs _) lastArc) -> [firstArc] <> arcs <> [lastArc]) <$> faces + allArcs = concatMap (\(Face _ firstArc (Slist arcs _) lastArc) -> [firstArc] <> arcs <> [lastArc]) faces allEdges = (\(Face edge _ _ _) -> toGanja edge) <$> faces res = (\(a,b) -> a (varname <> b)) <$> pairs pairs = zip (allEdges <> allPLines) allStrings @@ -312,7 +314,7 @@ dumpGanjas [f] = ganjaHeader <> vars <> ganjaFooterStart <> refs <> ganjaFooterE (vars, refs) = f "a" dumpGanjas xs = ganjaHeader <> vars <> ganjaFooterStart <> refs <> ganjaFooterEnd where - (vars, refs) = (concat $ fst <$> res, concat $ snd <$> res) + (vars, refs) = (concatMap fst res, concatMap snd res) where res = (\(a,b) -> a b) <$> zip xs allStrings allStrings = [ c : s | s <- "": allStrings, c <- ['a'..'z'] <> ['0'..'9'] ] From c4531967c6eb9d28b02a2b9c5457e59d5b0fb15a Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 3 Dec 2022 22:39:40 +0000 Subject: [PATCH 126/206] clean up LANGUAGE pragmas. --- Graphics/Slicer/Math/Ganja.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/Graphics/Slicer/Math/Ganja.hs b/Graphics/Slicer/Math/Ganja.hs index b049c3b0d..50023bd36 100644 --- a/Graphics/Slicer/Math/Ganja.hs +++ b/Graphics/Slicer/Math/Ganja.hs @@ -74,12 +74,8 @@ cut, and paste the output into https://enkimute.github.io/ganja.js/examples/coffeeshop.html, click 'Run' -} +-- loosen some instance restrictions, so we can work with String and others. {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ParallelListComp #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - --- so we can define a Num instance for Positive. -{-# OPTIONS_GHC -Wno-orphans #-} module Graphics.Slicer.Math.Ganja ( GanjaAble, @@ -115,6 +111,9 @@ import Graphics.Slicer.Math.Skeleton.Face(Face(Face)) class GanjaAble a where toGanja :: a -> String -> (String, String) +instance GanjaAble String where + toGanja string varname = (" // " <> varname <> " -- " <> string <> "\n","") + instance GanjaAble Point2 where toGanja (Point2 (x,y)) varname = ( " var " <> varname <> " = point(" <> showFullPrecision x <> "," <> showFullPrecision y <> ");\n", From d9dc2d7244a75e116995f84458c4e86fcf83ea1c Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 3 Dec 2022 23:42:36 +0000 Subject: [PATCH 127/206] add an instance for PPoint2, PPoint2Err, and simplify instances by using vecOfP and vecOfL. --- Graphics/Slicer/Math/Ganja.hs | 32 ++++++++++++++++++++++++++------ Graphics/Slicer/Math/PGA.hs | 3 ++- 2 files changed, 28 insertions(+), 7 deletions(-) diff --git a/Graphics/Slicer/Math/Ganja.hs b/Graphics/Slicer/Math/Ganja.hs index 50023bd36..eb5dc1361 100644 --- a/Graphics/Slicer/Math/Ganja.hs +++ b/Graphics/Slicer/Math/Ganja.hs @@ -88,7 +88,7 @@ import Prelude (String, (<>), (<>), (<$>), ($), (>=), (==), (.), (/=), concat, e import Data.List (concatMap) -import Data.Maybe (Maybe(Nothing), catMaybes, maybeToList) +import Data.Maybe (Maybe(Nothing), catMaybes) import Numeric (showFFloat) @@ -102,7 +102,7 @@ import Graphics.Slicer.Math.Definitions (Contour, Point2(Point2), LineSeg, endPo import Graphics.Slicer.Math.GeometricAlgebra (GNum(GEPlus, GEZero), GVec(GVec), getVal, valOf) -import Graphics.Slicer.Math.PGA (PLine2(PLine2), PPoint2(PPoint2), outOf) +import Graphics.Slicer.Math.PGA (PLine2, PPoint2, PPoint2Err, hasArc, outAndErrOf, outOf, vecOfL, vecOfP) import Graphics.Slicer.Math.Skeleton.Definitions(Cell(Cell), ENode, ENodeSet(ENodeSet), INode(INode), INodeSet(INodeSet), Motorcycle(Motorcycle), NodeTree(NodeTree), StraightSkeleton(StraightSkeleton), RemainingContour(RemainingContour), CellDivide(CellDivide), DividingMotorcycles(DividingMotorcycles), getFirstLineSeg, getLastLineSeg) @@ -136,7 +136,7 @@ instance GanjaAble LineSeg where (p2var, p2ref) = toGanja (endPoint l1) (varname <> "b") instance GanjaAble PPoint2 where - toGanja (PPoint2 (GVec vals)) varname = ( + toGanja point varname = ( " var " <> varname <> " = " <> showFullPrecision (valOf 0 (getVal [GEPlus 1, GEPlus 2] vals)) <> "e12" <> (if e02 >= 0 then "+" <> showFullPrecision e02 else showFullPrecision e02) @@ -150,9 +150,28 @@ instance GanjaAble PPoint2 where e01 = valOf 0 (getVal [GEZero 1, GEPlus 1] vals) -- because ganja's website does not handle scientific notation. showFullPrecision v = showFFloat Nothing v "" + (GVec vals) = vecOfP point + +instance GanjaAble (PPoint2, PPoint2Err) where + toGanja (point, pointErr) varname = ( + " var " <> varname <> " = " + <> showFullPrecision (valOf 0 (getVal [GEPlus 1, GEPlus 2] vals)) <> "e12" + <> (if e02 >= 0 then "+" <> showFullPrecision e02 else showFullPrecision e02) + <> "e02" + <> (if e01 >= 0 then "+" <> showFullPrecision e01 else showFullPrecision e01) + <> "e01;\n" + <> "// " <> show pointErr <> "\n" + , + " " <> varname <> ", " <> show varname <> ",\n") + where + e02 = valOf 0 (getVal [GEZero 1, GEPlus 2] vals) + e01 = valOf 0 (getVal [GEZero 1, GEPlus 1] vals) + -- because ganja's website does not handle scientific notation. + showFullPrecision v = showFFloat Nothing v "" + (GVec vals) = vecOfP point instance GanjaAble PLine2 where - toGanja (PLine2 (GVec vals)) varname = ( + toGanja line varname = ( " var " <> varname <> " = " <> showFullPrecision (valOf 0 (getVal [GEPlus 1] vals)) <> "e1" <> (if e2 >= 0 then "+" <> showFullPrecision e2 else showFullPrecision e2) @@ -166,6 +185,7 @@ instance GanjaAble PLine2 where e0 = valOf 0 (getVal [GEZero 1] vals) -- because ganja's website does not handle scientific notation. showFullPrecision v = showFFloat Nothing v "" + (GVec vals) = vecOfL line instance GanjaAble Contour where toGanja contour varname = (invars, inrefs) @@ -244,13 +264,13 @@ instance GanjaAble RemainingContour where listFromSlist (Slist a _) = a instance GanjaAble INode where - toGanja (INode firstPLine secondPLine (Slist rawMorePLines _) outPLine) varname = (invars, inrefs) + toGanja iNode@(INode firstPLine secondPLine (Slist rawMorePLines _) _) varname = (invars, inrefs) where (invars, inrefs) = (concatMap fst res, concatMap snd res) where res = (\(a,b) -> toGanja (fst a) (varname <> b)) <$> zip allPLines allStrings allStrings = [ c : s | s <- "": allStrings, c <- ['a'..'z'] <> ['0'..'9'] ] - allPLines = firstPLine:secondPLine:rawMorePLines <> maybeToList outPLine + allPLines = firstPLine:secondPLine:rawMorePLines <> (if hasArc iNode then [outAndErrOf iNode] else []) instance GanjaAble StraightSkeleton where toGanja (StraightSkeleton (Slist [[nodetree]] _) _) = toGanja nodetree diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index ef06e1e04..c630bad84 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -71,7 +71,8 @@ module Graphics.Slicer.Math.PGA( pToEP, plinesIntersectIn, translateL, - translateRotatePPoint2WithErr + translateRotatePPoint2WithErr, + vecOfP ) where import Prelude (Bool, Eq((==)), Monoid(mempty), Semigroup((<>)), Show(show), ($), (-), (>=), (&&), (<$>), otherwise, signum, (>), (<=), (+), negate, (/), (||), (<), abs, error, sin, cos, realToFrac) From 78473624d16e95ba6d4e32e2321917e75ac2e279 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 4 Dec 2022 00:53:16 +0000 Subject: [PATCH 128/206] reorder Intersections. --- Graphics/Slicer/Math/Ganja.hs | 8 ++--- Graphics/Slicer/Math/GeometricAlgebra.hs | 4 +-- Graphics/Slicer/Math/Intersections.hs | 39 ++++++++++++------------ 3 files changed, 26 insertions(+), 25 deletions(-) diff --git a/Graphics/Slicer/Math/Ganja.hs b/Graphics/Slicer/Math/Ganja.hs index eb5dc1361..34f7da4bb 100644 --- a/Graphics/Slicer/Math/Ganja.hs +++ b/Graphics/Slicer/Math/Ganja.hs @@ -123,7 +123,7 @@ instance GanjaAble Point2 where showFullPrecision v = showFFloat Nothing v "" instance GanjaAble LineSeg where - toGanja l1 varname = ( + toGanja lineSeg varname = ( p1var <> p2var, " 0x882288,\n" @@ -132,8 +132,8 @@ instance GanjaAble LineSeg where <> p1ref <> p2ref) where - (p1var, p1ref) = toGanja (startPoint l1) (varname <> "a") - (p2var, p2ref) = toGanja (endPoint l1) (varname <> "b") + (p1var, p1ref) = toGanja (startPoint lineSeg) (varname <> "a") + (p2var, p2ref) = toGanja (endPoint lineSeg) (varname <> "b") instance GanjaAble PPoint2 where toGanja point varname = ( @@ -248,7 +248,7 @@ instance GanjaAble CellDivide where where res = (\(a,b) -> toGanja a (varname <> b)) <$> zip allMotorcycles allStrings allStrings = [ c : s | s <- "": allStrings, c <- ['a'..'z'] <> ['0'..'9'] ] - allMotorcycles = firstMotorcycle:moreMotorcycles + allMotorcycles = firstMotorcycle:moreMotorcycles instance GanjaAble RemainingContour where toGanja (RemainingContour (Slist segsDivides _)) varname = (invars, inrefs) diff --git a/Graphics/Slicer/Math/GeometricAlgebra.hs b/Graphics/Slicer/Math/GeometricAlgebra.hs index aca67746b..5007a79f1 100644 --- a/Graphics/Slicer/Math/GeometricAlgebra.hs +++ b/Graphics/Slicer/Math/GeometricAlgebra.hs @@ -58,14 +58,14 @@ module Graphics.Slicer.Math.GeometricAlgebra( hpDivVecScalar, mulScalarVecWithErr, reduceVecPair, + scalarPart, subVal, subValPairWithErr, subVecPair, sumErrVals, - valOf, - scalarPart, ulpVal, unlikeVecPair, + valOf, vectorPart ) where diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index 733c09d3f..9fb74ece1 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -28,6 +28,26 @@ import Graphics.Slicer.Math.GeometricAlgebra (ulpVal) import Graphics.Slicer.Math.PGA (CPPoint2, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), PLine2, PLine2Err, PPoint2Err, ProjectiveLine2, distance2PL, plinesIntersectIn) +-- | check if two lines cannot intersect. +noIntersection :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Bool +noIntersection pline1@(pl1,_) pline2@(pl2,_) = isCollinear pline1 pline2 || isParallel pl1 pl2 || isAntiCollinear pline1 pline2 || isAntiParallel pl1 pl2 + +-- | check if two lines are really the same line. +isCollinear :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Bool +isCollinear pline1 pline2 = plinesIntersectIn pline1 pline2 == PCollinear + +-- | check if two lines are really the same line. +isAntiCollinear :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Bool +isAntiCollinear pline1 pline2 = plinesIntersectIn pline1 pline2 == PAntiCollinear + +-- | check if two lines are parallel. +isParallel :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Bool +isParallel pline1 pline2 = plinesIntersectIn (pline1, mempty) (pline2, mempty) == PParallel + +-- | check if two lines are anti-parallel. +isAntiParallel :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Bool +isAntiParallel pline1 pline2 = plinesIntersectIn (pline1, mempty) (pline2, mempty) == PAntiParallel + -- | Get the intersection point of two lines we know have an intersection point. intersectionOf :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> (CPPoint2, PPoint2Err) intersectionOf pl1 pl2 = saneIntersection $ plinesIntersectIn pl1 pl2 @@ -53,22 +73,3 @@ intersectionBetween pl1 pl2 = saneIntersection $ plinesIntersectIn (pl1,mempty) else Nothing saneIntersection (IntersectsIn p (_,_, pErr)) = Just $ Right (p,pErr) --- | check if two lines cannot intersect. -noIntersection :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Bool -noIntersection pline1@(pl1,_) pline2@(pl2,_) = isCollinear pline1 pline2 || isParallel pl1 pl2 || isAntiCollinear pline1 pline2 || isAntiParallel pl1 pl2 - --- | check if two lines are really the same line. -isCollinear :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Bool -isCollinear pline1 pline2 = plinesIntersectIn pline1 pline2 == PCollinear - --- | check if two lines are really the same line. -isAntiCollinear :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Bool -isAntiCollinear pline1 pline2 = plinesIntersectIn pline1 pline2 == PAntiCollinear - --- | check if two lines are parallel. -isParallel :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Bool -isParallel pline1 pline2 = plinesIntersectIn (pline1, mempty) (pline2, mempty) == PParallel - --- | check if two lines are anti-parallel. -isAntiParallel :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Bool -isAntiParallel pline1 pline2 = plinesIntersectIn (pline1, mempty) (pline2, mempty) == PAntiParallel From c97a049b3a7e625035900cac1351f15af4e53b6a Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 4 Dec 2022 01:57:24 +0000 Subject: [PATCH 129/206] formatting changes, and make isParallel accept error quotents. --- Graphics/Slicer/Math/Intersections.hs | 20 ++++++++++++++------ Graphics/Slicer/Math/Skeleton/Concave.hs | 2 +- 2 files changed, 15 insertions(+), 7 deletions(-) diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index 9fb74ece1..f65f70cc7 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -18,7 +18,15 @@ {- Purpose of this file: to hold the logic and routines responsible for checking for intersections with contours, or portions of contours. -} -module Graphics.Slicer.Math.Intersections (intersectionOf, intersectionBetween, noIntersection, isCollinear, isAntiCollinear, isParallel, isAntiParallel) where +module Graphics.Slicer.Math.Intersections ( + intersectionBetween, + intersectionOf, + isAntiCollinear, + isAntiParallel, + isCollinear, + isParallel, + noIntersection + ) where import Prelude (Bool, Either(Left, Right), (<>), ($), (<), (||), (==), error, show, mempty, realToFrac) @@ -30,7 +38,7 @@ import Graphics.Slicer.Math.PGA (CPPoint2, PIntersection(IntersectsIn, PParallel -- | check if two lines cannot intersect. noIntersection :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Bool -noIntersection pline1@(pl1,_) pline2@(pl2,_) = isCollinear pline1 pline2 || isParallel pl1 pl2 || isAntiCollinear pline1 pline2 || isAntiParallel pl1 pl2 +noIntersection pline1@(pl1,_) pline2@(pl2,_) = isCollinear pline1 pline2 || isParallel pline1 pline2 || isAntiCollinear pline1 pline2 || isAntiParallel pl1 pl2 -- | check if two lines are really the same line. isCollinear :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Bool @@ -41,8 +49,8 @@ isAntiCollinear :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> ( isAntiCollinear pline1 pline2 = plinesIntersectIn pline1 pline2 == PAntiCollinear -- | check if two lines are parallel. -isParallel :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Bool -isParallel pline1 pline2 = plinesIntersectIn (pline1, mempty) (pline2, mempty) == PParallel +isParallel :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Bool +isParallel pline1 pline2 = plinesIntersectIn pline1 pline2 == PParallel -- | check if two lines are anti-parallel. isAntiParallel :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Bool @@ -60,7 +68,7 @@ intersectionOf pl1 pl2 = saneIntersection $ plinesIntersectIn pl1 pl2 -- | Get the intersection point of two lines. intersectionBetween :: PLine2 -> PLine2 -> Maybe (Either PLine2 (CPPoint2, PPoint2Err)) -intersectionBetween pl1 pl2 = saneIntersection $ plinesIntersectIn (pl1,mempty) (pl2,mempty) +intersectionBetween pl1 pl2 = saneIntersection $ plinesIntersectIn (pl1, mempty) (pl2, mempty) where (foundDistance, (_,_, foundErr)) = distance2PL pl1 pl2 saneIntersection PAntiCollinear = Just $ Left pl1 @@ -71,5 +79,5 @@ intersectionBetween pl1 pl2 = saneIntersection $ plinesIntersectIn (pl1,mempty) saneIntersection PAntiParallel = if foundDistance < realToFrac (ulpVal foundErr) then Just $ Left pl1 else Nothing - saneIntersection (IntersectsIn p (_,_, pErr)) = Just $ Right (p,pErr) + saneIntersection (IntersectsIn p (_,_, pErr)) = Just $ Right (p, pErr) diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index f4802dc1d..517cca90d 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -175,7 +175,7 @@ averageNodes :: (Arcable a, Pointable a, Arcable b, Pointable b) => a -> b -> IN averageNodes n1 n2 | not (hasArc n1) || not (hasArc n2) = error $ "Cannot get the average of nodes if one of the nodes does not have an out!\n" <> dumpInput | not (canPoint n1) || not (canPoint n2) = error $ "Cannot get the average of nodes if we cannot resolve them to a point!\n" <> dumpInput - | isParallel (outOf n1) (outOf n2) = error $ "Cannot get the average of nodes if their outputs never intersect!\n" <> dumpInput + | isParallel (outAndErrOf n1) (outAndErrOf n2) = error $ "Cannot get the average of nodes if their outputs never intersect!\n" <> dumpInput | isCollinear (outAndErrOf n1) (outAndErrOf n2) = error $ "Cannot (yet) handle two input plines that are collinear.\n" <> dumpInput | nodesAreAntiCollinear n1 n2 = error $ "Cannot (yet) handle two input plines that are collinear.\n" <> dumpInput | n1Distance < getRounded n1Err = error $ "intersection is AT the point of n1!\n" <> dumpInput From 9444ee9021b845e909e8998e0ce4c248c57ca3db Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 4 Dec 2022 13:28:08 +0000 Subject: [PATCH 130/206] make isAntiParallel accept error quotents, and change variable names. --- Graphics/Slicer/Math/Intersections.hs | 34 ++++++++++++------------ Graphics/Slicer/Math/Skeleton/Concave.hs | 5 ++-- 2 files changed, 20 insertions(+), 19 deletions(-) diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index f65f70cc7..730a19df8 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -38,46 +38,46 @@ import Graphics.Slicer.Math.PGA (CPPoint2, PIntersection(IntersectsIn, PParallel -- | check if two lines cannot intersect. noIntersection :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Bool -noIntersection pline1@(pl1,_) pline2@(pl2,_) = isCollinear pline1 pline2 || isParallel pline1 pline2 || isAntiCollinear pline1 pline2 || isAntiParallel pl1 pl2 +noIntersection line1 line2 = isCollinear line1 line2 || isParallel line1 line2 || isAntiCollinear line1 line2 || isAntiParallel line1 line2 -- | check if two lines are really the same line. isCollinear :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Bool -isCollinear pline1 pline2 = plinesIntersectIn pline1 pline2 == PCollinear +isCollinear line1 line2 = plinesIntersectIn line1 line2 == PCollinear -- | check if two lines are really the same line. isAntiCollinear :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Bool -isAntiCollinear pline1 pline2 = plinesIntersectIn pline1 pline2 == PAntiCollinear +isAntiCollinear line1 line2 = plinesIntersectIn line1 line2 == PAntiCollinear -- | check if two lines are parallel. isParallel :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Bool -isParallel pline1 pline2 = plinesIntersectIn pline1 pline2 == PParallel +isParallel line1 line2 = plinesIntersectIn line1 line2 == PParallel -- | check if two lines are anti-parallel. -isAntiParallel :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Bool -isAntiParallel pline1 pline2 = plinesIntersectIn (pline1, mempty) (pline2, mempty) == PAntiParallel +isAntiParallel :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Bool +isAntiParallel line1 line2 = plinesIntersectIn line1 line2 == PAntiParallel -- | Get the intersection point of two lines we know have an intersection point. intersectionOf :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> (CPPoint2, PPoint2Err) -intersectionOf pl1 pl2 = saneIntersection $ plinesIntersectIn pl1 pl2 +intersectionOf line1 line2 = saneIntersection $ plinesIntersectIn line1 line2 where - saneIntersection PAntiCollinear = error $ "cannot get the intersection of anti-collinear lines.\npl1: " <> show pl1 <> "\npl2: " <> show pl2 <> "\n" - saneIntersection PCollinear = error $ "cannot get the intersection of collinear lines.\npl1: " <> show pl1 <> "\npl2: " <> show pl2 <> "\n" - saneIntersection PParallel = error $ "cannot get the intersection of parallel lines.\npl1: " <> show pl1 <> "\npl2: " <> show pl2 <> "\n" - saneIntersection PAntiParallel = error $ "cannot get the intersection of antiparallel lines.\npl1: " <> show pl1 <> "\npl2: " <> show pl2 <> "\n" + saneIntersection PAntiCollinear = error $ "cannot get the intersection of anti-collinear lines.\nline1: " <> show line1 <> "\nline2: " <> show line2 <> "\n" + saneIntersection PCollinear = error $ "cannot get the intersection of collinear lines.\nline1: " <> show line1 <> "\nline2: " <> show line2 <> "\n" + saneIntersection PParallel = error $ "cannot get the intersection of parallel lines.\nline1: " <> show line1 <> "\nline2: " <> show line2 <> "\n" + saneIntersection PAntiParallel = error $ "cannot get the intersection of antiparallel lines.\nline1: " <> show line1 <> "\nline2: " <> show line2 <> "\n" saneIntersection (IntersectsIn p (_,_, pErr)) = (p,pErr) -- | Get the intersection point of two lines. intersectionBetween :: PLine2 -> PLine2 -> Maybe (Either PLine2 (CPPoint2, PPoint2Err)) -intersectionBetween pl1 pl2 = saneIntersection $ plinesIntersectIn (pl1, mempty) (pl2, mempty) +intersectionBetween line1 line2 = saneIntersection $ plinesIntersectIn (line1, mempty) (line2, mempty) where - (foundDistance, (_,_, foundErr)) = distance2PL pl1 pl2 - saneIntersection PAntiCollinear = Just $ Left pl1 - saneIntersection PCollinear = Just $ Left pl1 + (foundDistance, (_,_, foundErr)) = distance2PL line1 line2 + saneIntersection PAntiCollinear = Just $ Left line1 + saneIntersection PCollinear = Just $ Left line1 saneIntersection PParallel = if foundDistance < realToFrac (ulpVal foundErr) - then Just $ Left pl1 + then Just $ Left line1 else Nothing saneIntersection PAntiParallel = if foundDistance < realToFrac (ulpVal foundErr) - then Just $ Left pl1 + then Just $ Left line1 else Nothing saneIntersection (IntersectsIn p (_,_, pErr)) = Just $ Right (p, pErr) diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index 517cca90d..701680408 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -34,7 +34,7 @@ import Prelude as PL (head, last, tail, init) import Data.Either (lefts,rights) -import Data.Maybe( Maybe(Just,Nothing), catMaybes, fromMaybe, isJust, isNothing, mapMaybe) +import Data.Maybe (Maybe(Just,Nothing), catMaybes, fromMaybe, isJust, isNothing, mapMaybe) import Data.List (takeWhile, dropWhile, sortBy, nub) @@ -58,7 +58,7 @@ import Graphics.Slicer.Math.Definitions (Contour, LineSeg(LineSeg), Point2, endP import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum)) -import Graphics.Slicer.Math.Intersections (intersectionOf, intersectionBetween, isCollinear, isParallel, isAntiCollinear, noIntersection) +import Graphics.Slicer.Math.Intersections (intersectionBetween, intersectionOf, isAntiCollinear, isAntiParallel, isCollinear, isParallel, noIntersection) import Graphics.Slicer.Math.Lossy as Lossy (distancePPointToPLine) @@ -176,6 +176,7 @@ averageNodes n1 n2 | not (hasArc n1) || not (hasArc n2) = error $ "Cannot get the average of nodes if one of the nodes does not have an out!\n" <> dumpInput | not (canPoint n1) || not (canPoint n2) = error $ "Cannot get the average of nodes if we cannot resolve them to a point!\n" <> dumpInput | isParallel (outAndErrOf n1) (outAndErrOf n2) = error $ "Cannot get the average of nodes if their outputs never intersect!\n" <> dumpInput + | isAntiParallel (outAndErrOf n1) (outAndErrOf n2) = error $ "Cannot get the average of nodes if their outputs never intersect!\n" <> dumpInput | isCollinear (outAndErrOf n1) (outAndErrOf n2) = error $ "Cannot (yet) handle two input plines that are collinear.\n" <> dumpInput | nodesAreAntiCollinear n1 n2 = error $ "Cannot (yet) handle two input plines that are collinear.\n" <> dumpInput | n1Distance < getRounded n1Err = error $ "intersection is AT the point of n1!\n" <> dumpInput From 6a05cac5f831ea4af42eff68780817055320ca27 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 4 Dec 2022 13:52:37 +0000 Subject: [PATCH 131/206] comment fixes and spacing changes. --- Graphics/Slicer/Math/Intersections.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index 730a19df8..f8021b1b8 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -36,23 +36,23 @@ import Graphics.Slicer.Math.GeometricAlgebra (ulpVal) import Graphics.Slicer.Math.PGA (CPPoint2, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), PLine2, PLine2Err, PPoint2Err, ProjectiveLine2, distance2PL, plinesIntersectIn) --- | check if two lines cannot intersect. +-- | Check if two lines cannot intersect. noIntersection :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Bool noIntersection line1 line2 = isCollinear line1 line2 || isParallel line1 line2 || isAntiCollinear line1 line2 || isAntiParallel line1 line2 --- | check if two lines are really the same line. +-- | Check if two lines are really the same line. isCollinear :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Bool isCollinear line1 line2 = plinesIntersectIn line1 line2 == PCollinear --- | check if two lines are really the same line. +-- | Check if two lines are really the same line, reversed. isAntiCollinear :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Bool isAntiCollinear line1 line2 = plinesIntersectIn line1 line2 == PAntiCollinear --- | check if two lines are parallel. +-- | Check if two lines are parallel. isParallel :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Bool isParallel line1 line2 = plinesIntersectIn line1 line2 == PParallel --- | check if two lines are anti-parallel. +-- | Check if two lines are anti-parallel. isAntiParallel :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Bool isAntiParallel line1 line2 = plinesIntersectIn line1 line2 == PAntiParallel @@ -64,7 +64,7 @@ intersectionOf line1 line2 = saneIntersection $ plinesIntersectIn line1 line2 saneIntersection PCollinear = error $ "cannot get the intersection of collinear lines.\nline1: " <> show line1 <> "\nline2: " <> show line2 <> "\n" saneIntersection PParallel = error $ "cannot get the intersection of parallel lines.\nline1: " <> show line1 <> "\nline2: " <> show line2 <> "\n" saneIntersection PAntiParallel = error $ "cannot get the intersection of antiparallel lines.\nline1: " <> show line1 <> "\nline2: " <> show line2 <> "\n" - saneIntersection (IntersectsIn p (_,_, pErr)) = (p,pErr) + saneIntersection (IntersectsIn p (_,_, pErr)) = (p, pErr) -- | Get the intersection point of two lines. intersectionBetween :: PLine2 -> PLine2 -> Maybe (Either PLine2 (CPPoint2, PPoint2Err)) From a5d962c4109347e6b6e350107ac006e7a68b2979 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 4 Dec 2022 15:53:18 +0000 Subject: [PATCH 132/206] make intersectionBetween accept error components, and use the ProjectiveLine2 typeclass. --- Graphics/Slicer/Math/ContourIntersections.hs | 1 + Graphics/Slicer/Math/Intersections.hs | 22 +++++++++++--------- Graphics/Slicer/Math/Skeleton/Concave.hs | 4 ++-- 3 files changed, 15 insertions(+), 12 deletions(-) diff --git a/Graphics/Slicer/Math/ContourIntersections.hs b/Graphics/Slicer/Math/ContourIntersections.hs index 4df653ec5..11191519b 100644 --- a/Graphics/Slicer/Math/ContourIntersections.hs +++ b/Graphics/Slicer/Math/ContourIntersections.hs @@ -67,6 +67,7 @@ getLineContourIntersections (line, lineErr) c where segs :: [Either LineSeg (NPLine2, PLine2Err)] segs = Left <$> lineSegsOfContour c + -- FIXME: why do we have to use a concrete type here? targetLine :: Either LineSeg (NPLine2, PLine2Err) targetLine = Right (nLine, lineErr <> nLineErr) (nLine, nLineErr) = normalizeL line diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index f8021b1b8..98cbbcb51 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -16,7 +16,9 @@ - along with this program. If not, see . -} -{- Purpose of this file: to hold the logic and routines responsible for checking for intersections with contours, or portions of contours. -} +{- + Purpose of this file: This file contains code for retrieving and reasoning about the intersection of two projective lines. +-} module Graphics.Slicer.Math.Intersections ( intersectionBetween, @@ -28,13 +30,13 @@ module Graphics.Slicer.Math.Intersections ( noIntersection ) where -import Prelude (Bool, Either(Left, Right), (<>), ($), (<), (||), (==), error, show, mempty, realToFrac) +import Prelude (Bool, Either(Left, Right), (<>), ($), (<), (||), (==), error, show, realToFrac) import Data.Maybe (Maybe(Just, Nothing)) import Graphics.Slicer.Math.GeometricAlgebra (ulpVal) -import Graphics.Slicer.Math.PGA (CPPoint2, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), PLine2, PLine2Err, PPoint2Err, ProjectiveLine2, distance2PL, plinesIntersectIn) +import Graphics.Slicer.Math.PGA (CPPoint2, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), PLine2Err, PPoint2Err, ProjectiveLine2, distance2PL, plinesIntersectIn) -- | Check if two lines cannot intersect. noIntersection :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Bool @@ -67,17 +69,17 @@ intersectionOf line1 line2 = saneIntersection $ plinesIntersectIn line1 line2 saneIntersection (IntersectsIn p (_,_, pErr)) = (p, pErr) -- | Get the intersection point of two lines. -intersectionBetween :: PLine2 -> PLine2 -> Maybe (Either PLine2 (CPPoint2, PPoint2Err)) -intersectionBetween line1 line2 = saneIntersection $ plinesIntersectIn (line1, mempty) (line2, mempty) +intersectionBetween :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Maybe (Either a (CPPoint2, PPoint2Err)) +intersectionBetween line1@(l1, _) line2@(l2, _) = saneIntersection $ plinesIntersectIn line1 line2 where - (foundDistance, (_,_, foundErr)) = distance2PL line1 line2 - saneIntersection PAntiCollinear = Just $ Left line1 - saneIntersection PCollinear = Just $ Left line1 + (foundDistance, (_,_, foundErr)) = distance2PL l1 l2 + saneIntersection PAntiCollinear = Just $ Left l1 + saneIntersection PCollinear = Just $ Left l1 saneIntersection PParallel = if foundDistance < realToFrac (ulpVal foundErr) - then Just $ Left line1 + then Just $ Left l1 else Nothing saneIntersection PAntiParallel = if foundDistance < realToFrac (ulpVal foundErr) - then Just $ Left line1 + then Just $ Left l1 else Nothing saneIntersection (IntersectsIn p (_,_, pErr)) = Just $ Right (p, pErr) diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index 701680408..d8fc7b744 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -629,8 +629,8 @@ skeletonOfNodes connectedLoop inSegSets iNodes = | and $ isJust <$> intersections = and $ pointsCloseEnough <> linesCloseEnough | otherwise = False where - intersections = mapWithFollower intersectionBetween ((outOf <$> nonAntiCollinearNodes eNodes (antiCollinearNodePairsOf eNodes) <> firstAntiCollinearNodes (antiCollinearNodePairsOf eNodes)) <> - (outOf <$> nonAntiCollinearNodes iNodes (antiCollinearNodePairsOf iNodes) <> firstAntiCollinearNodes (antiCollinearNodePairsOf iNodes))) + intersections = mapWithFollower intersectionBetween ((outAndErrOf <$> nonAntiCollinearNodes eNodes (antiCollinearNodePairsOf eNodes) <> firstAntiCollinearNodes (antiCollinearNodePairsOf eNodes)) <> + (outAndErrOf <$> nonAntiCollinearNodes iNodes (antiCollinearNodePairsOf iNodes) <> firstAntiCollinearNodes (antiCollinearNodePairsOf iNodes))) pointIntersections = rights $ catMaybes intersections lineIntersections = lefts $ catMaybes intersections pointsCloseEnough = mapWithFollower pairCloseEnough pointIntersections From 871bcf0ec24a14baf77cbc3b882a0bce490b3157 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 4 Dec 2022 16:11:34 +0000 Subject: [PATCH 133/206] add error quotent to both sides of the returned value from intersectionBetween. --- Graphics/Slicer/Math/Intersections.hs | 10 +++++----- Graphics/Slicer/Math/Skeleton/Concave.hs | 4 ++-- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index 98cbbcb51..e6d3ced9b 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -69,17 +69,17 @@ intersectionOf line1 line2 = saneIntersection $ plinesIntersectIn line1 line2 saneIntersection (IntersectsIn p (_,_, pErr)) = (p, pErr) -- | Get the intersection point of two lines. -intersectionBetween :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Maybe (Either a (CPPoint2, PPoint2Err)) +intersectionBetween :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Maybe (Either (a, PLine2Err) (CPPoint2, PPoint2Err)) intersectionBetween line1@(l1, _) line2@(l2, _) = saneIntersection $ plinesIntersectIn line1 line2 where (foundDistance, (_,_, foundErr)) = distance2PL l1 l2 - saneIntersection PAntiCollinear = Just $ Left l1 - saneIntersection PCollinear = Just $ Left l1 + saneIntersection PAntiCollinear = Just $ Left line1 + saneIntersection PCollinear = Just $ Left line1 saneIntersection PParallel = if foundDistance < realToFrac (ulpVal foundErr) - then Just $ Left l1 + then Just $ Left line1 else Nothing saneIntersection PAntiParallel = if foundDistance < realToFrac (ulpVal foundErr) - then Just $ Left l1 + then Just $ Left line1 else Nothing saneIntersection (IntersectsIn p (_,_, pErr)) = Just $ Right (p, pErr) diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index d8fc7b744..21dc70d97 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -62,7 +62,7 @@ import Graphics.Slicer.Math.Intersections (intersectionBetween, intersectionOf, import Graphics.Slicer.Math.Lossy as Lossy (distancePPointToPLine) -import Graphics.Slicer.Math.PGA (Arcable(errOfOut, hasArc, outOf), Pointable(canPoint, pPointOf), PLine2, PLine2Err, CPPoint2(CPPoint2), PPoint2(PPoint2), distance2PP, eToPL, flipL, outAndErrOf, pLineIsLeft, distancePPointToPLineWithErr) +import Graphics.Slicer.Math.PGA (Arcable(errOfOut, hasArc, outOf), Pointable(canPoint, pPointOf), PLine2, PLine2Err, distance2PP, eToPL, flipL, outAndErrOf, pLineIsLeft, distancePPointToPLineWithErr) import Graphics.Slicer.Math.Skeleton.Definitions (ENode(ENode), ENodeSet(ENodeSet), INode(INode), INodeSet(INodeSet), NodeTree(NodeTree), concavePLines, getFirstLineSeg, getLastLineSeg, finalOutOf, firstInOf, getPairs, indexPLinesTo, insOf, lastINodeOf, linePairs, makeINode, sortedPLinesWithErr, isLoop) @@ -645,7 +645,7 @@ skeletonOfNodes connectedLoop inSegSets iNodes = [] -> error "one line, no points.. makes no sense." (x:_) -> [and pointsCloseEnough && foundDistance < realToFrac foundErr] where - (foundDistance, (_,_,_,_,_,UlpSum foundErr)) = distancePPointToPLineWithErr ((\(CPPoint2 v,_) -> PPoint2 v) x, mempty) (a, mempty) + (foundDistance, (_,_,_,_,_,UlpSum foundErr)) = distancePPointToPLineWithErr x a (_:_) -> error $ "detected multiple lines?\n" <> show lineIntersections <> "\n" From ca1e35d9aa33ec2c4bbfd93b1a54392ea4981e4e Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Tue, 6 Dec 2022 22:26:35 +0000 Subject: [PATCH 134/206] format clearer. --- Graphics/Slicer/Math/Definitions.hs | 29 ++++++++++++++++++++++++++++- 1 file changed, 28 insertions(+), 1 deletion(-) diff --git a/Graphics/Slicer/Math/Definitions.hs b/Graphics/Slicer/Math/Definitions.hs index 619e54f38..e2a0e9c80 100644 --- a/Graphics/Slicer/Math/Definitions.hs +++ b/Graphics/Slicer/Math/Definitions.hs @@ -20,7 +20,34 @@ {-# LANGUAGE DeriveGeneric, DeriveAnyClass, DataKinds, PolyKinds, FlexibleInstances #-} -- | The purpose of this file is to hold the definitions of the data structures used when performing slicing related math. -module Graphics.Slicer.Math.Definitions(Point3(Point3), Point2(Point2), Contour(PointContour, LineSegContour), LineSeg(LineSeg), SpacePoint, PlanePoint, xOf, yOf, zOf, flatten, distance, addPoints, scalePoint, (~=), roundToFifth, roundPoint2, mapWithNeighbors, mapWithFollower, mapWithPredecessor, minMaxPoints, endPoint, fudgeFactor, startPoint, lineSegsOfContour, makeLineSeg, negatePoint) where +module Graphics.Slicer.Math.Definitions( + Point3(Point3), + Point2(Point2), + Contour(PointContour, LineSegContour), + LineSeg(LineSeg), + SpacePoint, + PlanePoint, + (~=), + addPoints, + distance, + endPoint, + flatten, + fudgeFactor, + lineSegsOfContour, + makeLineSeg, + mapWithNeighbors, + mapWithFollower, + mapWithPredecessor, + minMaxPoints, + negatePoint, + roundPoint2, + roundToFifth, + scalePoint, + startPoint, + xOf, + yOf, + zOf + ) where import Prelude (Eq, Show, (==), (*), sqrt, (+), ($), Bool, fromIntegral, round, (/), Ord(compare), otherwise, zipWith3, (<>), error, show, (<), (&&), negate) From a288743de975faff6cae12cf823e1f5813005661 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Wed, 7 Dec 2022 21:16:58 +0000 Subject: [PATCH 135/206] comment cleanups. --- Graphics/Slicer/Math/Intersections.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index e6d3ced9b..e70889361 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -17,8 +17,8 @@ -} {- - Purpose of this file: This file contains code for retrieving and reasoning about the intersection of two projective lines. --} + - This file contains code for retrieving and reasoning about the intersection of two projective lines. + -} module Graphics.Slicer.Math.Intersections ( intersectionBetween, @@ -68,7 +68,7 @@ intersectionOf line1 line2 = saneIntersection $ plinesIntersectIn line1 line2 saneIntersection PAntiParallel = error $ "cannot get the intersection of antiparallel lines.\nline1: " <> show line1 <> "\nline2: " <> show line2 <> "\n" saneIntersection (IntersectsIn p (_,_, pErr)) = (p, pErr) --- | Get the intersection point of two lines. +-- | Get the intersection point of two lines. If they are collinear, returns a line, and if they are parallel, returns Nothing. intersectionBetween :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Maybe (Either (a, PLine2Err) (CPPoint2, PPoint2Err)) intersectionBetween line1@(l1, _) line2@(l2, _) = saneIntersection $ plinesIntersectIn line1 line2 where From 83903aee860ecbee89fc3df8043024287b28b293 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Wed, 7 Dec 2022 22:52:37 +0000 Subject: [PATCH 136/206] add pointBetweenPoints, remove angleBetween. --- Graphics/Slicer/Math/Contour.hs | 15 ++++++++------- Graphics/Slicer/Math/Definitions.hs | 11 ++++++++--- Graphics/Slicer/Math/Lossy.hs | 6 +----- tests/Math/PGA.hs | 4 ++-- 4 files changed, 19 insertions(+), 17 deletions(-) diff --git a/Graphics/Slicer/Math/Contour.hs b/Graphics/Slicer/Math/Contour.hs index 19261924d..7d20c25b6 100644 --- a/Graphics/Slicer/Math/Contour.hs +++ b/Graphics/Slicer/Math/Contour.hs @@ -71,7 +71,7 @@ import Graphics.Slicer.Math.PGA (PPoint2, eToPP, join2EP, join2PP, pLineIsLeft, -- so that we have the loop, and also knowledge of how -- the list is built (the "sides" of it). -getLoops :: (Show a,Eq a) => [[a]] -> Maybe [[[a]]] +getLoops :: (Show a, Eq a) => [[a]] -> Maybe [[[a]]] getLoops [] = Just [] getLoops (x:xs) = getLoops' xs (slist [x]) (snd $ fromMaybe (error "empty first sequence") $ unsnoc x) -- We will be actually doing the loop extraction with @@ -157,11 +157,11 @@ getContours pointPairs = fromMaybe (error $ "failed to flip a contour\n" <> show foundContourSets :: [[[Point2]]] foundContourSets = fromMaybe (error "could not complete loop detection.") $ getLoops $ (\(a,b) -> [a,b]) <$> sortPairs pointPairs where - -- Sort the list to begin with, so that differently ordered input lists give the same output. + -- Sort the list, so that differently ordered input lists give the same output. sortPairs :: [(Point2,Point2)] -> [(Point2,Point2)] sortPairs = sortBy (\a b -> if fst a == fst b then compare (snd a) (snd b) else compare (fst a) (fst b)) --- make sure a contour is wound the right way, so that the inside of the contour is on the left side of each line segment. +-- | Ensure a contour is wound the right way, so that the inside of the contour is on the left side of each line segment. maybeFlipContour :: Contour -> Maybe Contour maybeFlipContour contour | isJust maybeIsLeft && maybeIsLeft == Just True = Just contour @@ -250,7 +250,8 @@ innerContourPoint contour (perpPoint, (_,_,_, perpErr)) = pPointOnPerpWithErr source midPoint minDistanceFromSeg (otherPoint, (_,_,_, otherErr)) = pPointOnPerpWithErr source midPoint (-minDistanceFromSeg) midPoint = pPointBetweenPPoints (eToPP p1) (eToPP p2) 0.5 0.5 - source = fst $ join2EP p1 p2 + -- FIXME: Error loss. + (source, _) = join2EP p1 p2 outsidePoint = pointFarOutsideContour contour (p1, p2) = firstPointPairOfContour contour -- | the minimum measurable distance of a point from a line segment @@ -267,7 +268,7 @@ pointFarOutsideContour contour | not (noIntersection line3 firstLine) = outsidePoint3 | otherwise = error "cannot get here." where - minPoint = fst $ minMaxPoints contour + (minPoint, _) = minMaxPoints contour (p1, p2) = firstPointPairOfContour contour firstLine = join2EP p1 p2 line1 = join2EP p1 outsidePoint1 @@ -285,8 +286,8 @@ pointFarOutsideContours contour1 contour2 | not (noIntersection line3 firstLine) && not (noIntersection line3 secondLine) = outsidePoint3 | otherwise = error "cannot get here...?" where - minPoint1 = fst $ minMaxPoints contour1 - minPoint2 = fst $ minMaxPoints contour2 + (minPoint1, _)= minMaxPoints contour1 + (minPoint2, _)= minMaxPoints contour2 minPoint = Point2 (min (xOf minPoint1) (xOf minPoint2),min (yOf minPoint1) (yOf minPoint2)) (p1, p2) = firstPointPairOfContour contour1 (p3, p4) = firstPointPairOfContour contour2 diff --git a/Graphics/Slicer/Math/Definitions.hs b/Graphics/Slicer/Math/Definitions.hs index e2a0e9c80..4a8da52e5 100644 --- a/Graphics/Slicer/Math/Definitions.hs +++ b/Graphics/Slicer/Math/Definitions.hs @@ -21,12 +21,12 @@ -- | The purpose of this file is to hold the definitions of the data structures used when performing slicing related math. module Graphics.Slicer.Math.Definitions( - Point3(Point3), - Point2(Point2), Contour(PointContour, LineSegContour), LineSeg(LineSeg), - SpacePoint, PlanePoint, + Point2(Point2), + Point3(Point3), + SpacePoint, (~=), addPoints, distance, @@ -40,6 +40,7 @@ module Graphics.Slicer.Math.Definitions( mapWithPredecessor, minMaxPoints, negatePoint, + pointBetweenPoints, roundPoint2, roundToFifth, scalePoint, @@ -181,6 +182,10 @@ minMaxPoints contour = case contour of (PointContour foundMinPoint foundMaxPoint _ _ _ _) -> (foundMinPoint, foundMaxPoint) (LineSegContour foundMinPoint foundMaxPoint _ _ _) -> (foundMinPoint, foundMaxPoint) +-- | Find a point between the two given points. +pointBetweenPoints :: Point2 -> Point2 -> Point2 +pointBetweenPoints point1 point2 = scalePoint 0.5 $ addPoints point1 point2 + -- | round a value roundToFifth :: ℝ -> ℝ roundToFifth a = fromIntegral (round (100000 * a) :: Fastℕ) / 100000 diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index 7001e812c..1b54cac94 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -19,7 +19,6 @@ -- | The purpose of this file is to provide versions of PGA functionality that are known to be lossy. module Graphics.Slicer.Math.Lossy ( - angleBetween, canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenPLines, @@ -48,10 +47,7 @@ import Graphics.Slicer.Math.Definitions (LineSeg, Point2, makeLineSeg) import qualified Graphics.Slicer.Math.Arcs as Arcs (getFirstArc, getInsideArc) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PPoint2, ProjectiveLine2, ProjectivePoint2, angleBetween2PL, canonicalizeP, distance2PP, distance2PL, distancePPointToPLineWithErr, eToPL, eToPP, interpolate2PP, join2PP, normalizeL, pPointOnPerpWithErr, pToEP, translateL) - -angleBetween :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> ℝ -angleBetween pLine1 pLine2 = fst $ angleBetween2PL pLine1 pLine2 +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PPoint2, ProjectiveLine2, ProjectivePoint2, canonicalizeP, distance2PP, distance2PL, distancePPointToPLineWithErr, eToPL, eToPP, interpolate2PP, join2PP, normalizeL, pPointOnPerpWithErr, pToEP, translateL) -- | canonicalize a euclidian point. canonicalizePPoint2 :: PPoint2 -> CPPoint2 diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index b66ef00d0..6a2d79216 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -56,7 +56,7 @@ import Graphics.Slicer.Math.Definitions(Point2(Point2), Contour(LineSegContour), -- Our Geometric Algebra library. import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(GEZero, GEPlus, G0), GVal(GVal), GVec(GVec), UlpSum(UlpSum), addValPairWithErr, subValPairWithErr, addValWithErr, ulpVal, subVal, addVecPair, subVecPair, mulScalarVecWithErr, divVecScalarWithErr, scalarPart, vectorPart, (•), (∧), (⋅), (⎣), (⎤)) -import Graphics.Slicer.Math.Lossy (angleBetween, canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenPLines, distancePPointToPLine, eToCPPoint2, eToPLine2, getFirstArc, join2PPoint2, normalizePLine2, pPointOnPerp) +import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenPLines, distancePPointToPLine, eToCPPoint2, eToPLine2, getFirstArc, join2PPoint2, normalizePLine2, pPointOnPerp) -- Our 2D Projective Geometric Algebra library. import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PLine2Err(PLine2Err), canonicalizeP, distance2PP, distancePPointToPLineWithErr, eToPL, eToPP, eToPP, interpolate2PP, intersect2PL, translateL, translateRotatePPoint2WithErr, angleBetween2PL, flipL, join2PP, makePPoint2, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, distancePPointToPLineWithErr, errOfOut, pPointOnPerpWithErr, outOf, pPointOf, outputIntersectsLineSeg) @@ -560,7 +560,7 @@ prop_QuadBisectorCrossesMultiple rawX1 rawY1 rawX2 rawY2 rawTimes <> show lineSeg2 <> "\n" <> show bisector1 <> "\n" <> show eNode <> "\n" - <> show (angleBetween (normalizePLine2 $ outOf eNode) bisector1) <> "\n" + <> show (angleBetween2PL (normalizePLine2 $ outOf eNode) bisector1) <> "\n" <> "(" <> show x3 <> "," <> show y3 <> ")\n" <> "(" <> show x4 <> "," <> show y4 <> ")\n" where From 1fc3bf8447cbf6c6c07509b362d92dc627c4be78 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 10 Dec 2022 12:46:58 +0000 Subject: [PATCH 137/206] use linear pointBetweenPoints instead of projective pPointBetweenPoints when generating error data. --- Graphics/Slicer/Math/PGA.hs | 2 +- Graphics/Slicer/Math/RandomGeometry.hs | 12 ++++++------ 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index c630bad84..8032e9350 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -75,7 +75,7 @@ module Graphics.Slicer.Math.PGA( vecOfP ) where -import Prelude (Bool, Eq((==)), Monoid(mempty), Semigroup((<>)), Show(show), ($), (-), (>=), (&&), (<$>), otherwise, signum, (>), (<=), (+), negate, (/), (||), (<), abs, error, sin, cos, realToFrac) +import Prelude (Bool, Eq((==)), Monoid(mempty), Semigroup((<>)), Show(show), ($), (-), (>=), (&&), (<$>), (>), (<=), (+), (/), (||), (<), abs, cos, error, negate, otherwise, realToFrac, signum, sin) import Data.Bits.Floating.Ulp (doubleUlp) diff --git a/Graphics/Slicer/Math/RandomGeometry.hs b/Graphics/Slicer/Math/RandomGeometry.hs index 55c4996c8..bec732326 100644 --- a/Graphics/Slicer/Math/RandomGeometry.hs +++ b/Graphics/Slicer/Math/RandomGeometry.hs @@ -86,13 +86,13 @@ import Graphics.Slicer.Math.Arcs (getOutsideArc) import Graphics.Slicer.Math.Contour (makePointContour, maybeFlipContour, firstPointPairOfContour, pointFarOutsideContour) -import Graphics.Slicer.Math.Definitions (Contour, Point2(Point2), LineSeg, makeLineSeg) +import Graphics.Slicer.Math.Definitions (Contour, Point2(Point2), LineSeg, makeLineSeg, pointBetweenPoints) import Graphics.Slicer.Math.Ganja (dumpGanjas, toGanja) -import Graphics.Slicer.Math.Lossy (eToPLine2, join2PPoint2, pPointBetweenPPoints, pToEPoint2) +import Graphics.Slicer.Math.Lossy (eToPLine2, pToEPoint2) -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), PLine2(PLine2), PPoint2(PPoint2), PLine2Err, eToPL, eToPP, flipL, normalizeL, translateRotatePPoint2WithErr, pPointOf, NPLine2(NPLine2)) +import Graphics.Slicer.Math.PGA (PLine2(PLine2), PLine2Err, eToPL, eToPP, flipL, join2EP, normalizeL, translateRotatePPoint2WithErr, pPointOf, NPLine2(NPLine2)) import Graphics.Slicer.Math.Skeleton.Concave (makeENode) @@ -378,9 +378,9 @@ randomStarPoly centerX centerY radianDistPairs = fromMaybe dumpError $ maybeFlip centerPPoint = eToPP $ Point2 (centerX, centerY) dumpError = error $ "failed to flip a contour:" <> dumpGanjas [toGanja contour, toGanja (Point2 (centerX, centerY)), toGanja outsidePLine] <> "\n" where - outsidePLine = join2PPoint2 myMidPoint outsidePoint - outsidePoint = (\(CPPoint2 a) -> PPoint2 a) $ eToPP $ pointFarOutsideContour contour - myMidPoint = pPointBetweenPPoints (eToPP p1) (eToPP p2) 0.5 0.5 + outsidePLine = fst $ join2EP myMidPoint outsidePoint + outsidePoint = pointFarOutsideContour contour + myMidPoint = pointBetweenPoints p1 p2 (p1, p2) = firstPointPairOfContour contour randomENode :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> Positive ℝ -> Radian ℝ -> ENode From 1f711d1e339531e93e0d6f850eff2dba4ce65ea2 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 10 Dec 2022 14:13:12 +0000 Subject: [PATCH 138/206] add intersectionBetweenArcsOf. --- Graphics/Slicer/Math/Contour.hs | 2 +- Graphics/Slicer/Math/Intersections.hs | 14 ++++++++++++-- Graphics/Slicer/Math/Skeleton/Cells.hs | 4 ++-- 3 files changed, 15 insertions(+), 5 deletions(-) diff --git a/Graphics/Slicer/Math/Contour.hs b/Graphics/Slicer/Math/Contour.hs index 7d20c25b6..bb52d9265 100644 --- a/Graphics/Slicer/Math/Contour.hs +++ b/Graphics/Slicer/Math/Contour.hs @@ -83,7 +83,7 @@ getLoops (x:xs) = getLoops' xs (slist [x]) (snd $ fromMaybe (error "empty first -- | so we begin with the "building loop" being empty. getLoops' - :: (Show a,Eq a) + :: (Show a, Eq a) => [[a]] -- ^ input -> Slist [a] -- ^ accumulator -> a -- ^ last element in the acumulator diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index e70889361..6b2b0a099 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -22,6 +22,7 @@ module Graphics.Slicer.Math.Intersections ( intersectionBetween, + intersectionBetweenArcsOf, intersectionOf, isAntiCollinear, isAntiParallel, @@ -30,13 +31,13 @@ module Graphics.Slicer.Math.Intersections ( noIntersection ) where -import Prelude (Bool, Either(Left, Right), (<>), ($), (<), (||), (==), error, show, realToFrac) +import Prelude (Bool, Either(Left, Right), (<>), ($), (<), (||), (==), (&&), error, show, otherwise, realToFrac) import Data.Maybe (Maybe(Just, Nothing)) import Graphics.Slicer.Math.GeometricAlgebra (ulpVal) -import Graphics.Slicer.Math.PGA (CPPoint2, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), PLine2Err, PPoint2Err, ProjectiveLine2, distance2PL, plinesIntersectIn) +import Graphics.Slicer.Math.PGA (Arcable(hasArc), CPPoint2, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), PLine2Err, PPoint2Err, ProjectiveLine2, distance2PL, outAndErrOf, plinesIntersectIn) -- | Check if two lines cannot intersect. noIntersection :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Bool @@ -83,3 +84,12 @@ intersectionBetween line1@(l1, _) line2@(l2, _) = saneIntersection $ plinesInter else Nothing saneIntersection (IntersectsIn p (_,_, pErr)) = Just $ Right (p, pErr) +-- | Find out where the output of two Arcables intersect. returns Nothing if no intersection, errors if no output Arc exists on either input. +intersectionBetweenArcsOf :: (Arcable a, Arcable b) => a -> b -> Maybe (CPPoint2, PPoint2Err) +intersectionBetweenArcsOf node1 node2 + | hasArc node1 && hasArc node2 = case res of + (IntersectsIn p (_,_, pErr)) -> Just (p, pErr) + _ -> Nothing + | otherwise = error $ "Tried to check if the outputs of two nodes intersect, but a node with no output:\n" <> show node1 <> "\n" <> show node2 <> "\n" + where + res = plinesIntersectIn (outAndErrOf node1) (outAndErrOf node2) diff --git a/Graphics/Slicer/Math/Skeleton/Cells.hs b/Graphics/Slicer/Math/Skeleton/Cells.hs index 6742ca800..8686947d7 100644 --- a/Graphics/Slicer/Math/Skeleton/Cells.hs +++ b/Graphics/Slicer/Math/Skeleton/Cells.hs @@ -54,7 +54,7 @@ import Graphics.Slicer.Math.Definitions (Contour, LineSeg(LineSeg), Point2, dist import Graphics.Slicer.Math.GeometricAlgebra (ulpVal) -import Graphics.Slicer.Math.Intersections (intersectionOf) +import Graphics.Slicer.Math.Intersections (intersectionBetweenArcsOf) import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, eToCPPoint2, eToPLine2, pToEPoint2) @@ -115,7 +115,7 @@ findDivisions contour crashTree = case motorcyclesIn crashTree of where (angleFound, (_,_, angleErr)) = angleBetween2PL (outOf m) (eToPLine2 $ lineSegToIntersection m) lineSegToIntersection m = makeLineSeg (ePointOf m) (pToEPoint2 intersectionPPoint) - intersectionPPoint = fst $ intersectionOf (outAndErrOf firstMC) (outAndErrOf secondMC) + (intersectionPPoint, _) = fromMaybe (error "no intersection between motorcycles!") $ intersectionBetweenArcsOf firstMC secondMC (Slist (_:_) _) -> error "too many motorcycles." motorcyclesIn (CrashTree motorcycles _ _) = motorcycles -- | find where the last motorcycle of a divide lands From 3c44192796ee905a7231a7c2cd9bf42b6f1b5115 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 10 Dec 2022 15:58:16 +0000 Subject: [PATCH 139/206] remove unnecessary canonicalization. --- Graphics/Slicer/Math/Skeleton/Cells.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Graphics/Slicer/Math/Skeleton/Cells.hs b/Graphics/Slicer/Math/Skeleton/Cells.hs index 8686947d7..020e475b7 100644 --- a/Graphics/Slicer/Math/Skeleton/Cells.hs +++ b/Graphics/Slicer/Math/Skeleton/Cells.hs @@ -56,7 +56,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (ulpVal) import Graphics.Slicer.Math.Intersections (intersectionBetweenArcsOf) -import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, eToCPPoint2, eToPLine2, pToEPoint2) +import Graphics.Slicer.Math.Lossy (distanceBetweenPPoints, eToCPPoint2, eToPLine2, pToEPoint2) import Graphics.Slicer.Math.PGA (Arcable(outOf), CPPoint2(CPPoint2), Pointable(canPoint, ePointOf, pPointOf), PIntersection(PAntiCollinear, IntersectsIn), PPoint2(PPoint2), angleBetween2PL, distance2PP, eToPL, eToPP, outAndErrOf, plinesIntersectIn) @@ -127,8 +127,8 @@ findDivisions contour crashTree = case motorcyclesIn crashTree of then WithENode oneNode else WithLineSeg $ fst $ motorcycleIntersectsAt myContour myMotorcycle where - cMotorcyclePoint = canonicalizePPoint2 $ pPointOf myMotorcycle - cNodePoint = canonicalizePPoint2 $ pPointOf oneNode + cMotorcyclePoint = pPointOf myMotorcycle + cNodePoint = pPointOf oneNode motorcycleENodeDistance = distanceBetweenPPoints cMotorcyclePoint cNodePoint motorcycleLineSegDistance = distanceBetweenPPoints cMotorcyclePoint $ justIntersectsIn $ plinesIntersectIn (outAndErrOf myMotorcycle) (eToPL $ fst $ motorcycleIntersectsAt myContour myMotorcycle) (_:_) -> error "more than one opposing exterior node. cannot yet handle this situation." From 75e8ce357846a550ef5875c6c95ade681f05c015 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 10 Dec 2022 17:34:28 +0000 Subject: [PATCH 140/206] add outputIntersectsPLineAt, and use distance2PP to eliminate a usage of Eq. --- Graphics/Slicer/Math/Arcs.hs | 2 +- Graphics/Slicer/Math/Intersections.hs | 13 ++++++++++++- Graphics/Slicer/Math/Skeleton/Cells.hs | 16 ++++++++-------- 3 files changed, 21 insertions(+), 10 deletions(-) diff --git a/Graphics/Slicer/Math/Arcs.hs b/Graphics/Slicer/Math/Arcs.hs index be0a2886b..85edcb5cb 100644 --- a/Graphics/Slicer/Math/Arcs.hs +++ b/Graphics/Slicer/Math/Arcs.hs @@ -115,12 +115,12 @@ getObtuseAngleBisectorFromPointedLines ppoint1 line1 ppoint2 line2 l2TowardPoint = towardIntersection ppoint2 line2 intersectionPoint -- | Determine if the line segment formed by the two given points starts with the first point, or the second. --- FIXME: angleBetween2PL should be handling line error. towardIntersection :: (ProjectivePoint2 a, ProjectiveLine2 b, ProjectivePoint2 c) => (a, PPoint2Err) -> (b, PLine2Err) -> (c, PPoint2Err) -> Bool towardIntersection point1@(pp1, _) (pl1, _) point2@(pp2, _) | d <= realToFrac (ulpVal dErr) = error $ "cannot resolve points finely enough.\nPPoint1: " <> show pp1 <> "\nPPoint2: " <> show pp2 <> "\nPLineIn: " <> show pl1 <> "\nnewPLine: " <> show newPLine <> "\n" | otherwise = angleFound > realToFrac (ulpVal angleErr) where + -- FIXME: angleBetween2PL should be handling line error. (angleFound, (_,_, angleErr)) = angleBetween2PL newPLine pl1 (d, (_,_, dErr)) = distance2PP point1 point2 (newPLine, _) = join2PP pp1 pp2 diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index 6b2b0a099..65d8fc636 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -28,7 +28,8 @@ module Graphics.Slicer.Math.Intersections ( isAntiParallel, isCollinear, isParallel, - noIntersection + noIntersection, + outputIntersectsPLineAt ) where import Prelude (Bool, Either(Left, Right), (<>), ($), (<), (||), (==), (&&), error, show, otherwise, realToFrac) @@ -93,3 +94,13 @@ intersectionBetweenArcsOf node1 node2 | otherwise = error $ "Tried to check if the outputs of two nodes intersect, but a node with no output:\n" <> show node1 <> "\n" <> show node2 <> "\n" where res = plinesIntersectIn (outAndErrOf node1) (outAndErrOf node2) + +-- | Find out where the output of an Arcable intersects a given PLine2. errors if no intersection. +outputIntersectsPLineAt :: (Arcable a, ProjectiveLine2 b) => a -> (b, PLine2Err) -> Maybe (CPPoint2, PPoint2Err) +outputIntersectsPLineAt n line + | hasArc n = case res of + (IntersectsIn p (_,_, pErr)) -> Just (p, pErr) + _ -> Nothing + | otherwise = error $ "Tried to check if the output of node intersects PLine on a node with no output:\n" <> show n <> "\n" <> show line <> "\n" + where + res = plinesIntersectIn (outAndErrOf n) line diff --git a/Graphics/Slicer/Math/Skeleton/Cells.hs b/Graphics/Slicer/Math/Skeleton/Cells.hs index 020e475b7..27d52ca79 100644 --- a/Graphics/Slicer/Math/Skeleton/Cells.hs +++ b/Graphics/Slicer/Math/Skeleton/Cells.hs @@ -54,11 +54,11 @@ import Graphics.Slicer.Math.Definitions (Contour, LineSeg(LineSeg), Point2, dist import Graphics.Slicer.Math.GeometricAlgebra (ulpVal) -import Graphics.Slicer.Math.Intersections (intersectionBetweenArcsOf) +import Graphics.Slicer.Math.Intersections (intersectionBetweenArcsOf, outputIntersectsPLineAt) import Graphics.Slicer.Math.Lossy (distanceBetweenPPoints, eToCPPoint2, eToPLine2, pToEPoint2) -import Graphics.Slicer.Math.PGA (Arcable(outOf), CPPoint2(CPPoint2), Pointable(canPoint, ePointOf, pPointOf), PIntersection(PAntiCollinear, IntersectsIn), PPoint2(PPoint2), angleBetween2PL, distance2PP, eToPL, eToPP, outAndErrOf, plinesIntersectIn) +import Graphics.Slicer.Math.PGA (Arcable(outOf), CPPoint2(CPPoint2), Pointable(canPoint, ePointOf, pPointOf), PIntersection(PAntiCollinear), PPoint2(PPoint2), angleBetween2PL, distance2PP, eToPL, eToPP, outAndErrOf, plinesIntersectIn) import Graphics.Slicer.Math.PGAPrimitives (join2PP) @@ -130,13 +130,9 @@ findDivisions contour crashTree = case motorcyclesIn crashTree of cMotorcyclePoint = pPointOf myMotorcycle cNodePoint = pPointOf oneNode motorcycleENodeDistance = distanceBetweenPPoints cMotorcyclePoint cNodePoint - motorcycleLineSegDistance = distanceBetweenPPoints cMotorcyclePoint $ justIntersectsIn $ plinesIntersectIn (outAndErrOf myMotorcycle) (eToPL $ fst $ motorcycleIntersectsAt myContour myMotorcycle) + motorcycleLineSegDistance = distanceBetweenPPoints cMotorcyclePoint $ fst $ fromMaybe (error "no outArc?") $ outputIntersectsPLineAt myMotorcycle (eToPL $ fst $ motorcycleIntersectsAt myContour myMotorcycle) (_:_) -> error "more than one opposing exterior node. cannot yet handle this situation." where - justIntersectsIn :: PIntersection -> CPPoint2 - justIntersectsIn res = case res of - (IntersectsIn p _) -> p - v -> error $ "intersection failure." <> show v <> show myContour <> "\n" <> show myMotorcycle <> "\n" eNodesInPath = opposingNodes myContour myMotorcycle where opposingNodes :: Contour -> Motorcycle -> [ENode] @@ -407,7 +403,11 @@ nodeTreesDoNotOverlap nodeTree1 nodeTree2 cellDivide@(CellDivide motorcycles1 _) -- | Check that the outputs of the NodeTrees collide at the same point at the division between the two cells the NodeTrees correspond to. lastOutsIntersect :: NodeTree -> NodeTree -> CellDivide -> Bool lastOutsIntersect nt1 nt2 (CellDivide motorcycles _) = case motorcycles of - (DividingMotorcycles m (Slist _ 0)) -> plinesIntersectIn (finalPLine nt1) (outAndErrOf m) == plinesIntersectIn (finalPLine nt2) (outAndErrOf m) + (DividingMotorcycles m (Slist _ 0)) -> d < realToFrac (ulpVal dErr) + where + (d, (_,_, dErr)) = distance2PP point1 point2 + point1 = fromMaybe (error "no outArc?") $ outputIntersectsPLineAt m (finalPLine nt1) + point2 = fromMaybe (error "no outArc?") $ outputIntersectsPLineAt m (finalPLine nt2) (DividingMotorcycles _ (Slist _ _)) -> error "cannot yet check outpoint intersections of more than one motorcycle." -- | Given a nodeTree and it's closing division, return all of the ENodes where the point of the node is on the opposite side of the division. From e8d437e738f47c64def6917007dc844a43e72f36 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 10 Dec 2022 18:12:53 +0000 Subject: [PATCH 141/206] make intersectionSameSide accept canonicalized points, and error quotents. --- Graphics/Slicer/Math/Intersections.hs | 6 +++--- Graphics/Slicer/Math/PGA.hs | 2 +- Graphics/Slicer/Math/Skeleton/Cells.hs | 6 +++--- Graphics/Slicer/Math/Skeleton/Motorcycles.hs | 13 +++++++------ 4 files changed, 14 insertions(+), 13 deletions(-) diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index 65d8fc636..9ddf00077 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -17,7 +17,7 @@ -} {- - - This file contains code for retrieving and reasoning about the intersection of two projective lines. + - This file contains code for retrieving and reasoning about the intersection of two projective lines. -} module Graphics.Slicer.Math.Intersections ( @@ -99,8 +99,8 @@ intersectionBetweenArcsOf node1 node2 outputIntersectsPLineAt :: (Arcable a, ProjectiveLine2 b) => a -> (b, PLine2Err) -> Maybe (CPPoint2, PPoint2Err) outputIntersectsPLineAt n line | hasArc n = case res of - (IntersectsIn p (_,_, pErr)) -> Just (p, pErr) - _ -> Nothing + (IntersectsIn p (_,_, pErr)) -> Just (p, pErr) + _ -> Nothing | otherwise = error $ "Tried to check if the output of node intersects PLine on a node with no output:\n" <> show n <> "\n" <> show line <> "\n" where res = plinesIntersectIn (outAndErrOf n) line diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 8032e9350..d7c0a1a3d 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -295,7 +295,7 @@ outAndErrOf a | otherwise = error $ "Asked for out and err of Arcable with no out!\n" <> show a <> "\n" -- | Typeclass for nodes that may be able to be resolved into a point. -class Pointable a where +class (Show a) => Pointable a where -- | Can this node be resolved into a point in 2d space? canPoint :: a -> Bool -- | Get a euclidian representation of this point. diff --git a/Graphics/Slicer/Math/Skeleton/Cells.hs b/Graphics/Slicer/Math/Skeleton/Cells.hs index 27d52ca79..6cf11cee8 100644 --- a/Graphics/Slicer/Math/Skeleton/Cells.hs +++ b/Graphics/Slicer/Math/Skeleton/Cells.hs @@ -58,7 +58,7 @@ import Graphics.Slicer.Math.Intersections (intersectionBetweenArcsOf, outputInte import Graphics.Slicer.Math.Lossy (distanceBetweenPPoints, eToCPPoint2, eToPLine2, pToEPoint2) -import Graphics.Slicer.Math.PGA (Arcable(outOf), CPPoint2(CPPoint2), Pointable(canPoint, ePointOf, pPointOf), PIntersection(PAntiCollinear), PPoint2(PPoint2), angleBetween2PL, distance2PP, eToPL, eToPP, outAndErrOf, plinesIntersectIn) +import Graphics.Slicer.Math.PGA (Arcable(outOf), CPPoint2, Pointable(canPoint, ePointOf, pPointOf), PIntersection(PAntiCollinear), angleBetween2PL, distance2PP, eToPL, eToPP, outAndErrOf, plinesIntersectIn) import Graphics.Slicer.Math.PGAPrimitives (join2PP) @@ -416,8 +416,8 @@ crossoverINodes :: NodeTree -> CellDivide -> [INode] crossoverINodes nodeTree@(NodeTree _ (INodeSet (Slist iNodes _))) cellDivision = filter nodeCrosses (filter canPoint $ concat iNodes) where nodeCrosses :: INode -> Bool - nodeCrosses a = Just False `elem` (intersectionSameSide pointOnSide a <$> motorcyclesInDivision cellDivision) - pointOnSide = (\(CPPoint2 a) -> PPoint2 a) $ eToPP $ pointInCell nodeTree cellDivision + nodeCrosses a = Just False `elem` (intersectionSameSide (pointOnSide, mempty) a <$> motorcyclesInDivision cellDivision) + pointOnSide = eToPP $ pointInCell nodeTree cellDivision pointInCell cell (CellDivide (DividingMotorcycles m _) _) | firstSegOf cell == lastCSegOf m = endPoint $ firstSegOf cell | lastSegOf cell == firstCSegOf m = startPoint $ lastSegOf cell diff --git a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs index 9a33870ba..925d3d3a8 100644 --- a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs +++ b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs @@ -52,7 +52,7 @@ import Graphics.Slicer.Math.Intersections (intersectionOf, isAntiCollinear, noIn import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, pPointBetweenPPoints, distanceBetweenPPoints, eToCPPoint2, eToPLine2, normalizePLine2, pToEPoint2) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), PPoint2, Arcable(outOf), Pointable(canPoint, ePointOf, pPointOf), eToPL, flipL, pLineIsLeft, pPointsOnSameSideOfPLine, PIntersection(IntersectsIn,PAntiCollinear), angleBetween2PL, distance2PP, eToPP, join2PP, outAndErrOf, outputIntersectsLineSeg, plinesIntersectIn, translateL) +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), PPoint2, PPoint2Err, Arcable(outOf), Pointable(canPoint, ePointOf, pPointOf), eToPL, flipL, pLineIsLeft, pPointsOnSameSideOfPLine, PIntersection(IntersectsIn,PAntiCollinear), ProjectivePoint2, angleBetween2PL, distance2PP, eToPP, join2PP, outAndErrOf, outputIntersectsLineSeg, plinesIntersectIn, translateL) import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle), ENode(ENode), getFirstLineSeg, linePairs, CellDivide(CellDivide), DividingMotorcycles(DividingMotorcycles), MotorcycleIntersection(WithLineSeg, WithENode, WithMotorcycle)) @@ -313,12 +313,13 @@ motorcycleIntersectsAt contour motorcycle = case intersections of -- | Determine if a node is on one side of a motorcycle, or the other. -- Assumes the starting point of the second line segment is a point on the path. -intersectionSameSide :: (Pointable a, Show a) => PPoint2 -> a -> Motorcycle -> Maybe Bool -intersectionSameSide pointOnSide node (Motorcycle _ path _) - | canPoint node && pPointOf node == pointOnSide = Just True - | canPoint node = pPointsOnSameSideOfPLine (pPointOf node) pointOnSide path +intersectionSameSide :: (ProjectivePoint2 a, Pointable b) => (a, PPoint2Err) -> b -> Motorcycle -> Maybe Bool +intersectionSameSide point@(pp1, _) node (Motorcycle _ path _) + | canPoint node && d < realToFrac (ulpVal dErr) = Just True + | canPoint node = pPointsOnSameSideOfPLine (pPointOf node) pp1 path | otherwise = error $ "cannot resolve provided item to a point: " <> show node <> "\n" - + where + (d, (_,_, dErr)) = distance2PP (pPointOf node, mempty) point -- | Check if the output of two motorcycles are anti-collinear with each other. motorcyclesAreAntiCollinear :: Motorcycle -> Motorcycle -> Bool motorcyclesAreAntiCollinear motorcycle1 motorcycle2 = plinesIntersectIn (outAndErrOf motorcycle1) (outAndErrOf motorcycle2) == PAntiCollinear From 2c385ba34e65ca4a0533c8fd2272236628ca6bb1 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 10 Dec 2022 23:19:40 +0000 Subject: [PATCH 142/206] make findINodes easier to read. --- Graphics/Slicer/Math/Skeleton/Cells.hs | 6 +++--- Graphics/Slicer/Math/Skeleton/Concave.hs | 16 +++++++--------- 2 files changed, 10 insertions(+), 12 deletions(-) diff --git a/Graphics/Slicer/Math/Skeleton/Cells.hs b/Graphics/Slicer/Math/Skeleton/Cells.hs index 6cf11cee8..7ccca00fc 100644 --- a/Graphics/Slicer/Math/Skeleton/Cells.hs +++ b/Graphics/Slicer/Math/Skeleton/Cells.hs @@ -54,11 +54,11 @@ import Graphics.Slicer.Math.Definitions (Contour, LineSeg(LineSeg), Point2, dist import Graphics.Slicer.Math.GeometricAlgebra (ulpVal) -import Graphics.Slicer.Math.Intersections (intersectionBetweenArcsOf, outputIntersectsPLineAt) +import Graphics.Slicer.Math.Intersections (intersectionBetweenArcsOf, isAntiCollinear, outputIntersectsPLineAt) import Graphics.Slicer.Math.Lossy (distanceBetweenPPoints, eToCPPoint2, eToPLine2, pToEPoint2) -import Graphics.Slicer.Math.PGA (Arcable(outOf), CPPoint2, Pointable(canPoint, ePointOf, pPointOf), PIntersection(PAntiCollinear), angleBetween2PL, distance2PP, eToPL, eToPP, outAndErrOf, plinesIntersectIn) +import Graphics.Slicer.Math.PGA (Arcable(outOf), CPPoint2, Pointable(canPoint, ePointOf, pPointOf), angleBetween2PL, distance2PP, eToPL, eToPP, outAndErrOf) import Graphics.Slicer.Math.PGAPrimitives (join2PP) @@ -136,7 +136,7 @@ findDivisions contour crashTree = case motorcyclesIn crashTree of eNodesInPath = opposingNodes myContour myMotorcycle where opposingNodes :: Contour -> Motorcycle -> [ENode] - opposingNodes c m = filter (\eNode -> plinesIntersectIn (outAndErrOf eNode) (outAndErrOf m) == PAntiCollinear) $ eNodesOfOutsideContour c + opposingNodes c m = filter (\eNode -> isAntiCollinear (outAndErrOf eNode) (outAndErrOf m)) $ eNodesOfOutsideContour c -- | Find a single Cell of the given contour. always finds the cell on the 'open end' of the contour. findFirstCellOfContour :: Contour -> [CellDivide] -> Maybe (Cell, Maybe [RemainingContour]) diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index 21dc70d97..a8d16490b 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -109,13 +109,12 @@ findINodes inSegSets | len inSegSets == 2 = -- Two walls, no closed ends. solve the ends of a hallway region, so we can then hand off the solutioning to our regular process. case initialENodes of - [] -> INodeSet $ slist [[makeINode [getInsideArc (eToFlippedPL firstSeg) (eToPL lastSeg), getInsideArc (eToPL firstSeg) (eToFlippedPL lastSeg)] Nothing]] + [] -> INodeSet $ slist [[makeINode [getInsideArc firstSegFlipped lastSeg, getInsideArc firstSeg lastSegFlipped] Nothing]] where - firstSeg = SL.head $ slist $ SL.head inSegSets - lastSeg = SL.head $ slist $ SL.last inSegSets - eToFlippedPL lineSeg = (flipL res, resErr) - where - (res, resErr) = eToPL lineSeg + firstSeg@(fs, fsErr) = eToPL $ SL.head $ slist $ SL.head inSegSets + firstSegFlipped = (flipL fs, fsErr) + lastSeg@(ls, lsErr) = eToPL $ SL.head $ slist $ SL.last inSegSets + lastSegFlipped = (flipL ls, lsErr) [a] -> INodeSet $ slist [[makeINode [getInsideArc (eToPL lastSeg) (eToPL shortSide), getInsideArc (eToPL firstSeg) (eToPL shortSide)] (Just (flipL $ outOf a, errOfOut a))]] where firstSeg = fromMaybe (error "no first segment?") $ safeHead $ slist longSide @@ -168,9 +167,8 @@ errorIfLeft :: Either PartialNodes INodeSet -> INodeSet errorIfLeft (Left failure) = error $ "Fail!\n" <> show failure errorIfLeft (Right val) = val --- | For a given par of nodes, construct a new internal node, where it's parents are the given nodes, and the line leaving it is along the the obtuse bisector. --- Note: this should be hidden in skeletonOfConcaveRegion, but it's exposed here, for testing. --- Note: assumes outOf the two input nodes is already normalized. +-- | For a given pair of nodes, construct a new internal node, where it's parents are the given nodes, and the line leaving it is along the the obtuse bisector. +-- Note: this should be hidden in skeletonOfConcaveRegion, but it's exposed here, for testing. averageNodes :: (Arcable a, Pointable a, Arcable b, Pointable b) => a -> b -> INode averageNodes n1 n2 | not (hasArc n1) || not (hasArc n2) = error $ "Cannot get the average of nodes if one of the nodes does not have an out!\n" <> dumpInput From 6822b2a51777cad520d8115268bc09b9924bc08f Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 11 Dec 2022 00:07:06 +0000 Subject: [PATCH 143/206] make findINodes easier to read. --- Graphics/Slicer/Math/Skeleton/Cells.hs | 2 +- Graphics/Slicer/Math/Skeleton/Concave.hs | 22 +++++++++++----------- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/Graphics/Slicer/Math/Skeleton/Cells.hs b/Graphics/Slicer/Math/Skeleton/Cells.hs index 7ccca00fc..650614fc3 100644 --- a/Graphics/Slicer/Math/Skeleton/Cells.hs +++ b/Graphics/Slicer/Math/Skeleton/Cells.hs @@ -115,7 +115,7 @@ findDivisions contour crashTree = case motorcyclesIn crashTree of where (angleFound, (_,_, angleErr)) = angleBetween2PL (outOf m) (eToPLine2 $ lineSegToIntersection m) lineSegToIntersection m = makeLineSeg (ePointOf m) (pToEPoint2 intersectionPPoint) - (intersectionPPoint, _) = fromMaybe (error "no intersection between motorcycles!") $ intersectionBetweenArcsOf firstMC secondMC + (intersectionPPoint, _) = fromMaybe (error "has arcs, but no intersection?") $ intersectionBetweenArcsOf firstMC secondMC (Slist (_:_) _) -> error "too many motorcycles." motorcyclesIn (CrashTree motorcycles _ _) = motorcycles -- | find where the last motorcycle of a divide lands diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index a8d16490b..cf71696ad 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -109,19 +109,19 @@ findINodes inSegSets | len inSegSets == 2 = -- Two walls, no closed ends. solve the ends of a hallway region, so we can then hand off the solutioning to our regular process. case initialENodes of - [] -> INodeSet $ slist [[makeINode [getInsideArc firstSegFlipped lastSeg, getInsideArc firstSeg lastSegFlipped] Nothing]] + [] -> INodeSet $ slist [[makeINode [getInsideArc firstLineFlipped lastLine, getInsideArc firstLine lastLineFlipped] Nothing]] where - firstSeg@(fs, fsErr) = eToPL $ SL.head $ slist $ SL.head inSegSets - firstSegFlipped = (flipL fs, fsErr) - lastSeg@(ls, lsErr) = eToPL $ SL.head $ slist $ SL.last inSegSets - lastSegFlipped = (flipL ls, lsErr) - [a] -> INodeSet $ slist [[makeINode [getInsideArc (eToPL lastSeg) (eToPL shortSide), getInsideArc (eToPL firstSeg) (eToPL shortSide)] (Just (flipL $ outOf a, errOfOut a))]] + firstLine@(fs, fsErr) = eToPL $ SL.head $ slist $ SL.head inSegSets + firstLineFlipped = (flipL fs, fsErr) + lastLine@(ls, lsErr) = eToPL $ SL.head $ slist $ SL.last inSegSets + lastLineFlipped = (flipL ls, lsErr) + [a] -> INodeSet $ slist [[makeINode [getInsideArc lastLine shortSide, getInsideArc firstLine shortSide] (Just (flipL $ outOf a, errOfOut a))]] where - firstSeg = fromMaybe (error "no first segment?") $ safeHead $ slist longSide - lastSeg = SL.last $ slist longSide - (shortSide,longSide) - | null (SL.head inSegSets) = (SL.head $ slist $ SL.last inSegSets, SL.head inSegSets) - | otherwise = (SL.head $ slist $ SL.head inSegSets, SL.last inSegSets) + firstLine = eToPL $ fromMaybe (error "no first segment?") $ safeHead $ slist longSide + lastLine = eToPL $ SL.last $ slist longSide + (shortSide, longSide) + | null (SL.head inSegSets) = (eToPL $ SL.head $ slist $ SL.last inSegSets, SL.head inSegSets) + | otherwise = (eToPL $ SL.head $ slist $ SL.head inSegSets, SL.last inSegSets) (_:_) -> error $ "too many items in makeInitialGeneration.\n" <> show initialENodes <> "\n" From c42353c61962cca3d83cb9f1c38a7fd624895253 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 11 Dec 2022 11:22:58 +0000 Subject: [PATCH 144/206] remove fudge factor, and add more error checking. --- Graphics/Slicer/Math/Skeleton/Concave.hs | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index cf71696ad..3b679413a 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -54,14 +54,12 @@ import Graphics.Slicer.Math.Arcs (getFirstArc, getInsideArc, getOutsideArc) import Graphics.Slicer.Math.Contour (lineSegsOfContour) -import Graphics.Slicer.Math.Definitions (Contour, LineSeg(LineSeg), Point2, endPoint, mapWithFollower, fudgeFactor, startPoint) +import Graphics.Slicer.Math.Definitions (Contour, LineSeg(LineSeg), Point2, endPoint, mapWithFollower, startPoint) import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum)) import Graphics.Slicer.Math.Intersections (intersectionBetween, intersectionOf, isAntiCollinear, isAntiParallel, isCollinear, isParallel, noIntersection) -import Graphics.Slicer.Math.Lossy as Lossy (distancePPointToPLine) - import Graphics.Slicer.Math.PGA (Arcable(errOfOut, hasArc, outOf), Pointable(canPoint, pPointOf), PLine2, PLine2Err, distance2PP, eToPL, flipL, outAndErrOf, pLineIsLeft, distancePPointToPLineWithErr) import Graphics.Slicer.Math.Skeleton.Definitions (ENode(ENode), ENodeSet(ENodeSet), INode(INode), INodeSet(INodeSet), NodeTree(NodeTree), concavePLines, getFirstLineSeg, getLastLineSeg, finalOutOf, firstInOf, getPairs, indexPLinesTo, insOf, lastINodeOf, linePairs, makeINode, sortedPLinesWithErr, isLoop) @@ -192,7 +190,9 @@ averageNodes n1 n2 -- | Take a pair of arcables, and return their outOfs, in a sorted order. sortedPair :: (Arcable a, Arcable b) => a -> b -> [(PLine2, PLine2Err)] -sortedPair n1 n2 = sortedPLinesWithErr [outAndErrOf n1, outAndErrOf n2] +sortedPair n1 n2 + | hasArc n1 && hasArc n2 = sortedPLinesWithErr [outAndErrOf n1, outAndErrOf n2] + | otherwise = error "Cannot get the average of nodes if one of the nodes does not have an out!\n" -- | Make a first generation node. makeENode :: Point2 -> Point2 -> Point2 -> ENode @@ -232,10 +232,9 @@ convexNodes contour = catMaybes $ onlyNodes <$> zip (linePairs contour) (mapWith -- | A better anticollinear checker. -- distance is used here to get a better anticollinear than PGA has, because we have a point, and floating point hurts us. -- FIXME: shouldn't this be pulled into PGA.hs, as part of an outsIntersectIn? -nodesAreAntiCollinear :: (Pointable a, Arcable a, Pointable b, Arcable b) => a -> b -> Bool +nodesAreAntiCollinear :: (Arcable a, Arcable b) => a -> b -> Bool nodesAreAntiCollinear node1 node2 - | hasArc node1 && hasArc node2 && isAntiCollinear (outAndErrOf node1) (outAndErrOf node2) = True - | canPoint node1 && canPoint node2 && hasArc node1 && hasArc node2 = (distancePPointToPLine (pPointOf node1) (outOf node2) < fudgeFactor*50) && (distancePPointToPLine (pPointOf node2) (outOf node1) < fudgeFactor*50) + | hasArc node1 && hasArc node2 = isAntiCollinear (outAndErrOf node1) (outAndErrOf node2) | otherwise = False -- | Walk the result tree, and find our enodes. Used to test the property that a walk of our result tree should result in the input ENodes in order. @@ -815,7 +814,7 @@ skeletonOfNodes connectedLoop inSegSets iNodes = intersectingNeighboringNodePairsOf inNodePairs = mapMaybe (\(node1, node2) -> if intersectsInPoint node1 node2 then Just (node1, node2) else Nothing) $ inNodePairs -- | find nodes that have output segments that are antiCollinear with one another. - antiCollinearNodePairsOf :: (Pointable a, Arcable a) => [a] -> [(a, a)] + antiCollinearNodePairsOf :: (Arcable a) => [a] -> [(a, a)] antiCollinearNodePairsOf inNodes = mapMaybe (\(node1, node2) -> if nodesAreAntiCollinear node1 node2 then Just (node1, node2) else Nothing) $ getPairs inNodes -- | for a given pair of nodes, find the longest distance between one of the two nodes and the intersection of the two output plines. From 4b153fc1ca91528c00176af06a8bb3d7d799161c Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 11 Dec 2022 15:17:35 +0000 Subject: [PATCH 145/206] remove eToCPPoint2, replacing it with the equivilent function eToPP. --- Graphics/Slicer/Math/Arcs.hs | 2 +- Graphics/Slicer/Math/Lossy.hs | 7 +------ Graphics/Slicer/Math/Skeleton/Cells.hs | 6 +++--- Graphics/Slicer/Math/Skeleton/Motorcycles.hs | 14 +++++++------- tests/Math/PGA.hs | 2 +- 5 files changed, 13 insertions(+), 18 deletions(-) diff --git a/Graphics/Slicer/Math/Arcs.hs b/Graphics/Slicer/Math/Arcs.hs index 85edcb5cb..89b540252 100644 --- a/Graphics/Slicer/Math/Arcs.hs +++ b/Graphics/Slicer/Math/Arcs.hs @@ -114,7 +114,7 @@ getObtuseAngleBisectorFromPointedLines ppoint1 line1 ppoint2 line2 l1TowardPoint = towardIntersection ppoint1 line1 intersectionPoint l2TowardPoint = towardIntersection ppoint2 line2 intersectionPoint --- | Determine if the line segment formed by the two given points starts with the first point, or the second. +-- | Determine if the line formed by the two given points goes through the first point first, or the second. towardIntersection :: (ProjectivePoint2 a, ProjectiveLine2 b, ProjectivePoint2 c) => (a, PPoint2Err) -> (b, PLine2Err) -> (c, PPoint2Err) -> Bool towardIntersection point1@(pp1, _) (pl1, _) point2@(pp2, _) | d <= realToFrac (ulpVal dErr) = error $ "cannot resolve points finely enough.\nPPoint1: " <> show pp1 <> "\nPPoint2: " <> show pp2 <> "\nPLineIn: " <> show pl1 <> "\nnewPLine: " <> show newPLine <> "\n" diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index 1b54cac94..2cc2cc326 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -23,7 +23,6 @@ module Graphics.Slicer.Math.Lossy ( distanceBetweenPPoints, distanceBetweenPLines, distancePPointToPLine, - eToCPPoint2, eToNPLine2, eToPLine2, getFirstArc, @@ -47,7 +46,7 @@ import Graphics.Slicer.Math.Definitions (LineSeg, Point2, makeLineSeg) import qualified Graphics.Slicer.Math.Arcs as Arcs (getFirstArc, getInsideArc) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PPoint2, ProjectiveLine2, ProjectivePoint2, canonicalizeP, distance2PP, distance2PL, distancePPointToPLineWithErr, eToPL, eToPP, interpolate2PP, join2PP, normalizeL, pPointOnPerpWithErr, pToEP, translateL) +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PPoint2, ProjectiveLine2, ProjectivePoint2, canonicalizeP, distance2PP, distance2PL, distancePPointToPLineWithErr, eToPL, interpolate2PP, join2PP, normalizeL, pPointOnPerpWithErr, pToEP, translateL) -- | canonicalize a euclidian point. canonicalizePPoint2 :: PPoint2 -> CPPoint2 @@ -63,10 +62,6 @@ distanceBetweenPLines nPLine1 nPLine2 = fst $ distance2PL nPLine1 nPLine2 distancePPointToPLine :: (ProjectivePoint2 a, ProjectiveLine2 b) => a -> b -> ℝ distancePPointToPLine point line = fst $ distancePPointToPLineWithErr (point, mempty) (line, mempty) --- | Create a projective point from a euclidian point. -eToCPPoint2 :: Point2 -> CPPoint2 -eToCPPoint2 point = eToPP point - -- | Create a normalized projective line from a euclidian line segment. eToNPLine2 :: LineSeg -> NPLine2 eToNPLine2 l1 = fst $ normalizeL $ fst $ eToPL l1 diff --git a/Graphics/Slicer/Math/Skeleton/Cells.hs b/Graphics/Slicer/Math/Skeleton/Cells.hs index 650614fc3..2860bca9f 100644 --- a/Graphics/Slicer/Math/Skeleton/Cells.hs +++ b/Graphics/Slicer/Math/Skeleton/Cells.hs @@ -56,7 +56,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (ulpVal) import Graphics.Slicer.Math.Intersections (intersectionBetweenArcsOf, isAntiCollinear, outputIntersectsPLineAt) -import Graphics.Slicer.Math.Lossy (distanceBetweenPPoints, eToCPPoint2, eToPLine2, pToEPoint2) +import Graphics.Slicer.Math.Lossy (distanceBetweenPPoints, eToPLine2, pToEPoint2) import Graphics.Slicer.Math.PGA (Arcable(outOf), CPPoint2, Pointable(canPoint, ePointOf, pPointOf), angleBetween2PL, distance2PP, eToPL, eToPP, outAndErrOf) @@ -191,9 +191,9 @@ findNextCell (RemainingContour (Slist [(Slist lineSegs _, divides)] _) ) = EQ -> fst (distance2PP (startPPoint $ fst $ fst div1, mempty) (toPPoint2 $ snd $ fst div1, mempty)) `compare` fst (distance2PP (startPPoint $ fst $ fst div2, mempty) (toPPoint2 $ snd $ fst div2, mempty)) where toPPoint2 :: Either Point2 CPPoint2 -> CPPoint2 - toPPoint2 (Left point2) = eToCPPoint2 point2 + toPPoint2 (Left point2) = eToPP point2 toPPoint2 (Right ppoint2) = ppoint2 - startPPoint (LineSeg start _) = eToCPPoint2 start + startPPoint (LineSeg start _) = eToPP start -- | Where the intersection intersects a contour. data AtOrAround = At diff --git a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs index 925d3d3a8..b12182d27 100644 --- a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs +++ b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs @@ -50,7 +50,7 @@ import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, mapWithNeighb import Graphics.Slicer.Math.Intersections (intersectionOf, isAntiCollinear, noIntersection) -import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, pPointBetweenPPoints, distanceBetweenPPoints, eToCPPoint2, eToPLine2, normalizePLine2, pToEPoint2) +import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, pPointBetweenPPoints, distanceBetweenPPoints, eToPLine2, normalizePLine2, pToEPoint2) import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), PPoint2, PPoint2Err, Arcable(outOf), Pointable(canPoint, ePointOf, pPointOf), eToPL, flipL, pLineIsLeft, pPointsOnSameSideOfPLine, PIntersection(IntersectsIn,PAntiCollinear), ProjectivePoint2, angleBetween2PL, distance2PP, eToPP, join2PP, outAndErrOf, outputIntersectsLineSeg, plinesIntersectIn, translateL) @@ -241,13 +241,13 @@ motorcycleMightIntersectWith lineSegs motorcycle (_, Right intersectionPPoint2) -> distanceBetweenPPoints motorcyclePoint intersectionPPoint1 `compare` distanceBetweenPPoints motorcyclePoint intersectionPPoint2 (_, Left intersectionPoint2) -> - distanceBetweenPPoints motorcyclePoint intersectionPPoint1 `compare` distanceBetweenPPoints motorcyclePoint (eToCPPoint2 intersectionPoint2) + distanceBetweenPPoints motorcyclePoint intersectionPPoint1 `compare` distanceBetweenPPoints motorcyclePoint (eToPP intersectionPoint2) (_, Left intersectionPoint1) -> case i2 of (_, Right intersectionPPoint2) -> - distanceBetweenPPoints motorcyclePoint (eToCPPoint2 intersectionPoint1) `compare` distanceBetweenPPoints motorcyclePoint intersectionPPoint2 + distanceBetweenPPoints motorcyclePoint (eToPP intersectionPoint1) `compare` distanceBetweenPPoints motorcyclePoint intersectionPPoint2 (_, Left intersectionPoint2) -> - distanceBetweenPPoints motorcyclePoint (eToCPPoint2 intersectionPoint1) `compare` distanceBetweenPPoints motorcyclePoint (eToCPPoint2 intersectionPoint2) + distanceBetweenPPoints motorcyclePoint (eToPP intersectionPoint1) `compare` distanceBetweenPPoints motorcyclePoint (eToPP intersectionPoint2) filterIntersection :: (LineSeg, Either Point2 CPPoint2) -> Maybe (LineSeg, Either Point2 CPPoint2) filterIntersection intersection = case intersection of (_, Right intersectionCPPoint) -> if intersectionCPPointIsBehind intersectionCPPoint @@ -283,13 +283,13 @@ motorcycleIntersectsAt contour motorcycle = case intersections of (_, Right intersectionPPoint2) -> distanceBetweenPPoints motorcyclePoint intersectionPPoint1 `compare` distanceBetweenPPoints motorcyclePoint intersectionPPoint2 (_, Left intersectionPoint2) -> - distanceBetweenPPoints motorcyclePoint intersectionPPoint1 `compare` distanceBetweenPPoints motorcyclePoint (eToCPPoint2 intersectionPoint2) + distanceBetweenPPoints motorcyclePoint intersectionPPoint1 `compare` distanceBetweenPPoints motorcyclePoint (eToPP intersectionPoint2) (_, Left intersectionPoint1) -> case i2 of (_, Right intersectionPPoint2) -> - distanceBetweenPPoints motorcyclePoint (eToCPPoint2 intersectionPoint1) `compare` distanceBetweenPPoints motorcyclePoint intersectionPPoint2 + distanceBetweenPPoints motorcyclePoint (eToPP intersectionPoint1) `compare` distanceBetweenPPoints motorcyclePoint intersectionPPoint2 (_, Left intersectionPoint2) -> - distanceBetweenPPoints motorcyclePoint (eToCPPoint2 intersectionPoint1) `compare` distanceBetweenPPoints motorcyclePoint (eToCPPoint2 intersectionPoint2) + distanceBetweenPPoints motorcyclePoint (eToPP intersectionPoint1) `compare` distanceBetweenPPoints motorcyclePoint (eToPP intersectionPoint2) where filterIntersection :: (LineSeg, Either Point2 CPPoint2) -> Maybe (LineSeg, Either Point2 CPPoint2) filterIntersection intersection = case intersection of diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index 6a2d79216..148c8b4ed 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -56,7 +56,7 @@ import Graphics.Slicer.Math.Definitions(Point2(Point2), Contour(LineSegContour), -- Our Geometric Algebra library. import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(GEZero, GEPlus, G0), GVal(GVal), GVec(GVec), UlpSum(UlpSum), addValPairWithErr, subValPairWithErr, addValWithErr, ulpVal, subVal, addVecPair, subVecPair, mulScalarVecWithErr, divVecScalarWithErr, scalarPart, vectorPart, (•), (∧), (⋅), (⎣), (⎤)) -import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenPLines, distancePPointToPLine, eToCPPoint2, eToPLine2, getFirstArc, join2PPoint2, normalizePLine2, pPointOnPerp) +import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenPLines, distancePPointToPLine, eToPLine2, getFirstArc, join2PPoint2, normalizePLine2, pPointOnPerp) -- Our 2D Projective Geometric Algebra library. import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PLine2Err(PLine2Err), canonicalizeP, distance2PP, distancePPointToPLineWithErr, eToPL, eToPP, eToPP, interpolate2PP, intersect2PL, translateL, translateRotatePPoint2WithErr, angleBetween2PL, flipL, join2PP, makePPoint2, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, distancePPointToPLineWithErr, errOfOut, pPointOnPerpWithErr, outOf, pPointOf, outputIntersectsLineSeg) From 99b3d9806b2b6a4af4d7af1b4829553a26282d23 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 11 Dec 2022 16:08:53 +0000 Subject: [PATCH 146/206] create translateRotatePPoint2. --- Graphics/Slicer/Math/Lossy.hs | 7 ++++++- Graphics/Slicer/Math/RandomGeometry.hs | 14 +++++++------- 2 files changed, 13 insertions(+), 8 deletions(-) diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index 2cc2cc326..46cc72971 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -34,6 +34,7 @@ module Graphics.Slicer.Math.Lossy ( pPointBetweenPPoints, pPointOnPerp, pToEPoint2, + translateRotatePPoint2, translatePLine2 ) where @@ -46,7 +47,7 @@ import Graphics.Slicer.Math.Definitions (LineSeg, Point2, makeLineSeg) import qualified Graphics.Slicer.Math.Arcs as Arcs (getFirstArc, getInsideArc) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PPoint2, ProjectiveLine2, ProjectivePoint2, canonicalizeP, distance2PP, distance2PL, distancePPointToPLineWithErr, eToPL, interpolate2PP, join2PP, normalizeL, pPointOnPerpWithErr, pToEP, translateL) +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PPoint2, ProjectiveLine2, ProjectivePoint2, canonicalizeP, distance2PP, distance2PL, distancePPointToPLineWithErr, eToPL, interpolate2PP, join2PP, normalizeL, pPointOnPerpWithErr, pToEP, translateL, translateRotatePPoint2WithErr) -- | canonicalize a euclidian point. canonicalizePPoint2 :: PPoint2 -> CPPoint2 @@ -105,6 +106,10 @@ pPointBetweenPPoints startOfSeg stopOfSeg weight1 weight2 = fst $ interpolate2PP pPointOnPerp :: (ProjectiveLine2 a, ProjectivePoint2 b) => a -> b -> ℝ -> PPoint2 pPointOnPerp pline ppoint d = fst $ pPointOnPerpWithErr pline ppoint d +-- | Translate a point a given distance away from where it is, rotating it a given amount clockwise (in radians) around it's original location, with 0 degrees being aligned to the X axis. +translateRotatePPoint2 :: (ProjectivePoint2 a) => a -> ℝ -> ℝ -> PPoint2 +translateRotatePPoint2 ppoint d rotation = fst $ translateRotatePPoint2WithErr ppoint d rotation + -- | translate a PLine2 along it's perpendicular bisector. translatePLine2 :: PLine2 -> ℝ -> PLine2 translatePLine2 pline distance = fst $ translateL pline distance diff --git a/Graphics/Slicer/Math/RandomGeometry.hs b/Graphics/Slicer/Math/RandomGeometry.hs index bec732326..6db9c543a 100644 --- a/Graphics/Slicer/Math/RandomGeometry.hs +++ b/Graphics/Slicer/Math/RandomGeometry.hs @@ -90,9 +90,9 @@ import Graphics.Slicer.Math.Definitions (Contour, Point2(Point2), LineSeg, makeL import Graphics.Slicer.Math.Ganja (dumpGanjas, toGanja) -import Graphics.Slicer.Math.Lossy (eToPLine2, pToEPoint2) +import Graphics.Slicer.Math.Lossy (eToPLine2, pToEPoint2, translateRotatePPoint2) -import Graphics.Slicer.Math.PGA (PLine2(PLine2), PLine2Err, eToPL, eToPP, flipL, join2EP, normalizeL, translateRotatePPoint2WithErr, pPointOf, NPLine2(NPLine2)) +import Graphics.Slicer.Math.PGA (PLine2(PLine2), PLine2Err, eToPL, eToPP, flipL, join2EP, normalizeL, pPointOf, NPLine2(NPLine2)) import Graphics.Slicer.Math.Skeleton.Concave (makeENode) @@ -374,7 +374,7 @@ randomStarPoly centerX centerY radianDistPairs = fromMaybe dumpError $ maybeFlip where contour = makePointContour points points = pToEPoint2 <$> pointsAroundCenter - pointsAroundCenter = (\(distanceFromPoint, angle) -> fst $ translateRotatePPoint2WithErr centerPPoint (coerce distanceFromPoint) (coerce angle)) <$> radianDistPairs + pointsAroundCenter = (\(distanceFromPoint, angle) -> translateRotatePPoint2 centerPPoint (coerce distanceFromPoint) (coerce angle)) <$> radianDistPairs centerPPoint = eToPP $ Point2 (centerX, centerY) dumpError = error $ "failed to flip a contour:" <> dumpGanjas [toGanja contour, toGanja (Point2 (centerX, centerY)), toGanja outsidePLine] <> "\n" where @@ -389,8 +389,8 @@ randomENode x y d1 rawR1 d2 rawR2 = makeENode p1 intersectionPoint p2 r1 = rawR1 / 2 r2 = r1 + (rawR2 / 2) intersectionPoint = Point2 (x,y) - pp1 = fst $ translateRotatePPoint2WithErr intersectionPPoint (coerce d1) (coerce r1) - pp2 = fst $ translateRotatePPoint2WithErr intersectionPPoint (coerce d2) (coerce r2) + pp1 = translateRotatePPoint2 intersectionPPoint (coerce d1) (coerce r1) + pp2 = translateRotatePPoint2 intersectionPPoint (coerce d2) (coerce r2) p1 = pToEPoint2 pp1 p2 = pToEPoint2 pp2 intersectionPPoint = eToPP intersectionPoint @@ -404,8 +404,8 @@ randomINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 = makeINode [maybeFlippedpl1,m pl2 = (\(NPLine2 a,b) -> (PLine2 a,b)) $ normalizeL $ flipL $ eToPLine2 $ getLastLineSeg eNode intersectionPPoint = pPointOf eNode eNode = randomENode x y d1 rawR1 d2 rawR2 - pp1 = fst $ translateRotatePPoint2WithErr intersectionPPoint (coerce d1) (coerce r1) - pp2 = fst $ translateRotatePPoint2WithErr intersectionPPoint (coerce d2) (coerce r2) + pp1 = translateRotatePPoint2 intersectionPPoint (coerce d1) (coerce r1) + pp2 = translateRotatePPoint2 intersectionPPoint (coerce d2) (coerce r2) maybeFlippedpl1 = (if flipIn1 then flipL (fst pl1) else (fst pl1), snd pl1) maybeFlippedpl2 = (if flipIn2 then flipL (fst pl2) else (fst pl2), snd pl2) bisector1 = normalizeL outsideRes From 73d085412356fa258d77a6bca96adafb8dd89cf6 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 11 Dec 2022 18:02:31 +0000 Subject: [PATCH 147/206] remove unnecessary normalisation when generation random INodes, and eliminate unneeded randomPL. --- Graphics/Slicer/Math/RandomGeometry.hs | 14 ++++++-------- tests/Math/PGA.hs | 6 +++--- 2 files changed, 9 insertions(+), 11 deletions(-) diff --git a/Graphics/Slicer/Math/RandomGeometry.hs b/Graphics/Slicer/Math/RandomGeometry.hs index 6db9c543a..6903534c4 100644 --- a/Graphics/Slicer/Math/RandomGeometry.hs +++ b/Graphics/Slicer/Math/RandomGeometry.hs @@ -46,7 +46,6 @@ module Graphics.Slicer.Math.RandomGeometry ( randomLineSeg, randomLineSegFromOriginNotX1Y1, randomLineSegFromPointNotX1Y1, - randomPL, randomPLine, randomPLineThroughOrigin, randomPLineThroughPoint, @@ -90,7 +89,7 @@ import Graphics.Slicer.Math.Definitions (Contour, Point2(Point2), LineSeg, makeL import Graphics.Slicer.Math.Ganja (dumpGanjas, toGanja) -import Graphics.Slicer.Math.Lossy (eToPLine2, pToEPoint2, translateRotatePPoint2) +import Graphics.Slicer.Math.Lossy (pToEPoint2, translateRotatePPoint2) import Graphics.Slicer.Math.PGA (PLine2(PLine2), PLine2Err, eToPL, eToPP, flipL, join2EP, normalizeL, pPointOf, NPLine2(NPLine2)) @@ -161,6 +160,7 @@ instance (Ord a, Num a, Fractional a) => Fractional (Positive a) where fromRational a = Positive $ fromRational a -- | Generate a random triangle. +-- FIXME: what stops this from trying to generate a triangle with all three points on the same line? randomTriangle :: ℝ -> ℝ -> ListThree (Radian ℝ) -> ListThree (Positive ℝ) -> Contour randomTriangle centerX centerY rawRadians rawDists = randomStarPoly centerX centerY $ makePairs dists radians where @@ -400,8 +400,10 @@ randomINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 = makeINode [maybeFlippedpl1,m where r1 = rawR1 / 2 r2 = r1 + (rawR2 / 2) - pl1 = (\(NPLine2 a,b) -> (PLine2 a,b)) $ normalizeL $ eToPLine2 $ getFirstLineSeg eNode - pl2 = (\(NPLine2 a,b) -> (PLine2 a,b)) $ normalizeL $ flipL $ eToPLine2 $ getLastLineSeg eNode + pl1 = eToPL $ getFirstLineSeg eNode + pl2 = (flipL $ ls, lsErr) + where + (ls, lsErr) = eToPL $ getLastLineSeg eNode intersectionPPoint = pPointOf eNode eNode = randomENode x y d1 rawR1 d2 rawR2 pp1 = translateRotatePPoint2 intersectionPPoint (coerce d1) (coerce r1) @@ -419,10 +421,6 @@ randomPLine x y dx dy = fst $ randomPLineWithErr x y dx dy randomPLineWithErr :: ℝ -> ℝ -> NonZero ℝ -> NonZero ℝ -> (PLine2, PLine2Err) randomPLineWithErr x y dx dy = eToPL $ makeLineSeg (Point2 (x, y)) (Point2 (coerce dx, coerce dy)) --- | A helper function. constructs a random PLine. -randomPL :: ℝ -> ℝ -> NonZero ℝ -> NonZero ℝ -> (PLine2, PLine2Err) -randomPL x y dx dy = eToPL $ makeLineSeg (Point2 (x, y)) (Point2 (coerce dx, coerce dy)) - -- | A helper function. constructs a random LineSeg. randomLineSeg :: ℝ -> ℝ -> ℝ -> ℝ -> LineSeg randomLineSeg x y dx dy = makeLineSeg (Point2 (x, y)) (Point2 (dx,dy)) diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index 148c8b4ed..79644fe0d 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -91,7 +91,7 @@ import Math.Util ((-->), (-/>)) import Graphics.Slicer.Math.Ganja (dumpGanjas, toGanja) -- Our Geometry generation library. For random shaped geometry. -import Graphics.Slicer.Math.RandomGeometry (ListThree, Radian(Radian), cellFrom, edgesOf, generationsOf, randomPL, randomTriangle, randomRectangle, randomSquare, randomConvexQuad, randomConvexSingleRightQuad, randomConvexDualRightQuad, randomConvexBisectableQuad, randomConcaveChevronQuad, randomENode, randomINode, randomLineSeg, randomPLine, randomPLineWithErr, remainderFrom, onlyOne, onlyOneOf, randomPLineThroughOrigin, randomX1Y1LineSegToOrigin, randomLineSegFromOriginNotX1Y1, randomX1Y1LineSegToPoint, randomLineSegFromPointNotX1Y1, randomPLineThroughPoint) +import Graphics.Slicer.Math.RandomGeometry (ListThree, Radian(Radian), cellFrom, edgesOf, generationsOf, randomTriangle, randomRectangle, randomSquare, randomConvexQuad, randomConvexSingleRightQuad, randomConvexDualRightQuad, randomConvexBisectableQuad, randomConcaveChevronQuad, randomENode, randomINode, randomLineSeg, randomPLine, randomPLineWithErr, remainderFrom, onlyOne, onlyOneOf, randomPLineThroughOrigin, randomX1Y1LineSegToOrigin, randomLineSegFromOriginNotX1Y1, randomX1Y1LineSegToPoint, randomLineSegFromPointNotX1Y1, randomPLineThroughPoint) -- Default all numbers in this file to being of the type ImplicitCAD uses for values. default (ℝ) @@ -1435,7 +1435,7 @@ prop_PLineIntersectsAtXAxis x y rawX2 y2 m axisIntersectionPoint = eToPP $ Point2 ((fromRight (error "not right?") $ fst $ fromJust axisIntersection), 0) axisIntersection = xIntercept (randomPLine1, pline1Err) (intersectionPPoint2, (_,_,intersectionErr)) = intersect2PL randomPLine1 axisPLine - (randomPLine1, pline1Err) = randomPL x y rawX2 (coerce y2) + (randomPLine1, pline1Err) = randomPLineWithErr x y rawX2 (coerce y2) -- Error in this line should be in directions that should not matter. (axisPLine, _) = eToPL $ makeLineSeg (Point2 (0,0)) (Point2 (coerce m,0)) @@ -1464,7 +1464,7 @@ prop_PLineIntersectsAtYAxis x y x2 rawY2 m axisIntersectionPoint = eToPP $ Point2 (0,(fromRight (error "not right?") $ fst $ fromJust axisIntersection)) axisIntersection = yIntercept (randomPLine1, pline1Err) (intersectionPPoint2, (_,_,intersectionErr)) = intersect2PL randomPLine1 axisPLine - (randomPLine1, pline1Err) = randomPL (coerce x) y (coerce x2) (coerce y2) + (randomPLine1, pline1Err) = randomPLineWithErr (coerce x) y (coerce x2) (coerce y2) -- Error in this line should be in directions that should not matter. (axisPLine, _) = eToPL $ makeLineSeg (Point2 (0,0)) (Point2 (0,coerce m)) y2 :: ℝ From 8c6b5d2e31d183f47d7e05b82dcfc4f1c59087bb Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 11 Dec 2022 18:07:16 +0000 Subject: [PATCH 148/206] simplify logic, and drop a few more unnecessary normalizations --- Graphics/Slicer/Math/RandomGeometry.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/Graphics/Slicer/Math/RandomGeometry.hs b/Graphics/Slicer/Math/RandomGeometry.hs index 6903534c4..c6b20875a 100644 --- a/Graphics/Slicer/Math/RandomGeometry.hs +++ b/Graphics/Slicer/Math/RandomGeometry.hs @@ -58,7 +58,7 @@ module Graphics.Slicer.Math.RandomGeometry ( remainderFrom ) where -import Prelude (Bool, Enum, Eq, Fractional, Num, Ord, Show, Int, (<>), (<>), (<$>), ($), (==), (+), (-), (*), (<), (/), (>), (<=), (&&), abs, error, fromInteger, fromRational, fst, mempty, mod, otherwise, replicate, show, signum, snd) +import Prelude (Bool, Enum, Eq, Fractional, Num, Ord, Show, Int, (<>), (<>), (<$>), ($), (==), (+), (-), (*), (<), (/), (>), (<=), (&&), abs, error, fromInteger, fromRational, fst, mempty, mod, otherwise, replicate, show, signum) import Data.Coerce (coerce) @@ -400,18 +400,18 @@ randomINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 = makeINode [maybeFlippedpl1,m where r1 = rawR1 / 2 r2 = r1 + (rawR2 / 2) - pl1 = eToPL $ getFirstLineSeg eNode - pl2 = (flipL $ ls, lsErr) + (pl1, pl1Err) = eToPL $ getFirstLineSeg eNode + (pl2, pl2Err) = (flipL $ ls, lsErr) where (ls, lsErr) = eToPL $ getLastLineSeg eNode intersectionPPoint = pPointOf eNode eNode = randomENode x y d1 rawR1 d2 rawR2 pp1 = translateRotatePPoint2 intersectionPPoint (coerce d1) (coerce r1) pp2 = translateRotatePPoint2 intersectionPPoint (coerce d2) (coerce r2) - maybeFlippedpl1 = (if flipIn1 then flipL (fst pl1) else (fst pl1), snd pl1) - maybeFlippedpl2 = (if flipIn2 then flipL (fst pl2) else (fst pl2), snd pl2) + maybeFlippedpl1 = (if flipIn1 then flipL pl1 else pl1, pl1Err) + maybeFlippedpl2 = (if flipIn2 then flipL pl2 else pl2, pl2Err) bisector1 = normalizeL outsideRes - (outsideRes, outsideResErr) = getOutsideArc (pp1, mempty) (normalizeL $ fst maybeFlippedpl1) (pp2, mempty) (normalizeL $ fst maybeFlippedpl2) + (outsideRes, outsideResErr) = getOutsideArc (pp1, mempty) maybeFlippedpl1 (pp2, mempty) maybeFlippedpl2 -- | A helper function. constructs a random PLine. randomPLine :: ℝ -> ℝ -> NonZero ℝ -> NonZero ℝ -> PLine2 From 92a5f756e170aa058411f371e8e517c689b4a38e Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Tue, 13 Dec 2022 19:24:40 +0000 Subject: [PATCH 149/206] use concatMap instead of concat and <$>. --- Graphics/Slicer/Math/RandomGeometry.hs | 3 +-- Graphics/Slicer/Math/Skeleton/Concave.hs | 14 +++++++------- 2 files changed, 8 insertions(+), 9 deletions(-) diff --git a/Graphics/Slicer/Math/RandomGeometry.hs b/Graphics/Slicer/Math/RandomGeometry.hs index c6b20875a..fa2550d2b 100644 --- a/Graphics/Slicer/Math/RandomGeometry.hs +++ b/Graphics/Slicer/Math/RandomGeometry.hs @@ -401,7 +401,7 @@ randomINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 = makeINode [maybeFlippedpl1,m r1 = rawR1 / 2 r2 = r1 + (rawR2 / 2) (pl1, pl1Err) = eToPL $ getFirstLineSeg eNode - (pl2, pl2Err) = (flipL $ ls, lsErr) + (pl2, pl2Err) = (flipL ls, lsErr) where (ls, lsErr) = eToPL $ getLastLineSeg eNode intersectionPPoint = pPointOf eNode @@ -425,7 +425,6 @@ randomPLineWithErr x y dx dy = eToPL $ makeLineSeg (Point2 (x, y)) (Point2 (coer randomLineSeg :: ℝ -> ℝ -> ℝ -> ℝ -> LineSeg randomLineSeg x y dx dy = makeLineSeg (Point2 (x, y)) (Point2 (dx,dy)) - -- | A PLine that does not follow the X = Y line, and does not follow the other given line. randomPLineThroughOrigin :: ℝ -> ℝ -> (PLine2, PLine2Err) randomPLineThroughOrigin x y = eToPL $ makeLineSeg (Point2 (x,y)) (Point2 (0,0)) diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index 3b679413a..aa889fadb 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -28,7 +28,7 @@ module Graphics.Slicer.Math.Skeleton.Concave (skeletonOfConcaveRegion, findINodes, makeENode, makeENodes, averageNodes, eNodesOfOutsideContour) where -import Prelude (Eq, Show, Bool(True, False), Either(Left, Right), String, Ord, Ordering(GT,LT), notElem, otherwise, ($), (>), (<), (<$>), (==), (/=), (>=), error, (&&), fst, and, (<>), show, not, max, concat, compare, uncurry, null, (||), min, snd, filter, zip, any, (*), (+), Int, (.), (-), mempty, realToFrac) +import Prelude (Eq, Show, Bool(True, False), Either(Left, Right), String, Ord, Ordering(GT,LT), notElem, otherwise, ($), (>), (<), (<$>), (==), (/=), (>=), error, (&&), fst, and, (<>), show, not, max, compare, uncurry, null, (||), min, snd, filter, zip, any, (*), (+), Int, (.), (-), concatMap, mempty, realToFrac) import Prelude as PL (head, last, tail, init) @@ -139,7 +139,7 @@ isHallway (NodeTree _ iNodeSet) = iNodeSetHasOneMember iNodeSet -- | Create the set of ENodes for a set of segments makeInitialGeneration :: Bool -> Slist [LineSeg] -> [ENode] -makeInitialGeneration gensAreLoop inSegSets = concat (firstENodes <$> inSegSets) <> maybeLoop +makeInitialGeneration gensAreLoop inSegSets = concatMap firstENodes inSegSets <> maybeLoop where -- Generate the first generation of nodes, from the passed in line segments. -- If the line segments are a loop, use the appropriate function to create the initial Nodes. @@ -246,7 +246,7 @@ findENodesInOrder eNodeSet@(ENodeSet (Slist [(_,_)] _)) generations = findENodes findENodesRecursive myGens = case unsnoc myGens of Nothing -> [] - (Just (ancestorGens,workingGen)) -> concat $ findENodesOfInRecursive <$> nub (insOf (onlyINodeIn workingGen) <> maybePLineOut (onlyINodeIn workingGen)) + (Just (ancestorGens,workingGen)) -> concatMap findENodesOfInRecursive $ nub (insOf (onlyINodeIn workingGen) <> maybePLineOut (onlyINodeIn workingGen)) where maybePLineOut :: INode -> [(PLine2,PLine2Err)] maybePLineOut myINode = if hasArc myINode @@ -266,7 +266,7 @@ findENodesInOrder eNodeSet@(ENodeSet (Slist [(_,_)] _)) generations = findENodes where -- strip the new last generation until it only contains the INode matching myPLine. lastGenWithOnlyMyINode :: [[INode]] - lastGenWithOnlyMyINode = case filter (\a -> outOf a == fst myPLine) newLastGen of + lastGenWithOnlyMyINode = case filter (\a -> hasArc a && isCollinear (outAndErrOf a) myPLine) newLastGen of [] -> [] a -> [[first a]] where @@ -676,13 +676,13 @@ skeletonOfNodes connectedLoop inSegSets iNodes = | null foundENodes = inSegSets | otherwise = case inSegSets of (Slist [] _) -> error "cannot remove segment from empty set." - (Slist segLists _) -> slist $ concat $ removeENodesFromSegList (slist foundENodes) <$> segLists + (Slist segLists _) -> slist $ concatMap (removeENodesFromSegList (slist foundENodes)) segLists where removeENodesFromSegList :: Slist ENode -> [LineSeg] -> [[LineSeg]] removeENodesFromSegList eNodesIn lineSegs = filterTooShorts $ case eNodesIn of (Slist [] _) -> [lineSegs] - (Slist (oneENode:moreENodes) _) -> concat $ removeENodeFromSegList oneENode <$> removeENodesFromSegList (slist moreENodes) lineSegs + (Slist (oneENode:moreENodes) _) -> concatMap (removeENodeFromSegList oneENode) $ removeENodesFromSegList (slist moreENodes) lineSegs where filterTooShorts sets = mapMaybe isTooShort sets isTooShort set = case set of @@ -802,7 +802,7 @@ skeletonOfNodes connectedLoop inSegSets iNodes = intersectingMixedNodePairs = mapMaybe (\(node1, node2) -> if intersectsInPoint node1 node2 then Just (node1, node2) else Nothing) $ getMixedPairs eNodes iNodes where getMixedPairs :: [a] -> [b] -> [(a, b)] - getMixedPairs set1 set2 = concat $ (\a -> (a,) <$> set2) <$> set1 + getMixedPairs set1 set2 = concatMap (\a -> (a,) <$> set2) set1 -- | find nodes of the same type that can intersect. intersectingNodePairsOf :: (Arcable a, Pointable a) => [a] -> [(a, a)] From 6c2e71880504cff8f8fbc270ee73be172229e82b Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Thu, 15 Dec 2022 23:33:38 +0000 Subject: [PATCH 150/206] create intersectionsAtSamePoint, and use it in the Pointable instance of INode. --- Graphics/Slicer/Math/Intersections.hs | 64 ++++++++++++++++++-- Graphics/Slicer/Math/PGA.hs | 18 ++++-- Graphics/Slicer/Math/Skeleton/Concave.hs | 11 ++-- Graphics/Slicer/Math/Skeleton/Definitions.hs | 44 ++++++-------- tests/golden/C0-Faces-Default.ganja.js | 4 +- tests/golden/C0-Faces-Ordered.ganja.js | 4 +- tests/golden/C0-Straight_Skeleton.ganja.js | 4 +- tests/golden/C1-Straight_Skeleton.ganja.js | 4 +- tests/golden/C2-Straight_Skeleton.ganja.js | 4 +- tests/golden/C3-Straight_Skeleton.ganja.js | 4 +- tests/golden/C4-Straight_Skeleton.ganja.js | 4 +- tests/golden/C5-Straight_Skeleton.ganja.js | 8 +-- tests/golden/C6-Straight_Skeleton.ganja.js | 4 +- 13 files changed, 118 insertions(+), 59 deletions(-) diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index 9ddf00077..b7df09998 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -24,6 +24,7 @@ module Graphics.Slicer.Math.Intersections ( intersectionBetween, intersectionBetweenArcsOf, intersectionOf, + intersectionsAtSamePoint, isAntiCollinear, isAntiParallel, isCollinear, @@ -32,13 +33,17 @@ module Graphics.Slicer.Math.Intersections ( outputIntersectsPLineAt ) where -import Prelude (Bool, Either(Left, Right), (<>), ($), (<), (||), (==), (&&), error, show, otherwise, realToFrac) +import Prelude (Bool(True), Either(Left, Right), (<>), ($), (<), (||), (==), (&&), (<$>), (<=), and, error, show, otherwise, realToFrac) -import Data.Maybe (Maybe(Just, Nothing)) +import Data.Either (rights, lefts) + +import Data.Maybe (Maybe(Just, Nothing), catMaybes, isJust) + +import Graphics.Slicer.Math.Definitions (mapWithFollower) import Graphics.Slicer.Math.GeometricAlgebra (ulpVal) -import Graphics.Slicer.Math.PGA (Arcable(hasArc), CPPoint2, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), PLine2Err, PPoint2Err, ProjectiveLine2, distance2PL, outAndErrOf, plinesIntersectIn) +import Graphics.Slicer.Math.PGA (Arcable(hasArc), CPPoint2, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), PLine2Err, PPoint2Err, ProjectiveLine2, distance2PL, distance2PP, distancePPointToPLineWithErr, fuzzinessOfL, fuzzinessOfP, outAndErrOf, pLineErrAtPPoint, plinesIntersectIn) -- | Check if two lines cannot intersect. noIntersection :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Bool @@ -85,7 +90,7 @@ intersectionBetween line1@(l1, _) line2@(l2, _) = saneIntersection $ plinesInter else Nothing saneIntersection (IntersectsIn p (_,_, pErr)) = Just $ Right (p, pErr) --- | Find out where the output of two Arcables intersect. returns Nothing if no intersection, errors if no output Arc exists on either input. +-- | Find out where the output of two Arcables intersect. returns Nothing if no intersection, and errors if no output Arc exists on either input. intersectionBetweenArcsOf :: (Arcable a, Arcable b) => a -> b -> Maybe (CPPoint2, PPoint2Err) intersectionBetweenArcsOf node1 node2 | hasArc node1 && hasArc node2 = case res of @@ -104,3 +109,54 @@ outputIntersectsPLineAt n line | otherwise = error $ "Tried to check if the output of node intersects PLine on a node with no output:\n" <> show n <> "\n" <> show line <> "\n" where res = plinesIntersectIn (outAndErrOf n) line + +-- | Find out if all of the possible intersections between all of the given nodes are close enough to be considered intersecting at the same point. +intersectionsAtSamePoint :: (ProjectiveLine2 a) => [(a, PLine2Err)] -> Bool +intersectionsAtSamePoint nodeOutsAndErrs + = case nodeOutsAndErrs of + [] -> error "given an empty list." + [a] -> error $ "asked to check for same point intersection of:\n" <> show a <> "\n" + [a,b] -> isJust $ intersectionBetween a b + _ -> and (isJust <$> intersections) && pointsCloseEnough && linesCloseEnough + where + intersections = mapWithFollower myIntersectionBetween nodeOutsAndErrs + where + myIntersectionBetween a b = case intersectionBetween a b of + Nothing -> Nothing + (Just (Right p)) -> Just $ Right (a,b,p) + (Just (Left l)) -> Just $ Left (a,b,l) + -- intersections that resulted in a point. +-- pointIntersections :: (ProjectiveLine2 b) => [((b, PLine2Err), (b, PLine2Err), (CPPoint2, PPoint2Err))] + pointIntersections = rights $ catMaybes intersections + -- intersections that resulted in a line, but are not anticollinear. + lineIntersections = lefts $ catMaybes intersections + pointsCloseEnough = and $ mapWithFollower pairCloseEnough pointIntersections + where + -- Minor optimization: first check against resErr, then actually use the fuzziness. + pairCloseEnough (a1, b1, point1@(c1,_)) (a2, b2, point2@(c2,_)) = res <= realToFrac (ulpVal resErr) || res < realToFrac errSum + where + errSum = ulpVal $ resErr <> fuzzinessOfP point1 + <> pLineErrAtPPoint a1 c1 + <> pLineErrAtPPoint b1 c1 + <> fuzzinessOfP point2 + <> pLineErrAtPPoint a2 c2 + <> pLineErrAtPPoint b2 c2 + (res, (_,_,resErr)) = distance2PP point1 point2 + linesCloseEnough = + case lineIntersections of + [] -> True + [(a1,b1,l1)] -> case pointIntersections of + [] -> error "one line, no points.. makes no sense." + ((a2,b2,ppoint1@(p1,_)):_) -> pointsCloseEnough && foundDistance < realToFrac errSum + where + (foundDistance, (_, _, _, _, _, resErr)) = distancePPointToPLineWithErr ppoint1 l1 + errSum = ulpVal $ resErr <> fuzzinessOfP ppoint1 + <> pLineErrAtPPoint a2 p1 + <> pLineErrAtPPoint b2 p1 + <> fuzzinessOfL a1 + <> fuzzinessOfL b1 + <> fuzzinessOfL l1 + (_:_) -> error + $ "detected multiple lines?\n" + <> show lineIntersections <> "\n" + <> show pointIntersections <> "\n" diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index d7c0a1a3d..7c5990caa 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -54,9 +54,12 @@ module Graphics.Slicer.Math.PGA( distancePPointToPLineWithErr, distance2PP, distance2PL, + errOfPPoint, eToPL, eToPP, flipL, + fuzzinessOfL, + fuzzinessOfP, interpolate2PP, intersectsWithErr, intersect2PL, @@ -66,9 +69,11 @@ module Graphics.Slicer.Math.PGA( outAndErrOf, outputIntersectsLineSeg, pLineIsLeft, + pPointAndErrOf, pPointOnPerpWithErr, pPointsOnSameSideOfPLine, pToEP, + pLineErrAtPPoint, plinesIntersectIn, translateL, translateRotatePPoint2WithErr, @@ -252,7 +257,7 @@ perpLineAt line point = (PLine2 res, resErr) (cPoint, cPointErr) = canonicalizeP point -- | Translate a point a given distance away from where it is, rotating it a given amount clockwise (in radians) around it's original location, with 0 degrees being aligned to the X axis. --- FIXME: make a single error quotent? +-- FIXME: throw this error into PPoint2Err. translateRotatePPoint2WithErr :: (ProjectivePoint2 a) => a -> ℝ -> ℝ -> (PPoint2, (UlpSum, UlpSum, [ErrVal], PLine2Err, PLine2Err, PPoint2Err, ([ErrVal],[ErrVal]))) translateRotatePPoint2WithErr point d rotation = (res, resErr) where @@ -300,13 +305,16 @@ class (Show a) => Pointable a where canPoint :: a -> Bool -- | Get a euclidian representation of this point. ePointOf :: a -> Point2 + -- | If the point is not a native euclidian point, the error generated while converting from a projective form. otherwise mempty. + errOfPPoint :: a -> PPoint2Err -- | Get a projective representation of this point. pPointOf :: a -> PPoint2 -{- +-- | If the given node can be resolved to a point, return it, along with it's error quotent. pPointAndErrOf :: (Pointable a) => a -> (PPoint2, PPoint2Err) - | canPoint a = ( --} +pPointAndErrOf node + | canPoint node = (pPointOf node, errOfPPoint node) + | otherwise = error "not able to resolve node to a point." -- | Check if/where the arc of a motorcycle, inode, or enode intersect a line segment. outputIntersectsLineSeg :: (Arcable a) => a -> LineSeg -> Either Intersection PIntersection @@ -498,7 +506,7 @@ combineConsecutiveLineSegs lines = case lines of ----- And now draw the rest of the algebra ----- ------------------------------------------------ --- | Create a canonical projective point from the given euclidian point. +-- | Create a canonical euclidian projective point from the given euclidian point. euclidianToProjectivePoint2, eToPP :: Point2 -> CPPoint2 euclidianToProjectivePoint2 (Point2 (x,y)) = res where diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index aa889fadb..88f68d791 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -265,8 +265,9 @@ findENodesInOrder eNodeSet@(ENodeSet (Slist [(_,_)] _)) generations = findENodes (Just (newAncestors, newLastGen)) -> findENodesRecursive $ newAncestors <> lastGenWithOnlyMyINode where -- strip the new last generation until it only contains the INode matching myPLine. + -- FIXME: why can't we use isCollinear here? doing so makes tests fail intermittently.. lastGenWithOnlyMyINode :: [[INode]] - lastGenWithOnlyMyINode = case filter (\a -> hasArc a && isCollinear (outAndErrOf a) myPLine) newLastGen of + lastGenWithOnlyMyINode = case filter (\a -> hasArc a && outAndErrOf a == myPLine) newLastGen of [] -> [] a -> [[first a]] where @@ -440,10 +441,10 @@ sortINodesByENodes loop inSegSets inGens@(INodeSet rawGenerations) -- check to see if an INode can be merged with another INode. canMergeWith :: INode -> INode -> Bool - canMergeWith inode1@(INode _ _ _ maybeOut) inode2 = isJust maybeOut && hasIn inode2 (outOf inode1) + canMergeWith inode1@(INode _ _ _ maybeOut) inode2 = isJust maybeOut && hasIn inode2 (outAndErrOf inode1) where - hasIn :: INode -> PLine2 -> Bool - hasIn iNode pLine2 = case filter (\a -> fst a == pLine2) $ insOf iNode of + hasIn :: INode -> (PLine2, PLine2Err) -> Bool + hasIn iNode pLine2 = case filter (\a -> isCollinear a pLine2) $ insOf iNode of [] -> False [_] -> True (_:_) -> error "filter passed too many options." @@ -489,7 +490,7 @@ sortINodesByENodes loop inSegSets inGens@(INodeSet rawGenerations) -- how many input PLines does an INode have. inCountOf (INode in1 in2 moreIns _) - -- handle two identical inputs. + -- HACK: handle two identical inputs. | in1 == in2 = 1+len moreIns | otherwise = 2+len moreIns diff --git a/Graphics/Slicer/Math/Skeleton/Definitions.hs b/Graphics/Slicer/Math/Skeleton/Definitions.hs index 38c6cb002..e743bc629 100644 --- a/Graphics/Slicer/Math/Skeleton/Definitions.hs +++ b/Graphics/Slicer/Math/Skeleton/Definitions.hs @@ -31,7 +31,7 @@ module Graphics.Slicer.Math.Skeleton.Definitions (RemainingContour(RemainingContour), StraightSkeleton(StraightSkeleton), Spine(Spine), ENode(ENode), INode(INode), ENodeSet(ENodeSet), INodeSet(INodeSet), NodeTree(NodeTree), ancestorsOf, Motorcycle(Motorcycle), Cell(Cell), CellDivide(CellDivide), DividingMotorcycles(DividingMotorcycles), MotorcycleIntersection(WithENode, WithMotorcycle, WithLineSeg), concavePLines, getFirstLineSeg, getLastLineSeg, hasNoINodes, getPairs, linePairs, finalPLine, finalINodeOf, finalOutOf, makeINode, sortedPLines, sortedPLinesWithErr, indexPLinesTo, insOf, lastINodeOf, firstInOf, isLoop, lastInOf) where -import Prelude (Eq, Show, Bool(True, False), Ordering(LT,GT), otherwise, ($), (<$>), (==), (/=), error, (>), (&&), any, fst, and, (||), (<>), show, (<), (*), mempty, realToFrac) +import Prelude (Eq, Show, Bool(True, False), Ordering(LT,GT), otherwise, ($), (<$>), (==), (/=), error, (>), (&&), any, fst, and, (||), (<>), show, (<), (*), mempty, not, realToFrac) import Prelude as PL (head, last) @@ -45,7 +45,7 @@ import Data.List.Unique (count_) import Data.Maybe (Maybe(Just,Nothing), isJust, mapMaybe) -import Slist (len, cons, slist, isEmpty, safeLast) +import Slist (len, slist, isEmpty, safeLast) import Slist as SL (last, head, init) @@ -55,7 +55,9 @@ import Graphics.Slicer.Math.Definitions (Contour, LineSeg(LineSeg), Point2, mapW import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum), addVecPair) -import Graphics.Slicer.Math.PGA (plinesIntersectIn, PIntersection(IntersectsIn), flipL, PLine2(PLine2), PLine2Err, pLineIsLeft, distance2PP, Pointable(canPoint, pPointOf, ePointOf), Arcable(errOfOut, hasArc, outOf), CPPoint2(CPPoint2), PPoint2(PPoint2), eToPL, eToPP, outAndErrOf, pToEP, vecOfL) +import Graphics.Slicer.Math.Intersections (noIntersection, intersectionsAtSamePoint) + +import Graphics.Slicer.Math.PGA (plinesIntersectIn, PIntersection(IntersectsIn), flipL, PLine2(PLine2), PLine2Err, pLineIsLeft, distance2PP, Pointable(canPoint, pPointOf, ePointOf, errOfPPoint), Arcable(errOfOut, hasArc, outOf), CPPoint2(CPPoint2), PPoint2(PPoint2), eToPL, eToPP, outAndErrOf, pToEP, vecOfL, vecOfP) -- | A point where two lines segments that are part of a contour intersect, emmiting an arc toward the interior of a contour. -- FIXME: a source should have a different UlpSum for it's point and it's output. @@ -73,8 +75,10 @@ instance Arcable ENode where instance Pointable ENode where -- an ENode always contains a point. canPoint _ = True - pPointOf a = (\(CPPoint2 v) -> PPoint2 v) $ eToPP $ ePointOf a + -- FIXME: this is going to cause double canonicalization. + pPointOf a = PPoint2 $ vecOfP $ eToPP $ ePointOf a ePointOf (ENode (_,centerPoint,_) _ _) = centerPoint + errOfPPoint _ = mempty -- | A point in our straight skeleton where two arcs intersect, resulting in the creation of another arc. -- FIXME: a source should have a different UlpSum for it's point and it's output. @@ -94,17 +98,11 @@ instance Arcable INode where instance Pointable INode where -- an INode does not contain a point, we have to attempt to resolve one instead. - canPoint iNode@(INode firstPLine secondPLine morePLines _) = len allPLines > 1 && hasIntersectingPairs allPLines + canPoint iNode = len (allPLinesOfINode iNode) > 1 && hasIntersectingPairs (allPLinesOfINode iNode) where - allPLines = if hasArc iNode - then cons (outAndErrOf iNode) $ cons firstPLine $ cons secondPLine morePLines - else cons firstPLine $ cons secondPLine morePLines - hasIntersectingPairs (Slist pLines _) = any (\(pl1, pl2) -> saneIntersect $ plinesIntersectIn pl1 pl2) $ getPairs pLines - where - saneIntersect (IntersectsIn _ _) = True - saneIntersect _ = False + hasIntersectingPairs (Slist pLines _) = any (\(pl1, pl2) -> not $ noIntersection pl1 pl2) $ getPairs pLines -- FIXME: if we have multiple intersecting pairs, is there a preferred pair to use for resolving? angle based, etc? - pPointOf iNode@(INode firstPLine secondPLine (Slist rawPLines _) _) + pPointOf iNode | allPointsSame = case results of [] -> error $ "cannot get a PPoint of this iNode: " <> show iNode <> "/n" [a] -> a @@ -114,24 +112,20 @@ instance Pointable INode where Nothing -> error $ "cannot get a PPoint of this iNode: " <> show iNode <> "/n" (Just a) -> fst a where - results = intersectionsOfPairs allPLines - allPointsSame = case intersectionsOfPairs allPLines of - [] -> error $ "no intersection of pairs for " <> show allPLines <> "\nINode: " <> show iNode <> "\n" - [_] -> True - points -> and $ mapWithFollower distanceWithinErr points - where - distanceWithinErr a b = res < realToFrac err - where - (res, (_,_,UlpSum err)) = distance2PP (a,mempty) (b,mempty) - allPLines = if hasArc iNode - then slist $ nub $ (outAndErrOf iNode) : firstPLine : secondPLine : rawPLines - else slist $ nub $ firstPLine : secondPLine : rawPLines + results = intersectionsOfPairs $ allPLinesOfINode iNode + allPointsSame = intersectionsAtSamePoint ((\(Slist l _) -> l) $ allPLinesOfINode iNode) intersectionsOfPairs (Slist pLines _) = mapMaybe (\(pl1, pl2) -> saneIntersect $ plinesIntersectIn pl1 pl2) $ getPairs pLines where saneIntersect (IntersectsIn a _) = Just $ (\(CPPoint2 v) -> PPoint2 v) a saneIntersect _ = Nothing ePointOf a = fst $ pToEP $ pPointOf a +-- | get all of the PLines that come from, or exit an iNode. +allPLinesOfINode :: INode -> Slist (PLine2, PLine2Err) +allPLinesOfINode iNode@(INode firstPLine secondPLine (Slist morePLines _) _) + | hasArc iNode = slist $ nub $ (outAndErrOf iNode) : firstPLine : secondPLine : morePLines + | otherwise = slist $ nub $ firstPLine : secondPLine : morePLines + -- Produce a list of the inputs to a given INode. insOf :: INode -> [(PLine2, PLine2Err)] insOf (INode firstIn secondIn (Slist moreIns _) _) = firstIn:secondIn:moreIns diff --git a/tests/golden/C0-Faces-Default.ganja.js b/tests/golden/C0-Faces-Default.ganja.js index 78d7da555..8bf69423d 100644 --- a/tests/golden/C0-Faces-Default.ganja.js +++ b/tests/golden/C0-Faces-Default.ganja.js @@ -15,13 +15,13 @@ Algebra(2,0,1,()=>{ var ag = -0.4142135623730951e1-0.17157287525381e2+0.24264068711928521e0; var ah = -0.7071067811865475e1-1.7071067811865475e2+1.0e0; var ai = 0.7071067811865475e1-1.7071067811865475e2-1.0e0; - var aj = 0.4142135623730951e1-0.17157287525381e2-0.24264068711928521e0; + var aj = 0.41421356237309515e1-0.17157287525380988e2-0.24264068711928524e0; var ak = 0.0e1-1.414213562373095e2+0.0e0; var al = 1.0e1+1.0e2+0.0e0; var am = 0.7071067811865475e1-1.7071067811865475e2-1.0e0; var an = -1.0e1+1.0e2+0.0e0; var ao = -0.4142135623730951e1-0.17157287525381e2+0.24264068711928521e0; - var ap = 0.4142135623730951e1-0.17157287525381e2-0.24264068711928521e0; + var ap = 0.41421356237309515e1-0.17157287525380988e2-0.24264068711928524e0; var aq = 1.0e1+1.0e2+0.0e0; var ar = -0.7071067811865475e1-1.7071067811865475e2+1.0e0; var as = -1.0e1+1.0e2+0.0e0; diff --git a/tests/golden/C0-Faces-Ordered.ganja.js b/tests/golden/C0-Faces-Ordered.ganja.js index d959af5fc..7f3dd26fc 100644 --- a/tests/golden/C0-Faces-Ordered.ganja.js +++ b/tests/golden/C0-Faces-Ordered.ganja.js @@ -12,13 +12,13 @@ Algebra(2,0,1,()=>{ var aea = point(-1.0,1.0); var aeb = point(0.0,0.0); var af = 0.7071067811865475e1-1.7071067811865475e2-1.0e0; - var ag = 0.4142135623730951e1-0.17157287525381e2-0.24264068711928521e0; + var ag = 0.41421356237309515e1-0.17157287525380988e2-0.24264068711928524e0; var ah = 0.0e1-1.414213562373095e2+0.0e0; var ai = 1.0e1+1.0e2+0.0e0; var aj = 0.7071067811865475e1-1.7071067811865475e2-1.0e0; var ak = -1.0e1+1.0e2+0.0e0; var al = -0.4142135623730951e1-0.17157287525381e2+0.24264068711928521e0; - var am = 0.4142135623730951e1-0.17157287525381e2-0.24264068711928521e0; + var am = 0.41421356237309515e1-0.17157287525380988e2-0.24264068711928524e0; var an = 1.0e1+1.0e2+0.0e0; var ao = -0.7071067811865475e1-1.7071067811865475e2+1.0e0; var ap = -1.0e1+1.0e2+0.0e0; diff --git a/tests/golden/C0-Straight_Skeleton.ganja.js b/tests/golden/C0-Straight_Skeleton.ganja.js index 94359a426..7731998a8 100644 --- a/tests/golden/C0-Straight_Skeleton.ganja.js +++ b/tests/golden/C0-Straight_Skeleton.ganja.js @@ -13,12 +13,12 @@ Algebra(2,0,1,()=>{ var aeb = point(0.0,0.0); var afa = 0.7071067811865475e1-1.7071067811865475e2-1.0e0; var afb = 1.0e1+1.0e2+0.0e0; - var afc = 0.4142135623730951e1-0.17157287525381e2-0.24264068711928521e0; + var afc = 0.41421356237309515e1-0.17157287525380988e2-0.24264068711928524e0; var aga = -1.0e1+1.0e2+0.0e0; var agb = -0.7071067811865475e1-1.7071067811865475e2+1.0e0; var agc = -0.4142135623730951e1-0.17157287525381e2+0.24264068711928521e0; var aha = 0.0e1-1.414213562373095e2+0.0e0; - var ahb = 0.4142135623730951e1-0.17157287525381e2-0.24264068711928521e0; + var ahb = 0.41421356237309515e1-0.17157287525380988e2-0.24264068711928524e0; var ahc = -0.4142135623730951e1-0.17157287525381e2+0.24264068711928521e0; document.body.appendChild(this.graph([ 0x882288, diff --git a/tests/golden/C1-Straight_Skeleton.ganja.js b/tests/golden/C1-Straight_Skeleton.ganja.js index 8ec213789..6a5708e41 100644 --- a/tests/golden/C1-Straight_Skeleton.ganja.js +++ b/tests/golden/C1-Straight_Skeleton.ganja.js @@ -16,10 +16,10 @@ Algebra(2,0,1,()=>{ var afc = 0.17157287525381e1-0.4142135623730951e2+0.24264068711928521e0; var aga = 1.7071067811865475e1+0.7071067811865475e2-1.0e0; var agb = -1.0e1+1.0e2+0.0e0; - var agc = 0.17157287525381e1+0.4142135623730951e2-0.24264068711928521e0; + var agc = 0.17157287525380988e1+0.41421356237309515e2-0.24264068711928524e0; var aha = 0.17157287525381e1-0.4142135623730951e2+0.24264068711928521e0; var ahb = 1.414213562373095e1+0.0e2+0.0e0; - var ahc = 0.17157287525381e1+0.4142135623730951e2-0.24264068711928521e0; + var ahc = 0.17157287525380988e1+0.41421356237309515e2-0.24264068711928524e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C2-Straight_Skeleton.ganja.js b/tests/golden/C2-Straight_Skeleton.ganja.js index bf5ddca18..eca194b7c 100644 --- a/tests/golden/C2-Straight_Skeleton.ganja.js +++ b/tests/golden/C2-Straight_Skeleton.ganja.js @@ -16,10 +16,10 @@ Algebra(2,0,1,()=>{ var afc = 0.4142135623730951e1+0.17157287525381e2+0.24264068711928521e0; var aga = -0.7071067811865475e1+1.7071067811865475e2-1.0e0; var agb = -1.0e1-1.0e2+0.0e0; - var agc = -0.4142135623730951e1+0.17157287525381e2-0.24264068711928521e0; + var agc = -0.41421356237309515e1+0.17157287525380988e2-0.24264068711928524e0; var aha = 0.4142135623730951e1+0.17157287525381e2+0.24264068711928521e0; var ahb = 0.0e1+1.414213562373095e2+0.0e0; - var ahc = -0.4142135623730951e1+0.17157287525381e2-0.24264068711928521e0; + var ahc = -0.41421356237309515e1+0.17157287525380988e2-0.24264068711928524e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C3-Straight_Skeleton.ganja.js b/tests/golden/C3-Straight_Skeleton.ganja.js index 6df95f204..dc56fab82 100644 --- a/tests/golden/C3-Straight_Skeleton.ganja.js +++ b/tests/golden/C3-Straight_Skeleton.ganja.js @@ -13,12 +13,12 @@ Algebra(2,0,1,()=>{ var aeb = point(0.0,0.0); var afa = -1.7071067811865475e1-0.7071067811865475e2-1.0e0; var afb = 1.0e1-1.0e2+0.0e0; - var afc = -0.17157287525381e1-0.4142135623730951e2-0.24264068711928521e0; + var afc = -0.17157287525380988e1-0.41421356237309515e2-0.24264068711928524e0; var aga = 1.0e1+1.0e2+0.0e0; var agb = -1.7071067811865475e1+0.7071067811865475e2+1.0e0; var agc = -0.17157287525381e1+0.4142135623730951e2+0.24264068711928521e0; var aha = -1.414213562373095e1+0.0e2+0.0e0; - var ahb = -0.17157287525381e1-0.4142135623730951e2-0.24264068711928521e0; + var ahb = -0.17157287525380988e1-0.41421356237309515e2-0.24264068711928524e0; var ahc = -0.17157287525381e1+0.4142135623730951e2+0.24264068711928521e0; document.body.appendChild(this.graph([ 0x882288, diff --git a/tests/golden/C4-Straight_Skeleton.ganja.js b/tests/golden/C4-Straight_Skeleton.ganja.js index 94359a426..7731998a8 100644 --- a/tests/golden/C4-Straight_Skeleton.ganja.js +++ b/tests/golden/C4-Straight_Skeleton.ganja.js @@ -13,12 +13,12 @@ Algebra(2,0,1,()=>{ var aeb = point(0.0,0.0); var afa = 0.7071067811865475e1-1.7071067811865475e2-1.0e0; var afb = 1.0e1+1.0e2+0.0e0; - var afc = 0.4142135623730951e1-0.17157287525381e2-0.24264068711928521e0; + var afc = 0.41421356237309515e1-0.17157287525380988e2-0.24264068711928524e0; var aga = -1.0e1+1.0e2+0.0e0; var agb = -0.7071067811865475e1-1.7071067811865475e2+1.0e0; var agc = -0.4142135623730951e1-0.17157287525381e2+0.24264068711928521e0; var aha = 0.0e1-1.414213562373095e2+0.0e0; - var ahb = 0.4142135623730951e1-0.17157287525381e2-0.24264068711928521e0; + var ahb = 0.41421356237309515e1-0.17157287525380988e2-0.24264068711928524e0; var ahc = -0.4142135623730951e1-0.17157287525381e2+0.24264068711928521e0; document.body.appendChild(this.graph([ 0x882288, diff --git a/tests/golden/C5-Straight_Skeleton.ganja.js b/tests/golden/C5-Straight_Skeleton.ganja.js index a5b227228..25b67983d 100644 --- a/tests/golden/C5-Straight_Skeleton.ganja.js +++ b/tests/golden/C5-Straight_Skeleton.ganja.js @@ -15,14 +15,14 @@ Algebra(2,0,1,()=>{ var afb = point(0.0,0.0); var aga = 0.7071067811865475e1-1.7071067811865475e2-1.0e0; var agb = 0.7071067811865475e1+0.29289321881345254e2-0.4142135623730949e0; - var agc = 0.2928932188134524e1-0.29289321881345254e2-0.2928932188134524e0; + var agc = 0.2928932188134526e1-0.29289321881345265e2-0.2928932188134526e0; var aha = -0.7071067811865475e1+0.29289321881345254e2+0.4142135623730949e0; var ahb = -0.7071067811865475e1-1.7071067811865475e2+1.0e0; - var ahc = -0.2928932188134526e1-0.29289321881345265e2+0.2928932188134526e0; + var ahc = -0.2928932188134524e1-0.29289321881345254e2+0.2928932188134524e0; var aia = 0.0e1-1.414213562373095e2+0.0e0; - var aib = 0.2928932188134524e1-0.29289321881345254e2-0.2928932188134524e0; + var aib = 0.2928932188134526e1-0.29289321881345265e2-0.2928932188134526e0; var aic = 0.0e1+1.0e2+0.0e0; - var aid = -0.2928932188134526e1-0.29289321881345265e2+0.2928932188134526e0; + var aid = -0.2928932188134524e1-0.29289321881345254e2+0.2928932188134524e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], diff --git a/tests/golden/C6-Straight_Skeleton.ganja.js b/tests/golden/C6-Straight_Skeleton.ganja.js index 9d514afca..82ee19dbb 100644 --- a/tests/golden/C6-Straight_Skeleton.ganja.js +++ b/tests/golden/C6-Straight_Skeleton.ganja.js @@ -26,10 +26,10 @@ Algebra(2,0,1,()=>{ var ajc = 0.14412639668556793e1-0.5468566089394846e2+0.3778686232909291e0; var aka = 1.5577575895385873e1+0.18137566906741376e2-0.9510565162951536e0; var akb = -1.0e1+1.0e2+0.0e0; - var akc = 0.14412639668556793e1+0.5468566089394846e2-0.3778686232909291e0; + var akc = 0.14412639668556793e1+0.5468566089394847e2-0.37786862329092913e0; var ala = 0.14412639668556793e1-0.5468566089394846e2+0.3778686232909291e0; var alb = 1.7888543819998317e1+0.0e2+0.0e0; - var alc = 0.14412639668556793e1+0.5468566089394846e2-0.3778686232909291e0; + var alc = 0.14412639668556793e1+0.5468566089394847e2-0.37786862329092913e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], From 44f4daa42bf00f58f2209ec9108f7d8490102f01 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Fri, 16 Dec 2022 21:03:03 +0000 Subject: [PATCH 151/206] formatting changes. --- Graphics/Slicer/Math/Intersections.hs | 94 ++++++++++---------- Graphics/Slicer/Math/Skeleton/Definitions.hs | 51 +++++++---- 2 files changed, 83 insertions(+), 62 deletions(-) diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index b7df09998..aff6119a1 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -114,49 +114,51 @@ outputIntersectsPLineAt n line intersectionsAtSamePoint :: (ProjectiveLine2 a) => [(a, PLine2Err)] -> Bool intersectionsAtSamePoint nodeOutsAndErrs = case nodeOutsAndErrs of - [] -> error "given an empty list." - [a] -> error $ "asked to check for same point intersection of:\n" <> show a <> "\n" - [a,b] -> isJust $ intersectionBetween a b - _ -> and (isJust <$> intersections) && pointsCloseEnough && linesCloseEnough - where - intersections = mapWithFollower myIntersectionBetween nodeOutsAndErrs - where - myIntersectionBetween a b = case intersectionBetween a b of - Nothing -> Nothing - (Just (Right p)) -> Just $ Right (a,b,p) - (Just (Left l)) -> Just $ Left (a,b,l) - -- intersections that resulted in a point. --- pointIntersections :: (ProjectiveLine2 b) => [((b, PLine2Err), (b, PLine2Err), (CPPoint2, PPoint2Err))] - pointIntersections = rights $ catMaybes intersections - -- intersections that resulted in a line, but are not anticollinear. - lineIntersections = lefts $ catMaybes intersections - pointsCloseEnough = and $ mapWithFollower pairCloseEnough pointIntersections - where - -- Minor optimization: first check against resErr, then actually use the fuzziness. - pairCloseEnough (a1, b1, point1@(c1,_)) (a2, b2, point2@(c2,_)) = res <= realToFrac (ulpVal resErr) || res < realToFrac errSum - where - errSum = ulpVal $ resErr <> fuzzinessOfP point1 - <> pLineErrAtPPoint a1 c1 - <> pLineErrAtPPoint b1 c1 - <> fuzzinessOfP point2 - <> pLineErrAtPPoint a2 c2 - <> pLineErrAtPPoint b2 c2 - (res, (_,_,resErr)) = distance2PP point1 point2 - linesCloseEnough = - case lineIntersections of - [] -> True - [(a1,b1,l1)] -> case pointIntersections of - [] -> error "one line, no points.. makes no sense." - ((a2,b2,ppoint1@(p1,_)):_) -> pointsCloseEnough && foundDistance < realToFrac errSum - where - (foundDistance, (_, _, _, _, _, resErr)) = distancePPointToPLineWithErr ppoint1 l1 - errSum = ulpVal $ resErr <> fuzzinessOfP ppoint1 - <> pLineErrAtPPoint a2 p1 - <> pLineErrAtPPoint b2 p1 - <> fuzzinessOfL a1 - <> fuzzinessOfL b1 - <> fuzzinessOfL l1 - (_:_) -> error - $ "detected multiple lines?\n" - <> show lineIntersections <> "\n" - <> show pointIntersections <> "\n" + [] -> error "given an empty list." + [a] -> error $ "asked to check for same point intersection of:\n" <> show a <> "\n" + [a,b] -> isJust $ intersectionBetween a b + _ -> and (isJust <$> intersections) && pointsCloseEnough && linesCloseEnough + where + intersections = mapWithFollower myIntersectionBetween nodeOutsAndErrs + where + myIntersectionBetween a b = case intersectionBetween a b of + Nothing -> Nothing + (Just (Right p)) -> Just $ Right (a,b,p) + (Just (Left l)) -> Just $ Left (a,b,l) + pointsCloseEnough = and $ mapWithFollower pairCloseEnough pointIntersections + where + -- intersections that resulted in a point. + pointIntersections = rights $ catMaybes intersections + -- Minor optimization: first check against resErr, then actually use the fuzziness. + pairCloseEnough (a1, b1, point1@(c1,_)) (a2, b2, point2@(c2,_)) = res <= realToFrac (ulpVal resErr) || res < realToFrac errSum + where + errSum = ulpVal $ resErr <> fuzzinessOfP point1 + <> pLineErrAtPPoint a1 c1 + <> pLineErrAtPPoint b1 c1 + <> fuzzinessOfP point2 + <> pLineErrAtPPoint a2 c2 + <> pLineErrAtPPoint b2 c2 + (res, (_,_,resErr)) = distance2PP point1 point2 + linesCloseEnough = + case lineIntersections of + [] -> True + [(a1,b1,l1)] -> case pointIntersections of + [] -> error "one line, no points.. makes no sense." + ((a2,b2,ppoint1@(p1,_)):_) -> pointsCloseEnough && foundDistance < realToFrac errSum + where + (foundDistance, (_, _, _, _, _, resErr)) = distancePPointToPLineWithErr ppoint1 l1 + errSum = ulpVal $ resErr <> fuzzinessOfP ppoint1 + <> pLineErrAtPPoint a2 p1 + <> pLineErrAtPPoint b2 p1 + <> fuzzinessOfL a1 + <> fuzzinessOfL b1 + <> fuzzinessOfL l1 + (_:_) -> error + $ "detected multiple lines?\n" + <> show lineIntersections <> "\n" + <> show pointIntersections <> "\n" + where + -- intersections that resulted in a point. + pointIntersections = rights $ catMaybes intersections + -- intersections that resulted in a line, but are not anticollinear. + lineIntersections = lefts $ catMaybes intersections diff --git a/Graphics/Slicer/Math/Skeleton/Definitions.hs b/Graphics/Slicer/Math/Skeleton/Definitions.hs index e743bc629..7101763b6 100644 --- a/Graphics/Slicer/Math/Skeleton/Definitions.hs +++ b/Graphics/Slicer/Math/Skeleton/Definitions.hs @@ -31,7 +31,7 @@ module Graphics.Slicer.Math.Skeleton.Definitions (RemainingContour(RemainingContour), StraightSkeleton(StraightSkeleton), Spine(Spine), ENode(ENode), INode(INode), ENodeSet(ENodeSet), INodeSet(INodeSet), NodeTree(NodeTree), ancestorsOf, Motorcycle(Motorcycle), Cell(Cell), CellDivide(CellDivide), DividingMotorcycles(DividingMotorcycles), MotorcycleIntersection(WithENode, WithMotorcycle, WithLineSeg), concavePLines, getFirstLineSeg, getLastLineSeg, hasNoINodes, getPairs, linePairs, finalPLine, finalINodeOf, finalOutOf, makeINode, sortedPLines, sortedPLinesWithErr, indexPLinesTo, insOf, lastINodeOf, firstInOf, isLoop, lastInOf) where -import Prelude (Eq, Show, Bool(True, False), Ordering(LT,GT), otherwise, ($), (<$>), (==), (/=), error, (>), (&&), any, fst, and, (||), (<>), show, (<), (*), mempty, not, realToFrac) +import Prelude (Eq, Show, Bool(True, False), Ordering(LT,GT), otherwise, ($), (<$>), (==), (/=), error, (>), (&&), any, fst, (||), (<>), show, (<), (*), mempty, not) import Prelude as PL (head, last) @@ -53,44 +53,58 @@ import Slist.Type (Slist(Slist)) import Graphics.Slicer.Math.Definitions (Contour, LineSeg(LineSeg), Point2, mapWithFollower, fudgeFactor, startPoint, distance, endPoint, lineSegsOfContour, makeLineSeg) -import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum), addVecPair) +import Graphics.Slicer.Math.GeometricAlgebra (addVecPair) import Graphics.Slicer.Math.Intersections (noIntersection, intersectionsAtSamePoint) -import Graphics.Slicer.Math.PGA (plinesIntersectIn, PIntersection(IntersectsIn), flipL, PLine2(PLine2), PLine2Err, pLineIsLeft, distance2PP, Pointable(canPoint, pPointOf, ePointOf, errOfPPoint), Arcable(errOfOut, hasArc, outOf), CPPoint2(CPPoint2), PPoint2(PPoint2), eToPL, eToPP, outAndErrOf, pToEP, vecOfL, vecOfP) +import Graphics.Slicer.Math.PGA (plinesIntersectIn, PIntersection(IntersectsIn), flipL, PLine2(PLine2), PLine2Err, pLineIsLeft, Pointable(canPoint, pPointOf, ePointOf, errOfPPoint), Arcable(errOfOut, hasArc, outOf), CPPoint2(CPPoint2), PPoint2(PPoint2), eToPL, eToPP, outAndErrOf, pToEP, vecOfL, vecOfP) -- | A point where two lines segments that are part of a contour intersect, emmiting an arc toward the interior of a contour. -- FIXME: a source should have a different UlpSum for it's point and it's output. -- FIXME: provide our own Eq instance, cause floats suck? :) -data ENode = ENode { _inPoints :: !(Point2, Point2, Point2), _arcOut :: !PLine2, _arcOutErr :: !PLine2Err} +data ENode = ENode + -- Input points. three points in order, with the inside of the contour to the left. + !(Point2, Point2, Point2) + -- The projective line eminating from the middle point. refered to as an Arc. + !PLine2 + -- The imprecision of the Arc. + !PLine2Err deriving Eq deriving stock Show instance Arcable ENode where - -- an ENode always has an arc. + errOfOut (ENode _ _ outErr) = outErr + -- | an ENode always has an arc. hasArc _ = True outOf (ENode _ outArc _) = outArc - errOfOut (ENode _ _ outErr) = outErr instance Pointable ENode where - -- an ENode always contains a point. + -- | an ENode always contains a point. canPoint _ = True - -- FIXME: this is going to cause double canonicalization. - pPointOf a = PPoint2 $ vecOfP $ eToPP $ ePointOf a ePointOf (ENode (_,centerPoint,_) _ _) = centerPoint errOfPPoint _ = mempty + -- FIXME: this is going to cause double canonicalization. + pPointOf a = PPoint2 $ vecOfP $ eToPP $ ePointOf a -- | A point in our straight skeleton where two arcs intersect, resulting in the creation of another arc. -- FIXME: a source should have a different UlpSum for it's point and it's output. -data INode = INode { _firstInArc :: !(PLine2, PLine2Err), _secondInArc :: !(PLine2, PLine2Err), _moreInArcs :: !(Slist (PLine2, PLine2Err)), _outArc :: !(Maybe (PLine2, PLine2Err))} +data INode = INode + -- _firstInArc :: + !(PLine2, PLine2Err) + -- _secondInArc :: + !(PLine2, PLine2Err) + -- _moreInArcs :: + !(Slist (PLine2, PLine2Err)) + -- _outArc :: + !(Maybe (PLine2, PLine2Err)) deriving Eq deriving stock Show instance Arcable INode where -- an INode might just end here. - errOfOut (INode _ _ _ outArc) = case outArc of - (Just (_,rawOutArcErr)) -> rawOutArcErr - Nothing -> error "tried to get an outArc that has no output arc." + errOfOut (INode _ _ _ outArc) = case outArc of + (Just (_,rawOutErr)) -> rawOutErr + Nothing -> error "tried to get an outArc that has no output arc." hasArc (INode _ _ _ outArc) = isJust outArc outOf (INode _ _ _ outArc) = case outArc of (Just (rawOutArc,_)) -> rawOutArc @@ -105,8 +119,7 @@ instance Pointable INode where pPointOf iNode | allPointsSame = case results of [] -> error $ "cannot get a PPoint of this iNode: " <> show iNode <> "/n" - [a] -> a - (a:_) -> a + l -> PL.head l -- Allow the pebbles to vote. | otherwise = case safeLast (slist $ count_ results) of Nothing -> error $ "cannot get a PPoint of this iNode: " <> show iNode <> "/n" @@ -138,7 +151,13 @@ lastINodeOf (INodeSet gens) = case unsnoc (SL.last gens) of -- | A Motorcycle. a PLine eminating from an intersection between two line segments toward the interior or the exterior of a contour. -- Motorcycles are emitted from convex (reflex) virtexes of the encircling contour, and concave virtexes of any holes. -- FIXME: Note that a new motorcycle may be created in the case of degenerate polygons... with it's inSegs being two other motorcycles. -data Motorcycle = Motorcycle { _inCSegs :: !(LineSeg, LineSeg), _outPline :: !PLine2, _outPlineErr :: PLine2Err} +data Motorcycle = Motorcycle + -- The two line segments from which this motorcycle projects + !(LineSeg, LineSeg) + -- The output arc of this motorcycle. really, the motorcycle. + !PLine2 + -- The error quotent of the output arc. + PLine2Err deriving Eq deriving stock Show From 5d40f2594aa20412783a49187adf2e73411d8db1 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 17 Dec 2022 13:18:26 +0000 Subject: [PATCH 152/206] add more performant EQ instances, and move unused Eq instances from the library to the test suite. --- Graphics/Slicer/Math/Skeleton/Definitions.hs | 31 +++++++++++++------- tests/Math/PGA.hs | 16 ++++++++-- 2 files changed, 35 insertions(+), 12 deletions(-) diff --git a/Graphics/Slicer/Math/Skeleton/Definitions.hs b/Graphics/Slicer/Math/Skeleton/Definitions.hs index 7101763b6..064f693ad 100644 --- a/Graphics/Slicer/Math/Skeleton/Definitions.hs +++ b/Graphics/Slicer/Math/Skeleton/Definitions.hs @@ -61,7 +61,6 @@ import Graphics.Slicer.Math.PGA (plinesIntersectIn, PIntersection(IntersectsIn), -- | A point where two lines segments that are part of a contour intersect, emmiting an arc toward the interior of a contour. -- FIXME: a source should have a different UlpSum for it's point and it's output. --- FIXME: provide our own Eq instance, cause floats suck? :) data ENode = ENode -- Input points. three points in order, with the inside of the contour to the left. !(Point2, Point2, Point2) @@ -69,9 +68,13 @@ data ENode = ENode !PLine2 -- The imprecision of the Arc. !PLine2Err - deriving Eq deriving stock Show +-- Since the PLine2 and PLine2Err are derived from the points, only check the points for Eq. +instance Eq ENode where + (==) (ENode points _ _) (ENode morePoints _ _) = points == morePoints + (/=) a b = not $ a == b + instance Arcable ENode where errOfOut (ENode _ _ outErr) = outErr -- | an ENode always has an arc. @@ -97,9 +100,13 @@ data INode = INode !(Slist (PLine2, PLine2Err)) -- _outArc :: !(Maybe (PLine2, PLine2Err)) - deriving Eq deriving stock Show +-- Since the outgoing PLine2 and PLine2Err are derived from the input arcs, only check the input arcs for Eq. +instance Eq INode where + (==) (INode arcA1 arcA2 moreA _) (INode arcB1 arcB2 moreB _) = arcA1 == arcB1 && arcA2 == arcB2 && moreA == moreB + (/=) a b = not $ a == b + instance Arcable INode where -- an INode might just end here. errOfOut (INode _ _ _ outArc) = case outArc of @@ -158,9 +165,14 @@ data Motorcycle = Motorcycle !PLine2 -- The error quotent of the output arc. PLine2Err - deriving Eq deriving stock Show + +-- Since the PLine2 and PLine2Err are derived from the line segments, only check them for Eq. +instance Eq Motorcycle where + (==) (Motorcycle segsA _ _) (Motorcycle segsB _ _) = segsA == segsB + (/=) a b = not $ a == b + instance Arcable Motorcycle where -- A Motorcycle always has an arc, which is it's path. hasArc _ = True @@ -180,7 +192,6 @@ data DividingMotorcycles = DividingMotorcycles { firstMotorcycle :: !Motorcycle, -- A concave region of a contour. newtype Cell = Cell { _sides :: Slist (Slist LineSeg, Maybe CellDivide)} - deriving Eq deriving stock Show -- | the border dividing two cells of a contour. @@ -198,8 +209,6 @@ data MotorcycleIntersection = -- The part of a contour that remains once we trim a concave section from it. newtype RemainingContour = RemainingContour (Slist (Slist LineSeg, [CellDivide])) - deriving Eq - deriving stock Show -- | The exterior nodes of a whole contour or just a cell of a contour. newtype ENodeSet = ENodeSet { _eNodeSides :: Slist (ENode,Slist ENode) } @@ -217,18 +226,20 @@ newtype INodeSet = INodeSet (Slist [INode]) -- | The complete graph of exterior nodes, and their interior intersection. note this may be for a cell, a contour, or the border between two cells. data NodeTree = NodeTree { _eNodes :: !ENodeSet, _iNodes :: !INodeSet } - deriving Eq deriving stock Show +-- | All nodetrees with identical eNodes have identical iNodes. +instance Eq NodeTree where + (==) (NodeTree enodeset1 _) (NodeTree enodeset2 _) = enodeset1 == enodeset2 + (/=) a b = not $ a == b + -- | A Spine component: -- Similar to a node, only without the in and out heirarchy. always connects to inArcs from a NodeTree. One per generation. allows us to build loops. newtype Spine = Spine { _spineArcs :: NonEmpty PLine2 } - deriving newtype Eq deriving stock Show -- | The straight skeleton of a contour. data StraightSkeleton = StraightSkeleton { _nodeSets :: !(Slist [NodeTree]), _spineNodes :: !(Slist Spine) } - deriving Eq deriving stock Show -- | Cut a list into all possible pairs. Used in a few places, but here because the Pointable instance for INode uses it. diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index 79644fe0d..aed0c84a7 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -22,10 +22,13 @@ {-# LANGUAGE DataKinds #-} +-- So we can add Eq instances here, instead of in the library. +{-# LANGUAGE StandaloneDeriving #-} + module Math.PGA (linearAlgSpec, geomAlgSpec, pgaSpec, proj2DGeomAlgSpec, facetSpec, facetFlakeySpec, contourSpec, lineSpec) where -- Be explicit about what we import. -import Prelude (($), Bool(True, False), (<$>), (==), (>=), error, (/=), (<=), mempty, otherwise, abs, (&&), (+), show, length, (<>), fst, not, length, realToFrac, sqrt, (<), (>), (-), (/), (||), (*), snd) +import Prelude (($), Bool(True, False), Eq, Show, (<$>), (==), (>=), error, (/=), (<=), mempty, otherwise, abs, (&&), (+), show, length, (<>), fst, not, length, realToFrac, sqrt, (<), (>), (-), (/), (||), (*), snd) -- Hspec, for writing specs. import Test.Hspec (describe, Spec, it, Expectation) @@ -78,7 +81,7 @@ import Graphics.Slicer.Machine.Infill (InfillType(Horiz, Vert), makeInfill) import Graphics.Slicer.Math.Arcs (getOutsideArc, towardIntersection) import Graphics.Slicer.Math.Skeleton.Cells (findFirstCellOfContour, findDivisions, findNextCell) import Graphics.Slicer.Math.Skeleton.Concave (makeENode, makeENodes, averageNodes) -import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle), RemainingContour(RemainingContour), INode(INode), Cell(Cell), getFirstLineSeg, getLastLineSeg) +import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle), RemainingContour(RemainingContour), Spine(Spine), StraightSkeleton(StraightSkeleton), INode(INode), Cell(Cell), getFirstLineSeg, getLastLineSeg) import Graphics.Slicer.Math.Skeleton.Face (Face(Face), facesOf, orderedFacesOf) import Graphics.Slicer.Math.Skeleton.Line (addInset) import Graphics.Slicer.Math.Skeleton.Motorcycles (convexMotorcycles, crashMotorcycles, CrashTree(CrashTree)) @@ -96,6 +99,15 @@ import Graphics.Slicer.Math.RandomGeometry (ListThree, Radian(Radian), cellFrom, -- Default all numbers in this file to being of the type ImplicitCAD uses for values. default (ℝ) +deriving instance Eq RemainingContour +deriving instance Show RemainingContour + +deriving instance Eq Cell + +deriving instance Eq Spine + +deriving instance Eq StraightSkeleton + contourSpec :: Spec contourSpec = do describe "Contours (math/contour)" $ do From 421e99ce49feadad6a031256524295b36522d9b1 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 17 Dec 2022 14:21:42 +0000 Subject: [PATCH 153/206] minor formatting change. --- Graphics/Slicer/Math/Intersections.hs | 33 ++++++++++++++------------- 1 file changed, 17 insertions(+), 16 deletions(-) diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index aff6119a1..2c996cbca 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -132,12 +132,13 @@ intersectionsAtSamePoint nodeOutsAndErrs -- Minor optimization: first check against resErr, then actually use the fuzziness. pairCloseEnough (a1, b1, point1@(c1,_)) (a2, b2, point2@(c2,_)) = res <= realToFrac (ulpVal resErr) || res < realToFrac errSum where - errSum = ulpVal $ resErr <> fuzzinessOfP point1 - <> pLineErrAtPPoint a1 c1 - <> pLineErrAtPPoint b1 c1 - <> fuzzinessOfP point2 - <> pLineErrAtPPoint a2 c2 - <> pLineErrAtPPoint b2 c2 + errSum = ulpVal $ resErr + <> fuzzinessOfP point1 + <> pLineErrAtPPoint a1 c1 + <> pLineErrAtPPoint b1 c1 + <> fuzzinessOfP point2 + <> pLineErrAtPPoint a2 c2 + <> pLineErrAtPPoint b2 c2 (res, (_,_,resErr)) = distance2PP point1 point2 linesCloseEnough = case lineIntersections of @@ -147,16 +148,16 @@ intersectionsAtSamePoint nodeOutsAndErrs ((a2,b2,ppoint1@(p1,_)):_) -> pointsCloseEnough && foundDistance < realToFrac errSum where (foundDistance, (_, _, _, _, _, resErr)) = distancePPointToPLineWithErr ppoint1 l1 - errSum = ulpVal $ resErr <> fuzzinessOfP ppoint1 - <> pLineErrAtPPoint a2 p1 - <> pLineErrAtPPoint b2 p1 - <> fuzzinessOfL a1 - <> fuzzinessOfL b1 - <> fuzzinessOfL l1 - (_:_) -> error - $ "detected multiple lines?\n" - <> show lineIntersections <> "\n" - <> show pointIntersections <> "\n" + errSum = ulpVal $ resErr + <> fuzzinessOfP ppoint1 + <> pLineErrAtPPoint a2 p1 + <> pLineErrAtPPoint b2 p1 + <> fuzzinessOfL a1 + <> fuzzinessOfL b1 + <> fuzzinessOfL l1 + (_:_) -> error $ "detected multiple lines?\n" + <> show lineIntersections <> "\n" + <> show pointIntersections <> "\n" where -- intersections that resulted in a point. pointIntersections = rights $ catMaybes intersections From 4cb35cf8c96fe94fdc15338c340729d805eabeb0 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 17 Dec 2022 16:49:29 +0000 Subject: [PATCH 154/206] take error quotents into account when getting distances. --- Graphics/Slicer/Math/Lossy.hs | 18 +++++++++++------- Graphics/Slicer/Math/Skeleton/Cells.hs | 12 ++++++------ 2 files changed, 17 insertions(+), 13 deletions(-) diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index 46cc72971..07e9f2cfd 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -21,6 +21,7 @@ module Graphics.Slicer.Math.Lossy ( canonicalizePPoint2, distanceBetweenPPoints, + distanceBetweenPPointsWithErr, distanceBetweenPLines, distancePPointToPLine, eToNPLine2, @@ -34,8 +35,8 @@ module Graphics.Slicer.Math.Lossy ( pPointBetweenPPoints, pPointOnPerp, pToEPoint2, - translateRotatePPoint2, - translatePLine2 + translatePLine2, + translateRotatePPoint2 ) where import Prelude (($), fst, mempty) @@ -47,7 +48,7 @@ import Graphics.Slicer.Math.Definitions (LineSeg, Point2, makeLineSeg) import qualified Graphics.Slicer.Math.Arcs as Arcs (getFirstArc, getInsideArc) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PPoint2, ProjectiveLine2, ProjectivePoint2, canonicalizeP, distance2PP, distance2PL, distancePPointToPLineWithErr, eToPL, interpolate2PP, join2PP, normalizeL, pPointOnPerpWithErr, pToEP, translateL, translateRotatePPoint2WithErr) +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PPoint2, PPoint2Err, ProjectiveLine2, ProjectivePoint2, canonicalizeP, distance2PP, distance2PL, distancePPointToPLineWithErr, eToPL, interpolate2PP, join2PP, normalizeL, pPointOnPerpWithErr, pToEP, translateL, translateRotatePPoint2WithErr) -- | canonicalize a euclidian point. canonicalizePPoint2 :: PPoint2 -> CPPoint2 @@ -56,6 +57,9 @@ canonicalizePPoint2 point = fst $ canonicalizeP point distanceBetweenPPoints :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> ℝ distanceBetweenPPoints point1 point2 = fst $ distance2PP (point1, mempty) (point2, mempty) +distanceBetweenPPointsWithErr :: (ProjectivePoint2 a, ProjectivePoint2 b) => (a, PPoint2Err) -> (b, PPoint2Err) -> ℝ +distanceBetweenPPointsWithErr point1 point2 = fst $ distance2PP point1 point2 + distanceBetweenPLines :: (ProjectiveLine2 a) => a -> a -> ℝ distanceBetweenPLines nPLine1 nPLine2 = fst $ distance2PL nPLine1 nPLine2 @@ -106,10 +110,10 @@ pPointBetweenPPoints startOfSeg stopOfSeg weight1 weight2 = fst $ interpolate2PP pPointOnPerp :: (ProjectiveLine2 a, ProjectivePoint2 b) => a -> b -> ℝ -> PPoint2 pPointOnPerp pline ppoint d = fst $ pPointOnPerpWithErr pline ppoint d --- | Translate a point a given distance away from where it is, rotating it a given amount clockwise (in radians) around it's original location, with 0 degrees being aligned to the X axis. -translateRotatePPoint2 :: (ProjectivePoint2 a) => a -> ℝ -> ℝ -> PPoint2 -translateRotatePPoint2 ppoint d rotation = fst $ translateRotatePPoint2WithErr ppoint d rotation - -- | translate a PLine2 along it's perpendicular bisector. translatePLine2 :: PLine2 -> ℝ -> PLine2 translatePLine2 pline distance = fst $ translateL pline distance + +-- | Translate a point a given distance away from where it is, rotating it a given amount clockwise (in radians) around it's original location, with 0 degrees being aligned to the X axis. +translateRotatePPoint2 :: (ProjectivePoint2 a) => a -> ℝ -> ℝ -> PPoint2 +translateRotatePPoint2 ppoint d rotation = fst $ translateRotatePPoint2WithErr ppoint d rotation diff --git a/Graphics/Slicer/Math/Skeleton/Cells.hs b/Graphics/Slicer/Math/Skeleton/Cells.hs index 2860bca9f..1b9a32d20 100644 --- a/Graphics/Slicer/Math/Skeleton/Cells.hs +++ b/Graphics/Slicer/Math/Skeleton/Cells.hs @@ -56,9 +56,9 @@ import Graphics.Slicer.Math.GeometricAlgebra (ulpVal) import Graphics.Slicer.Math.Intersections (intersectionBetweenArcsOf, isAntiCollinear, outputIntersectsPLineAt) -import Graphics.Slicer.Math.Lossy (distanceBetweenPPoints, eToPLine2, pToEPoint2) +import Graphics.Slicer.Math.Lossy (distanceBetweenPPointsWithErr, eToPLine2, pToEPoint2) -import Graphics.Slicer.Math.PGA (Arcable(outOf), CPPoint2, Pointable(canPoint, ePointOf, pPointOf), angleBetween2PL, distance2PP, eToPL, eToPP, outAndErrOf) +import Graphics.Slicer.Math.PGA (Arcable(outOf), CPPoint2, Pointable(canPoint, ePointOf, pPointOf), angleBetween2PL, distance2PP, eToPL, eToPP, outAndErrOf, pPointAndErrOf) import Graphics.Slicer.Math.PGAPrimitives (join2PP) @@ -127,10 +127,10 @@ findDivisions contour crashTree = case motorcyclesIn crashTree of then WithENode oneNode else WithLineSeg $ fst $ motorcycleIntersectsAt myContour myMotorcycle where - cMotorcyclePoint = pPointOf myMotorcycle - cNodePoint = pPointOf oneNode - motorcycleENodeDistance = distanceBetweenPPoints cMotorcyclePoint cNodePoint - motorcycleLineSegDistance = distanceBetweenPPoints cMotorcyclePoint $ fst $ fromMaybe (error "no outArc?") $ outputIntersectsPLineAt myMotorcycle (eToPL $ fst $ motorcycleIntersectsAt myContour myMotorcycle) + cMotorcyclePoint = pPointAndErrOf myMotorcycle + cNodePoint = pPointAndErrOf oneNode + motorcycleENodeDistance = distanceBetweenPPointsWithErr cMotorcyclePoint cNodePoint + motorcycleLineSegDistance = distanceBetweenPPointsWithErr cMotorcyclePoint $ fromMaybe (error "no outArc?") $ outputIntersectsPLineAt myMotorcycle (eToPL $ fst $ motorcycleIntersectsAt myContour myMotorcycle) (_:_) -> error "more than one opposing exterior node. cannot yet handle this situation." where eNodesInPath = opposingNodes myContour myMotorcycle From 2b3f4c0c1ccedea1f2128bc8944f256bd3b26082 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 17 Dec 2022 19:03:01 +0000 Subject: [PATCH 155/206] make some loss more visible. --- Graphics/Slicer/Math/Skeleton/Cells.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Graphics/Slicer/Math/Skeleton/Cells.hs b/Graphics/Slicer/Math/Skeleton/Cells.hs index 1b9a32d20..e2d51468f 100644 --- a/Graphics/Slicer/Math/Skeleton/Cells.hs +++ b/Graphics/Slicer/Math/Skeleton/Cells.hs @@ -56,7 +56,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (ulpVal) import Graphics.Slicer.Math.Intersections (intersectionBetweenArcsOf, isAntiCollinear, outputIntersectsPLineAt) -import Graphics.Slicer.Math.Lossy (distanceBetweenPPointsWithErr, eToPLine2, pToEPoint2) +import Graphics.Slicer.Math.Lossy (distanceBetweenPPoints, distanceBetweenPPointsWithErr, eToPLine2, pToEPoint2) import Graphics.Slicer.Math.PGA (Arcable(outOf), CPPoint2, Pointable(canPoint, ePointOf, pPointOf), angleBetween2PL, distance2PP, eToPL, eToPP, outAndErrOf, pPointAndErrOf) @@ -188,7 +188,7 @@ findNextCell (RemainingContour (Slist [(Slist lineSegs _, divides)] _) ) = case elemIndex (fst $ fst div1) contourSegs `compare` elemIndex (fst $ fst div2) contourSegs of LT -> LT GT -> GT - EQ -> fst (distance2PP (startPPoint $ fst $ fst div1, mempty) (toPPoint2 $ snd $ fst div1, mempty)) `compare` fst (distance2PP (startPPoint $ fst $ fst div2, mempty) (toPPoint2 $ snd $ fst div2, mempty)) + EQ -> distanceBetweenPPoints (startPPoint $ fst $ fst div1) (toPPoint2 $ snd $ fst div1) `compare` distanceBetweenPPoints (startPPoint $ fst $ fst div2) (toPPoint2 $ snd $ fst div2) where toPPoint2 :: Either Point2 CPPoint2 -> CPPoint2 toPPoint2 (Left point2) = eToPP point2 From 918ae066e062713d003ccfc5ce86a3740784de66 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 17 Dec 2022 20:22:58 +0000 Subject: [PATCH 156/206] use intersectionsAtSamePoint in skeletonOfNodes, and formatting changes. --- Graphics/Slicer/Math/PGA.hs | 2 +- Graphics/Slicer/Math/Skeleton/Concave.hs | 65 +++++++------------ tests/golden/rectangle-Faces-Default.ganja.js | 14 ++-- .../rectangle-Straight_Skeleton.ganja.js | 14 ++-- tests/golden/square-Faces-Default.ganja.js | 40 +++++------- .../golden/square-Straight_Skeleton.ganja.js | 18 ++--- 6 files changed, 54 insertions(+), 99 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 7c5990caa..f68ea4347 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -38,6 +38,7 @@ module Graphics.Slicer.Math.PGA( Pointable( canPoint, ePointOf, + errOfPPoint, pPointOf ), PPoint2(PPoint2), @@ -54,7 +55,6 @@ module Graphics.Slicer.Math.PGA( distancePPointToPLineWithErr, distance2PP, distance2PL, - errOfPPoint, eToPL, eToPP, flipL, diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index 88f68d791..b86ee19bf 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -28,13 +28,11 @@ module Graphics.Slicer.Math.Skeleton.Concave (skeletonOfConcaveRegion, findINodes, makeENode, makeENodes, averageNodes, eNodesOfOutsideContour) where -import Prelude (Eq, Show, Bool(True, False), Either(Left, Right), String, Ord, Ordering(GT,LT), notElem, otherwise, ($), (>), (<), (<$>), (==), (/=), (>=), error, (&&), fst, and, (<>), show, not, max, compare, uncurry, null, (||), min, snd, filter, zip, any, (*), (+), Int, (.), (-), concatMap, mempty, realToFrac) +import Prelude (Eq, Show, Bool(True, False), Either(Left, Right), String, Ord, Ordering(GT,LT), notElem, otherwise, ($), (>), (<), (<$>), (==), (/=), (>=), error, (&&), fst, (<>), show, not, max, compare, uncurry, null, (||), min, snd, filter, zip, any, (*), (+), Int, (.), (-), concatMap, mempty, realToFrac) import Prelude as PL (head, last, tail, init) -import Data.Either (lefts,rights) - -import Data.Maybe (Maybe(Just,Nothing), catMaybes, fromMaybe, isJust, isNothing, mapMaybe) +import Data.Maybe (Maybe(Just,Nothing), fromMaybe, isJust, isNothing, mapMaybe) import Data.List (takeWhile, dropWhile, sortBy, nub) @@ -58,9 +56,9 @@ import Graphics.Slicer.Math.Definitions (Contour, LineSeg(LineSeg), Point2, endP import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum)) -import Graphics.Slicer.Math.Intersections (intersectionBetween, intersectionOf, isAntiCollinear, isAntiParallel, isCollinear, isParallel, noIntersection) +import Graphics.Slicer.Math.Intersections (intersectionOf, intersectionsAtSamePoint, isAntiCollinear, isAntiParallel, isCollinear, isParallel, noIntersection) -import Graphics.Slicer.Math.PGA (Arcable(errOfOut, hasArc, outOf), Pointable(canPoint, pPointOf), PLine2, PLine2Err, distance2PP, eToPL, flipL, outAndErrOf, pLineIsLeft, distancePPointToPLineWithErr) +import Graphics.Slicer.Math.PGA (Arcable(errOfOut, hasArc, outOf), Pointable(canPoint, pPointOf), PLine2, PLine2Err, distance2PP, eToPL, flipL, outAndErrOf, pLineIsLeft) import Graphics.Slicer.Math.Skeleton.Definitions (ENode(ENode), ENodeSet(ENodeSet), INode(INode), INodeSet(INodeSet), NodeTree(NodeTree), concavePLines, getFirstLineSeg, getLastLineSeg, finalOutOf, firstInOf, getPairs, indexPLinesTo, insOf, lastINodeOf, linePairs, makeINode, sortedPLinesWithErr, isLoop) @@ -471,7 +469,7 @@ sortINodesByENodes loop inSegSets inGens@(INodeSet rawGenerations) [v] -> v (_:_) -> error "filter passed too many connecting PLines." iNodeInsOf myINode = filter (\a -> isNothing . findENodeByOutput (eNodeSetOf $ slist initialENodes) $ fst a) $ insOf myINode - withoutConnectingPLine = filter (\a -> a /= oldConnectingPLine) + withoutConnectingPLine = filter (/= oldConnectingPLine) -- Determine if the given INode has a PLine that points to an ENode. hasENode iNode = any (isJust . findENodeByOutput (eNodeSetOf $ slist initialENodes)) $ fst <$> insOf iNode @@ -538,8 +536,9 @@ sortINodesByENodes loop inSegSets inGens@(INodeSet rawGenerations) -- | add together a child and it's parent. addINodeToParent :: INode -> INode -> INode - addINodeToParent (INode _ _ _ Nothing) _ = error "cannot merge a child inode with no output!" - addINodeToParent iNode1@(INode _ _ _ (Just out1)) iNode2@(INode _ _ _ out2) = orderInsByENodes $ makeINode (insOf iNode1 <> withoutPLine (fst out1) (insOf iNode2)) out2 + addINodeToParent iNode1 iNode2@(INode _ _ _ out2) + | hasArc iNode1 = orderInsByENodes $ makeINode (insOf iNode1 <> withoutPLine (outOf iNode1) (insOf iNode2)) out2 + | otherwise = error "cannot merge a child inode with no output!" where withoutPLine :: PLine2 -> [(PLine2,PLine2Err)] -> [(PLine2,PLine2Err)] withoutPLine myPLine = filter (\a -> fst a /= myPLine) @@ -569,7 +568,7 @@ skeletonOfNodes connectedLoop inSegSets iNodes = else -- Construct an INode with two identical inputs, and return it. -- FIXME: shouldn't we be able to return an empty set, instead? - Right $ INodeSet $ one [INode (outAndErrOf eNode) (outAndErrOf eNode) (slist []) Nothing] + Right $ INodeSet $ one [makeINode [outAndErrOf eNode, outAndErrOf eNode] Nothing] [iNode] -> handleTwoNodes eNode iNode (_:_) -> handleThreeOrMoreNodes [eNode1,eNode2] -> case iNodes of @@ -584,9 +583,11 @@ skeletonOfNodes connectedLoop inSegSets iNodes = -- Handle the the case of two nodes. handleTwoNodes :: (Arcable a, Pointable a, Arcable b, Pointable b) => a -> b -> Either PartialNodes INodeSet handleTwoNodes node1 node2 + | not (hasArc node1) || not (hasArc node2) = error $ "ran across a node without an output?\n" <> show node1 <> "\n" <> show node2 <> "\n" | isCollinear (outAndErrOf node1) (outAndErrOf node2) = Left $ PartialNodes (INodeSet $ one iNodes) $ "cannot handle collinear nodes:\n" <> show node1 <> "\n" <> show node2 <> "\n" | nodesAreAntiCollinear node1 node2 && contourLooped = Right $ INodeSet $ one [makeLastPair node1 node2] - | contourLooped = -- this is a complete loop, so this last INode will be re-written in sortINodesByENodes anyways. + | contourLooped = + -- this is a complete loop, so this last INode will be re-written in sortINodesByENodes anyways. Right $ INodeSet $ one [makeINode (sortedPLinesWithErr [outAndErrOf node1,outAndErrOf node2]) Nothing] | intersectsInPoint node1 node2 = Right $ INodeSet $ one [averageNodes node1 node2] | otherwise = errorLen2 @@ -623,39 +624,21 @@ skeletonOfNodes connectedLoop inSegSets iNodes = -- | When all of our nodes end in the same point we should create a single Node with all of them as input. This checks for that case. endsAtSamePoint :: Bool - endsAtSamePoint - | and $ isJust <$> intersections = and $ pointsCloseEnough <> linesCloseEnough - | otherwise = False + endsAtSamePoint = intersectionsAtSamePoint nodeOutsAndErrs where - intersections = mapWithFollower intersectionBetween ((outAndErrOf <$> nonAntiCollinearNodes eNodes (antiCollinearNodePairsOf eNodes) <> firstAntiCollinearNodes (antiCollinearNodePairsOf eNodes)) <> - (outAndErrOf <$> nonAntiCollinearNodes iNodes (antiCollinearNodePairsOf iNodes) <> firstAntiCollinearNodes (antiCollinearNodePairsOf iNodes))) - pointIntersections = rights $ catMaybes intersections - lineIntersections = lefts $ catMaybes intersections - pointsCloseEnough = mapWithFollower pairCloseEnough pointIntersections - where - pairCloseEnough a b = res < realToFrac errRes - where - (res, (_,_,UlpSum errRes)) = distance2PP a b - linesCloseEnough = - case lineIntersections of - [] -> [] - [a] -> case pointIntersections of - [] -> error "one line, no points.. makes no sense." - (x:_) -> [and pointsCloseEnough && foundDistance < realToFrac foundErr] - where - (foundDistance, (_,_,_,_,_,UlpSum foundErr)) = distancePPointToPLineWithErr x a - (_:_) -> error - $ "detected multiple lines?\n" - <> show lineIntersections <> "\n" - <> show pointIntersections <> "\n" + nodeOutsAndErrs = nonAntiCollinearOutErrPairs allOuts (antiCollinearOutErrPairsOf allOuts) + <> firstofAntiCollinearOutErrPairs (antiCollinearOutErrPairsOf allOuts) + allOuts = (outAndErrOf <$> eNodes) <> (outAndErrOf <$> iNodes) -- since anti-collinear nodes end at the same point, only count one of them. - firstAntiCollinearNodes nodePairs = fst <$> nodePairs - -- find nodes that do not have an anti-collinear pair. + firstofAntiCollinearOutErrPairs nodePairs = fst <$> nodePairs + -- filter out collinear pairs. eliminates both ends. -- FIXME: is there a better way do do this with Ord? - nonAntiCollinearNodes :: (Eq a) => [a] -> [(a,a)] -> [a] - nonAntiCollinearNodes myNodes nodePairs = filter (`notElem` allAntiCollinearNodes nodePairs) myNodes + nonAntiCollinearOutErrPairs :: (Eq a) => [a] -> [(a,a)] -> [a] + nonAntiCollinearOutErrPairs myNodes nodePairs = filter (`notElem` allAntiCollinearNodes nodePairs) myNodes where allAntiCollinearNodes myNodePairs = (fst <$> myNodePairs) <> (snd <$> myNodePairs) + -- Find our anti-collinear pairs. + antiCollinearOutErrPairsOf inOutErrPairs = filter (uncurry isAntiCollinear) $ getPairs inOutErrPairs -- | make sure we have a potential intersection between two nodes to work with. hasShortestNeighboringPair :: Bool @@ -814,10 +797,6 @@ skeletonOfNodes connectedLoop inSegSets iNodes = intersectingNeighboringNodePairsOf :: (Arcable a, Pointable a) => [(a,a)] -> [(a, a)] intersectingNeighboringNodePairsOf inNodePairs = mapMaybe (\(node1, node2) -> if intersectsInPoint node1 node2 then Just (node1, node2) else Nothing) $ inNodePairs - -- | find nodes that have output segments that are antiCollinear with one another. - antiCollinearNodePairsOf :: (Arcable a) => [a] -> [(a, a)] - antiCollinearNodePairsOf inNodes = mapMaybe (\(node1, node2) -> if nodesAreAntiCollinear node1 node2 then Just (node1, node2) else Nothing) $ getPairs inNodes - -- | for a given pair of nodes, find the longest distance between one of the two nodes and the intersection of the two output plines. distanceToIntersection :: (Pointable a, Arcable a, Pointable b, Arcable b) => a -> b -> Maybe ℝ distanceToIntersection node1 node2 diff --git a/tests/golden/rectangle-Faces-Default.ganja.js b/tests/golden/rectangle-Faces-Default.ganja.js index 6513c9c07..ce10a6b91 100644 --- a/tests/golden/rectangle-Faces-Default.ganja.js +++ b/tests/golden/rectangle-Faces-Default.ganja.js @@ -12,13 +12,11 @@ Algebra(2,0,1,()=>{ var ae = -1.0e1+1.0e2+0.0e0; var af = 1.0e1+1.0e2+0.0e0; var ag = -1.0e1-1.0e2-1.0e0; - var ah = 0.0e1+1.414213562373095e2+0.0e0; - var ai = -1.0e1+1.0e2+0.0e0; - var aj = 1.0e1-1.0e2+1.0e0; - var ak = -1.0e1-1.0e2-1.0e0; - var al = 1.0e1+1.0e2+0.0e0; - var am = 0.0e1+1.414213562373095e2+0.0e0; - var an = 1.0e1-1.0e2+1.0e0; + var ah = -1.0e1+1.0e2+0.0e0; + var ai = 1.0e1-1.0e2+1.0e0; + var aj = -1.0e1-1.0e2-1.0e0; + var ak = 1.0e1+1.0e2+0.0e0; + var al = 1.0e1-1.0e2+1.0e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], @@ -48,8 +46,6 @@ Algebra(2,0,1,()=>{ aj, "aj", ak, "ak", al, "al", - am, "am", - an, "an", ],{ grid: true, labels: true, diff --git a/tests/golden/rectangle-Straight_Skeleton.ganja.js b/tests/golden/rectangle-Straight_Skeleton.ganja.js index a41b2ad7e..f808af9f0 100644 --- a/tests/golden/rectangle-Straight_Skeleton.ganja.js +++ b/tests/golden/rectangle-Straight_Skeleton.ganja.js @@ -9,12 +9,10 @@ Algebra(2,0,1,()=>{ var acb = point(-2.0,1.0); var ada = point(-2.0,1.0); var adb = point(-2.0,-1.0); - var aea = 1.0e1+1.0e2+0.0e0; - var aeb = -1.0e1+1.0e2+0.0e0; - var aec = 0.0e1+1.414213562373095e2+0.0e0; - var afa = 1.0e1-1.0e2+1.0e0; - var afb = 0.0e1+1.414213562373095e2+0.0e0; - var afc = -1.0e1-1.0e2-1.0e0; + var aea = 1.0e1-1.0e2+1.0e0; + var aeb = 1.0e1+1.0e2+0.0e0; + var aec = -1.0e1+1.0e2+0.0e0; + var aed = -1.0e1-1.0e2-1.0e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], @@ -39,9 +37,7 @@ Algebra(2,0,1,()=>{ aea, "aea", aeb, "aeb", aec, "aec", - afa, "afa", - afb, "afb", - afc, "afc", + aed, "aed", ],{ grid: true, labels: true, diff --git a/tests/golden/square-Faces-Default.ganja.js b/tests/golden/square-Faces-Default.ganja.js index f17b01db4..777c467ed 100644 --- a/tests/golden/square-Faces-Default.ganja.js +++ b/tests/golden/square-Faces-Default.ganja.js @@ -1,26 +1,22 @@ Algebra(2,0,1,()=>{ var line = (a,b,c)=>a*1e1 + b*1e2 + c*1e0; var point = (x,y)=>!(1e0 + x*1e1 + y*1e2); - var aaa = point(-1.0,1.0); - var aab = point(-1.0,-1.0); - var aba = point(-1.0,-1.0); - var abb = point(1.0,-1.0); - var aca = point(1.0,-1.0); - var acb = point(1.0,1.0); - var ada = point(1.0,1.0); - var adb = point(-1.0,1.0); - var ae = 1.0e1-1.0e2+0.0e0; - var af = 1.414213562373095e1+0.0e2+0.0e0; - var ag = -1.414213562373095e1+0.0e2+0.0e0; - var ah = -1.0e1-1.0e2+0.0e0; - var ai = 1.0e1+1.0e2+0.0e0; - var aj = 1.0e1-1.0e2+0.0e0; - var ak = -1.0e1+1.0e2+0.0e0; - var al = -1.414213562373095e1+0.0e2+0.0e0; - var am = 1.414213562373095e1+0.0e2+0.0e0; - var an = 1.0e1+1.0e2+0.0e0; - var ao = -1.0e1-1.0e2+0.0e0; - var ap = -1.0e1+1.0e2+0.0e0; + var aaa = point(1.0,-1.0); + var aab = point(1.0,1.0); + var aba = point(1.0,1.0); + var abb = point(-1.0,1.0); + var aca = point(-1.0,1.0); + var acb = point(-1.0,-1.0); + var ada = point(-1.0,-1.0); + var adb = point(1.0,-1.0); + var ae = -1.0e1+1.0e2+0.0e0; + var af = 1.0e1+1.0e2+0.0e0; + var ag = -1.0e1-1.0e2+0.0e0; + var ah = -1.0e1+1.0e2+0.0e0; + var ai = 1.0e1-1.0e2+0.0e0; + var aj = -1.0e1-1.0e2+0.0e0; + var ak = 1.0e1+1.0e2+0.0e0; + var al = 1.0e1-1.0e2+0.0e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], @@ -50,10 +46,6 @@ Algebra(2,0,1,()=>{ aj, "aj", ak, "ak", al, "al", - am, "am", - an, "an", - ao, "ao", - ap, "ap", ],{ grid: true, labels: true, diff --git a/tests/golden/square-Straight_Skeleton.ganja.js b/tests/golden/square-Straight_Skeleton.ganja.js index b5b17d198..a94d6254f 100644 --- a/tests/golden/square-Straight_Skeleton.ganja.js +++ b/tests/golden/square-Straight_Skeleton.ganja.js @@ -9,14 +9,10 @@ Algebra(2,0,1,()=>{ var acb = point(-1.0,1.0); var ada = point(-1.0,1.0); var adb = point(-1.0,-1.0); - var aea = -1.0e1+1.0e2+0.0e0; - var aeb = -1.0e1-1.0e2+0.0e0; - var aec = -1.414213562373095e1+0.0e2+0.0e0; - var afa = 1.0e1-1.0e2+0.0e0; - var afb = 1.0e1+1.0e2+0.0e0; - var afc = 1.414213562373095e1+0.0e2+0.0e0; - var aga = 1.414213562373095e1+0.0e2+0.0e0; - var agb = -1.414213562373095e1+0.0e2+0.0e0; + var aea = 1.0e1-1.0e2+0.0e0; + var aeb = 1.0e1+1.0e2+0.0e0; + var aec = -1.0e1+1.0e2+0.0e0; + var aed = -1.0e1-1.0e2+0.0e0; document.body.appendChild(this.graph([ 0x882288, [aaa,aab], @@ -41,11 +37,7 @@ Algebra(2,0,1,()=>{ aea, "aea", aeb, "aeb", aec, "aec", - afa, "afa", - afb, "afb", - afc, "afc", - aga, "aga", - agb, "agb", + aed, "aed", ],{ grid: true, labels: true, From 1780e04f16d078019480d4fea4e22e9ed6db6e1b Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 17 Dec 2022 22:02:33 +0000 Subject: [PATCH 157/206] remove warnings, and move outputIntersetsLineSeg into Intersections.hs --- Graphics/Slicer/Machine/GCode.hs | 1 - Graphics/Slicer/Math/Arcs.hs | 1 + Graphics/Slicer/Math/ContourIntersections.hs | 4 +++- Graphics/Slicer/Math/Intersections.hs | 23 +++++++++++++++++--- Graphics/Slicer/Math/PGA.hs | 14 ++---------- Graphics/Slicer/Math/PGAPrimitives.hs | 11 ++++++++++ Graphics/Slicer/Math/Skeleton/Motorcycles.hs | 5 +++-- Graphics/Slicer/Math/Skeleton/NodeTrees.hs | 1 - tests/Math/PGA.hs | 4 +++- 9 files changed, 43 insertions(+), 21 deletions(-) diff --git a/Graphics/Slicer/Machine/GCode.hs b/Graphics/Slicer/Machine/GCode.hs index 56b119c97..990b01558 100644 --- a/Graphics/Slicer/Machine/GCode.hs +++ b/Graphics/Slicer/Machine/GCode.hs @@ -207,7 +207,6 @@ gcodeForInfill :: ℝ -> ℝ -> ℝ -> ℝ -> [[LineSeg]] -> [GCode] gcodeForInfill _ _ _ _ [] = [] gcodeForInfill lh pathWidth infillFeedRate travelFeedRate lineGroups = case lineGroups of - [] -> [] (headGroup:tailGroups) -> concat $ renderLineSegGroup headGroup : zipWith (\group1 group2 -> moveBetweenLineSegGroups group1 group2 <> renderLineSegGroup group2) lineGroups tailGroups where -- FIXME: this should be a single gcode. why are we getting empty line groups given to us? diff --git a/Graphics/Slicer/Math/Arcs.hs b/Graphics/Slicer/Math/Arcs.hs index 89b540252..3226b4043 100644 --- a/Graphics/Slicer/Math/Arcs.hs +++ b/Graphics/Slicer/Math/Arcs.hs @@ -67,6 +67,7 @@ getInsideArc line1 line2 = (res, resErr) -- | Get a projective line along the angle bisector of the intersection of the two given lines, pointing in the 'acute' direction. -- Note that we assume that the first line points toward the intersection. +{-# INLINABLE getAcuteAngleBisectorFromLines #-} getAcuteAngleBisectorFromLines :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> (PLine2, (PLine2Err, PLine2Err, PLine2Err)) getAcuteAngleBisectorFromLines line1@(pl1, _) line2@(pl2, _) | isCollinear line1 line2 = error "Asked to find the acute bisector of two colinear lines!" diff --git a/Graphics/Slicer/Math/ContourIntersections.hs b/Graphics/Slicer/Math/ContourIntersections.hs index 11191519b..0310fa653 100644 --- a/Graphics/Slicer/Math/ContourIntersections.hs +++ b/Graphics/Slicer/Math/ContourIntersections.hs @@ -39,7 +39,9 @@ import Graphics.Slicer.Definitions (ℝ) import Graphics.Slicer.Math.Definitions (Contour, LineSeg(endPoint, startPoint), Point2, distance, fudgeFactor, lineSegsOfContour, makeLineSeg, mapWithNeighbors) -import Graphics.Slicer.Math.PGA (CPPoint2, Intersection(HitEndPoint, HitStartPoint, NoIntersection), NPLine2, PIntersection(IntersectsIn, PAntiCollinear, PAntiParallel, PCollinear, PParallel), PLine2Err, ProjectiveLine2, intersectsWithErr, normalizeL, outputIntersectsLineSeg, pToEP) +import Graphics.Slicer.Math.Intersections (outputIntersectsLineSeg) + +import Graphics.Slicer.Math.PGA (CPPoint2, Intersection(HitEndPoint, HitStartPoint, NoIntersection), NPLine2, PIntersection(IntersectsIn, PAntiCollinear, PAntiParallel, PCollinear, PParallel), PLine2Err, ProjectiveLine2, intersectsWithErr, normalizeL, pToEP) import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle)) diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index 2c996cbca..26ee7f3c5 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -30,6 +30,7 @@ module Graphics.Slicer.Math.Intersections ( isCollinear, isParallel, noIntersection, + outputIntersectsLineSeg, outputIntersectsPLineAt ) where @@ -37,15 +38,16 @@ import Prelude (Bool(True), Either(Left, Right), (<>), ($), (<), (||), (==), (&& import Data.Either (rights, lefts) -import Data.Maybe (Maybe(Just, Nothing), catMaybes, isJust) +import Data.Maybe (Maybe(Just, Nothing), catMaybes, isJust, isNothing) -import Graphics.Slicer.Math.Definitions (mapWithFollower) +import Graphics.Slicer.Math.Definitions (LineSeg, mapWithFollower) import Graphics.Slicer.Math.GeometricAlgebra (ulpVal) -import Graphics.Slicer.Math.PGA (Arcable(hasArc), CPPoint2, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), PLine2Err, PPoint2Err, ProjectiveLine2, distance2PL, distance2PP, distancePPointToPLineWithErr, fuzzinessOfL, fuzzinessOfP, outAndErrOf, pLineErrAtPPoint, plinesIntersectIn) +import Graphics.Slicer.Math.PGA (Arcable(hasArc), CPPoint2, Intersection, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), PLine2Err, PPoint2Err, ProjectiveLine2, canonicalizedIntersectionOf2PL, distance2PL, distance2PP, distancePPointToPLineWithErr, eToPL, fuzzinessOfL, fuzzinessOfP, outAndErrOf, pLineErrAtPPoint, pLineIntersectsLineSeg, plinesIntersectIn) -- | Check if two lines cannot intersect. +{-# INLINABLE noIntersection #-} noIntersection :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Bool noIntersection line1 line2 = isCollinear line1 line2 || isParallel line1 line2 || isAntiCollinear line1 line2 || isAntiParallel line1 line2 @@ -66,6 +68,7 @@ isAntiParallel :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b isAntiParallel line1 line2 = plinesIntersectIn line1 line2 == PAntiParallel -- | Get the intersection point of two lines we know have an intersection point. +{-# INLINABLE intersectionOf #-} intersectionOf :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> (CPPoint2, PPoint2Err) intersectionOf line1 line2 = saneIntersection $ plinesIntersectIn line1 line2 where @@ -91,6 +94,7 @@ intersectionBetween line1@(l1, _) line2@(l2, _) = saneIntersection $ plinesInter saneIntersection (IntersectsIn p (_,_, pErr)) = Just $ Right (p, pErr) -- | Find out where the output of two Arcables intersect. returns Nothing if no intersection, and errors if no output Arc exists on either input. +{-# INLINABLE intersectionBetweenArcsOf #-} intersectionBetweenArcsOf :: (Arcable a, Arcable b) => a -> b -> Maybe (CPPoint2, PPoint2Err) intersectionBetweenArcsOf node1 node2 | hasArc node1 && hasArc node2 = case res of @@ -100,7 +104,20 @@ intersectionBetweenArcsOf node1 node2 where res = plinesIntersectIn (outAndErrOf node1) (outAndErrOf node2) +-- | Check if/where the arc of a motorcycle, inode, or enode intersect a line segment. +{-# INLINABLE outputIntersectsLineSeg #-} +outputIntersectsLineSeg :: (Arcable a) => a -> LineSeg -> Either Intersection PIntersection +outputIntersectsLineSeg source l1 + -- handle the case where a segment that is an input to the node is checked against. + | isNothing canonicalizedIntersection = Right $ plinesIntersectIn (pl1, pl1Err) (pl2, pl2Err) + | otherwise = pLineIntersectsLineSeg (pl1, pl1Err) l1 + where + (pl2, pl2Err) = eToPL l1 + (pl1, pl1Err) = outAndErrOf source + canonicalizedIntersection = canonicalizedIntersectionOf2PL pl1 pl2 + -- | Find out where the output of an Arcable intersects a given PLine2. errors if no intersection. +{-# INLINABLE outputIntersectsPLineAt #-} outputIntersectsPLineAt :: (Arcable a, ProjectiveLine2 b) => a -> (b, PLine2Err) -> Maybe (CPPoint2, PPoint2Err) outputIntersectsPLineAt n line | hasArc n = case res of diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index f68ea4347..347dd711c 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -51,6 +51,7 @@ module Graphics.Slicer.Math.PGA( canonicalizeP ), angleBetween2PL, + canonicalizedIntersectionOf2PL, combineConsecutiveLineSegs, distancePPointToPLineWithErr, distance2PP, @@ -67,7 +68,7 @@ module Graphics.Slicer.Math.PGA( join2PP, makePPoint2, outAndErrOf, - outputIntersectsLineSeg, + pLineIntersectsLineSeg, pLineIsLeft, pPointAndErrOf, pPointOnPerpWithErr, @@ -316,17 +317,6 @@ pPointAndErrOf node | canPoint node = (pPointOf node, errOfPPoint node) | otherwise = error "not able to resolve node to a point." --- | Check if/where the arc of a motorcycle, inode, or enode intersect a line segment. -outputIntersectsLineSeg :: (Arcable a) => a -> LineSeg -> Either Intersection PIntersection -outputIntersectsLineSeg source l1 - -- handle the case where a segment that is an input to the node is checked against. - | isNothing canonicalizedIntersection = Right $ plinesIntersectIn (pl1, pl1Err) (pl2, pl2Err) - | otherwise = pLineIntersectsLineSeg (pl1, pl1Err) l1 - where - (pl2, pl2Err) = eToPL l1 - (pl1, pl1Err) = outAndErrOf source - canonicalizedIntersection = canonicalizedIntersectionOf2PL pl1 pl2 - ---------------------------------------------------------- -------------- Euclidian Mixed Interface ----------------- ---------------------------------------------------------- diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index 3d60837e9..953546399 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -194,6 +194,7 @@ instance Monoid PLine2Err where -- | Return the sine of the angle between the two lines, along with the error. -- Results in a value that is ~+1 when a line points in the same direction of the other given line, and ~-1 when pointing backwards. angleBetweenProjectiveLines :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, ([ErrVal], [ErrVal]), UlpSum)) +{-# INLINABLE angleBetweenProjectiveLines #-} angleBetweenProjectiveLines line1 line2 = (scalarPart likeRes, resErr) where resErr = (npl1Err, npl2Err, (likeMulErr,likeAddErr), ulpSum) @@ -212,6 +213,7 @@ angleBetween2PL l1 l2 = crushErr $ angleBetweenProjectiveLines l1 l2 crushErr (res, (n1,n2,_,resErr)) = (res, (n1,n2,resErr)) -- | Find the distance between two parallel or antiparallel projective lines. +{-# INLINABLE distanceBetweenProjectiveLines #-} distanceBetweenProjectiveLines :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, ([ErrVal], [ErrVal]), UlpSum)) distanceBetweenProjectiveLines line1 line2 = (res, resErr) where @@ -224,6 +226,7 @@ distanceBetweenProjectiveLines line1 line2 = (res, resErr) (npl2, npl2Err) = normalizeL line2 -- | A wrapper for the above function, that removes error quotents that are not directly related to the input or result. +{-# INLINABLE distance2PL #-} distance2PL :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, UlpSum)) distance2PL l1 l2 = crushErr $ distanceBetweenProjectiveLines l1 l2 where @@ -281,6 +284,7 @@ fuzzinessOfL l = fuzzinessOfProjectiveLine l -- Note: This should only be used when you can guarantee the input lines are not collinear, or parallel. intersectionOfProjectiveLines, intersect2PL :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PPoint2, (PLine2Err, PLine2Err, PPoint2Err)) -- | Actual implementation. +{-# INLINABLE intersectionOfProjectiveLines #-} intersectionOfProjectiveLines line1 line2 = (res, (line1Err, line2Err, resErr)) where (res, (line1Err, line2Err, resUnlikeErrs)) = meetOfProjectiveLines line1 line2 @@ -288,10 +292,12 @@ intersectionOfProjectiveLines line1 line2 = (res, (line1Err, line2Err, resErr)) -- Since the angle of intersection has an effect on how well this point was resolved, save it with the point. (iAngleErr,(_,_,iAngleUnlikeErr,_)) = angleBetweenProjectiveLines line1 line2 -- | Wrapper. +{-# INLINABLE intersect2PL #-} intersect2PL l1 l2 = intersectionOfProjectiveLines l1 l2 -- | A typed meet function. the meeting of two lines is a point. -- Kept separate from intersectionOfProjectiveLines for verification reasons. +{-# INLINABLE meetOfProjectiveLines #-} meetOfProjectiveLines :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PPoint2, (PLine2Err, PLine2Err, ([ErrVal], [ErrVal]))) meetOfProjectiveLines line1 line2 = (PPoint2 res, (npl1Err, @@ -492,6 +498,7 @@ angleCosBetween2PL l1 l2 = angleCosBetweenProjectiveLines l1 l2 -- NOTE: Returns Nothing when the lines are (anti)parallel. canonicalizedIntersectionOfProjectiveLines, canonicalizedIntersectionOf2PL :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Maybe (CPPoint2, (PLine2Err, PLine2Err, PPoint2Err)) -- | Actual implementation. +{-# INLINABLE canonicalizedIntersectionOfProjectiveLines #-} canonicalizedIntersectionOfProjectiveLines line1 line2 -- | Check whether the result of our intersection returns an ideal point. if it does, it means the two lines are (anti)parallel, and we should fail. | isIdealP pp1 = Nothing @@ -500,6 +507,7 @@ canonicalizedIntersectionOfProjectiveLines line1 line2 (cpp1, cpp1Err) = canonicalizeP pp1 (pp1, (l1Err, l2Err, pp1Err)) = intersect2PL line1 line2 -- | Wrapper. +{-# INLINABLE canonicalizedIntersectionOf2PL #-} canonicalizedIntersectionOf2PL l1 l2 = canonicalizedIntersectionOfProjectiveLines l1 l2 -------------------------------- @@ -646,6 +654,7 @@ idealNormOfProjectivePoint point idealNormOfP p = idealNormOfProjectivePoint p -- | Join two points, returning the line that connects them. +{-# INLINABLE joinOfProjectivePoints #-} joinOfProjectivePoints, join2PP :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> (PLine2, (PPoint2Err, PPoint2Err, PLine2Err)) -- | Actual implementation. joinOfProjectivePoints point1 point2 = (PLine2 res, @@ -658,6 +667,7 @@ joinOfProjectivePoints point1 point2 = (PLine2 res, (cPoint1, cPoint1Err) = canonicalizeP point1 (cPoint2, cPoint2Err) = canonicalizeP point2 -- | Wrapper. +{-# INLINABLE join2PP #-} join2PP p1 p2 = joinOfProjectivePoints p1 p2 -- | Find a point along the line between the two given points. @@ -679,6 +689,7 @@ projectivePointBetweenProjectivePoints startPoint stopPoint weight1 weight2 (cStartPoint, cStartPointErr) = canonicalizeP startPoint (cStopPoint, cStopPointErr) = canonicalizeP stopPoint -- | Wrapper. +{-# INLINABLE interpolate2PP #-} interpolate2PP p1 p2 = projectivePointBetweenProjectivePoints p1 p2 -- | Determine if a point is an ideal point. diff --git a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs index b12182d27..e3440bc2f 100644 --- a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs +++ b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs @@ -48,11 +48,11 @@ import Graphics.Slicer.Math.ContourIntersections (getMotorcycleContourIntersecti import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, mapWithNeighbors, startPoint, endPoint, makeLineSeg) -import Graphics.Slicer.Math.Intersections (intersectionOf, isAntiCollinear, noIntersection) +import Graphics.Slicer.Math.Intersections (intersectionOf, isAntiCollinear, noIntersection, outputIntersectsLineSeg) import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, pPointBetweenPPoints, distanceBetweenPPoints, eToPLine2, normalizePLine2, pToEPoint2) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), PPoint2, PPoint2Err, Arcable(outOf), Pointable(canPoint, ePointOf, pPointOf), eToPL, flipL, pLineIsLeft, pPointsOnSameSideOfPLine, PIntersection(IntersectsIn,PAntiCollinear), ProjectivePoint2, angleBetween2PL, distance2PP, eToPP, join2PP, outAndErrOf, outputIntersectsLineSeg, plinesIntersectIn, translateL) +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), PPoint2, PPoint2Err, Arcable(outOf), Pointable(canPoint, ePointOf, pPointOf), eToPL, flipL, pLineIsLeft, pPointsOnSameSideOfPLine, PIntersection(IntersectsIn,PAntiCollinear), ProjectivePoint2, angleBetween2PL, distance2PP, eToPP, join2PP, outAndErrOf, plinesIntersectIn, translateL) import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle), ENode(ENode), getFirstLineSeg, linePairs, CellDivide(CellDivide), DividingMotorcycles(DividingMotorcycles), MotorcycleIntersection(WithLineSeg, WithENode, WithMotorcycle)) @@ -313,6 +313,7 @@ motorcycleIntersectsAt contour motorcycle = case intersections of -- | Determine if a node is on one side of a motorcycle, or the other. -- Assumes the starting point of the second line segment is a point on the path. +{-# INLINABLE intersectionSameSide #-} intersectionSameSide :: (ProjectivePoint2 a, Pointable b) => (a, PPoint2Err) -> b -> Motorcycle -> Maybe Bool intersectionSameSide point@(pp1, _) node (Motorcycle _ path _) | canPoint node && d < realToFrac (ulpVal dErr) = Just True diff --git a/Graphics/Slicer/Math/Skeleton/NodeTrees.hs b/Graphics/Slicer/Math/Skeleton/NodeTrees.hs index 8471bff30..5051b26a7 100644 --- a/Graphics/Slicer/Math/Skeleton/NodeTrees.hs +++ b/Graphics/Slicer/Math/Skeleton/NodeTrees.hs @@ -64,7 +64,6 @@ pathTo :: NodeTree -> Direction -> ([PLine2], [INode], ENode) pathTo (NodeTree (ENodeSet (Slist [] _)) _) _ = error "unable to pathTo a Nodetree without ENodes." pathTo (NodeTree eNodeSet@(ENodeSet eNodeSides) iNodeSet@(INodeSet generations)) direction | isEmpty generations = case eNodeSides of - (Slist [] _) -> error "looking for a first ENode in an empty ENodeSet." (Slist [(firstENode,_)] _) -> ([outOf firstENode], [], firstENode) (Slist _ _) -> error "looking for a first ENode in an ENodeSet with more than one side." | otherwise = pathInner (ancestorsOf iNodeSet) eNodeSet (finalINodeOf iNodeSet) diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index aed0c84a7..1dc992a3f 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -59,10 +59,12 @@ import Graphics.Slicer.Math.Definitions(Point2(Point2), Contour(LineSegContour), -- Our Geometric Algebra library. import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(GEZero, GEPlus, G0), GVal(GVal), GVec(GVec), UlpSum(UlpSum), addValPairWithErr, subValPairWithErr, addValWithErr, ulpVal, subVal, addVecPair, subVecPair, mulScalarVecWithErr, divVecScalarWithErr, scalarPart, vectorPart, (•), (∧), (⋅), (⎣), (⎤)) +import Graphics.Slicer.Math.Intersections (outputIntersectsLineSeg) + import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenPLines, distancePPointToPLine, eToPLine2, getFirstArc, join2PPoint2, normalizePLine2, pPointOnPerp) -- Our 2D Projective Geometric Algebra library. -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PLine2Err(PLine2Err), canonicalizeP, distance2PP, distancePPointToPLineWithErr, eToPL, eToPP, eToPP, interpolate2PP, intersect2PL, translateL, translateRotatePPoint2WithErr, angleBetween2PL, flipL, join2PP, makePPoint2, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, distancePPointToPLineWithErr, errOfOut, pPointOnPerpWithErr, outOf, pPointOf, outputIntersectsLineSeg) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PLine2Err(PLine2Err), canonicalizeP, distance2PP, distancePPointToPLineWithErr, eToPL, eToPP, eToPP, interpolate2PP, intersect2PL, translateL, translateRotatePPoint2WithErr, angleBetween2PL, flipL, join2PP, makePPoint2, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, distancePPointToPLineWithErr, errOfOut, pPointOnPerpWithErr, outOf, pPointOf) -- The primitives of our PGA only library, and error estimation code. From 6506c9605f0dd9c16ffeea91123a2012cc69a08c Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 18 Dec 2022 01:29:57 +0000 Subject: [PATCH 158/206] better spacing, and a missing inlinable. --- Graphics/Slicer/Math/Arcs.hs | 1 + Graphics/Slicer/Math/PGAPrimitives.hs | 7 ++++--- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/Graphics/Slicer/Math/Arcs.hs b/Graphics/Slicer/Math/Arcs.hs index 3226b4043..95e8472ae 100644 --- a/Graphics/Slicer/Math/Arcs.hs +++ b/Graphics/Slicer/Math/Arcs.hs @@ -116,6 +116,7 @@ getObtuseAngleBisectorFromPointedLines ppoint1 line1 ppoint2 line2 l2TowardPoint = towardIntersection ppoint2 line2 intersectionPoint -- | Determine if the line formed by the two given points goes through the first point first, or the second. +{-# INLINABLE towardIntersection #-} towardIntersection :: (ProjectivePoint2 a, ProjectiveLine2 b, ProjectivePoint2 c) => (a, PPoint2Err) -> (b, PLine2Err) -> (c, PPoint2Err) -> Bool towardIntersection point1@(pp1, _) (pl1, _) point2@(pp2, _) | d <= realToFrac (ulpVal dErr) = error $ "cannot resolve points finely enough.\nPPoint1: " <> show pp1 <> "\nPPoint2: " <> show pp2 <> "\nPLineIn: " <> show pl1 <> "\nnewPLine: " <> show newPLine <> "\n" diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index 953546399..a42b706ac 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -193,8 +193,8 @@ instance Monoid PLine2Err where -- | Return the sine of the angle between the two lines, along with the error. -- Results in a value that is ~+1 when a line points in the same direction of the other given line, and ~-1 when pointing backwards. -angleBetweenProjectiveLines :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, ([ErrVal], [ErrVal]), UlpSum)) {-# INLINABLE angleBetweenProjectiveLines #-} +angleBetweenProjectiveLines :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, ([ErrVal], [ErrVal]), UlpSum)) angleBetweenProjectiveLines line1 line2 = (scalarPart likeRes, resErr) where resErr = (npl1Err, npl2Err, (likeMulErr,likeAddErr), ulpSum) @@ -282,9 +282,9 @@ fuzzinessOfL l = fuzzinessOfProjectiveLine l -- | Find out where two lines intersect, returning a projective point, and the error quotents. -- Note: This should only be used when you can guarantee the input lines are not collinear, or parallel. +{-# INLINABLE intersectionOfProjectiveLines #-} intersectionOfProjectiveLines, intersect2PL :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PPoint2, (PLine2Err, PLine2Err, PPoint2Err)) -- | Actual implementation. -{-# INLINABLE intersectionOfProjectiveLines #-} intersectionOfProjectiveLines line1 line2 = (res, (line1Err, line2Err, resErr)) where (res, (line1Err, line2Err, resUnlikeErrs)) = meetOfProjectiveLines line1 line2 @@ -496,9 +496,9 @@ angleCosBetween2PL l1 l2 = angleCosBetweenProjectiveLines l1 l2 -- | Get the canonicalized intersection of two lines. -- NOTE: Returns Nothing when the lines are (anti)parallel. +{-# INLINABLE canonicalizedIntersectionOfProjectiveLines #-} canonicalizedIntersectionOfProjectiveLines, canonicalizedIntersectionOf2PL :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Maybe (CPPoint2, (PLine2Err, PLine2Err, PPoint2Err)) -- | Actual implementation. -{-# INLINABLE canonicalizedIntersectionOfProjectiveLines #-} canonicalizedIntersectionOfProjectiveLines line1 line2 -- | Check whether the result of our intersection returns an ideal point. if it does, it means the two lines are (anti)parallel, and we should fail. | isIdealP pp1 = Nothing @@ -673,6 +673,7 @@ join2PP p1 p2 = joinOfProjectivePoints p1 p2 -- | Find a point along the line between the two given points. -- The position of the found point is determined by the ratio betwenn the two weights supplied. -- If the weights are equal, the distance will be right between the two points. +{-# INLINABLE projectivePointBetweenProjectivePoints #-} projectivePointBetweenProjectivePoints, interpolate2PP :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> ℝ -> ℝ -> (PPoint2, (PPoint2Err, PPoint2Err, PPoint2Err)) -- | Actual implementation. projectivePointBetweenProjectivePoints startPoint stopPoint weight1 weight2 From 66b98e5d45ba2c469759f30d1df943fa3b6deb62 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 18 Dec 2022 12:52:33 +0000 Subject: [PATCH 159/206] rename distancePPointToPLineWithErr to distancePPToPL, and add a lossy variant. --- Graphics/Slicer/Math/Intersections.hs | 4 ++-- Graphics/Slicer/Math/Lossy.hs | 14 +++++++++++--- Graphics/Slicer/Math/PGA.hs | 8 +++++--- Graphics/Slicer/Math/Skeleton/Line.hs | 10 +++++----- tests/Math/PGA.hs | 14 +++++++------- 5 files changed, 30 insertions(+), 20 deletions(-) diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index 26ee7f3c5..ecef5124f 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -44,7 +44,7 @@ import Graphics.Slicer.Math.Definitions (LineSeg, mapWithFollower) import Graphics.Slicer.Math.GeometricAlgebra (ulpVal) -import Graphics.Slicer.Math.PGA (Arcable(hasArc), CPPoint2, Intersection, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), PLine2Err, PPoint2Err, ProjectiveLine2, canonicalizedIntersectionOf2PL, distance2PL, distance2PP, distancePPointToPLineWithErr, eToPL, fuzzinessOfL, fuzzinessOfP, outAndErrOf, pLineErrAtPPoint, pLineIntersectsLineSeg, plinesIntersectIn) +import Graphics.Slicer.Math.PGA (Arcable(hasArc), CPPoint2, Intersection, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), PLine2Err, PPoint2Err, ProjectiveLine2, canonicalizedIntersectionOf2PL, distance2PL, distance2PP, distancePPToPL, eToPL, fuzzinessOfL, fuzzinessOfP, outAndErrOf, pLineErrAtPPoint, pLineIntersectsLineSeg, plinesIntersectIn) -- | Check if two lines cannot intersect. {-# INLINABLE noIntersection #-} @@ -164,7 +164,7 @@ intersectionsAtSamePoint nodeOutsAndErrs [] -> error "one line, no points.. makes no sense." ((a2,b2,ppoint1@(p1,_)):_) -> pointsCloseEnough && foundDistance < realToFrac errSum where - (foundDistance, (_, _, _, _, _, resErr)) = distancePPointToPLineWithErr ppoint1 l1 + (foundDistance, (_, _, _, _, _, resErr)) = distancePPToPL ppoint1 l1 errSum = ulpVal $ resErr <> fuzzinessOfP ppoint1 <> pLineErrAtPPoint a2 p1 diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index 07e9f2cfd..35713d00f 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -24,6 +24,7 @@ module Graphics.Slicer.Math.Lossy ( distanceBetweenPPointsWithErr, distanceBetweenPLines, distancePPointToPLine, + distancePPointToPLineWithErr, eToNPLine2, eToPLine2, getFirstArc, @@ -48,24 +49,31 @@ import Graphics.Slicer.Math.Definitions (LineSeg, Point2, makeLineSeg) import qualified Graphics.Slicer.Math.Arcs as Arcs (getFirstArc, getInsideArc) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PPoint2, PPoint2Err, ProjectiveLine2, ProjectivePoint2, canonicalizeP, distance2PP, distance2PL, distancePPointToPLineWithErr, eToPL, interpolate2PP, join2PP, normalizeL, pPointOnPerpWithErr, pToEP, translateL, translateRotatePPoint2WithErr) +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PLine2Err, PPoint2, PPoint2Err, ProjectiveLine2, ProjectivePoint2, canonicalizeP, distance2PP, distance2PL, distancePPToPL, eToPL, interpolate2PP, join2PP, normalizeL, pPointOnPerpWithErr, pToEP, translateL, translateRotatePPoint2WithErr) -- | canonicalize a euclidian point. canonicalizePPoint2 :: PPoint2 -> CPPoint2 canonicalizePPoint2 point = fst $ canonicalizeP point +-- | Find the distance between two projective points. distanceBetweenPPoints :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> ℝ distanceBetweenPPoints point1 point2 = fst $ distance2PP (point1, mempty) (point2, mempty) +-- | find the distance between two projective points, with error quotents attached. distanceBetweenPPointsWithErr :: (ProjectivePoint2 a, ProjectivePoint2 b) => (a, PPoint2Err) -> (b, PPoint2Err) -> ℝ distanceBetweenPPointsWithErr point1 point2 = fst $ distance2PP point1 point2 distanceBetweenPLines :: (ProjectiveLine2 a) => a -> a -> ℝ distanceBetweenPLines nPLine1 nPLine2 = fst $ distance2PL nPLine1 nPLine2 --- | Find the unsigned distance between a point and a line. +-- | Find the distance between a point and a line. distancePPointToPLine :: (ProjectivePoint2 a, ProjectiveLine2 b) => a -> b -> ℝ -distancePPointToPLine point line = fst $ distancePPointToPLineWithErr (point, mempty) (line, mempty) +distancePPointToPLine point line = fst $ distancePPToPL (point, mempty) (line, mempty) + +-- | Find the distance between a point and a line, both with error quotents. +distancePPointToPLineWithErr :: (ProjectivePoint2 a, ProjectiveLine2 b) => (a, PPoint2Err) -> (b, PLine2Err) -> ℝ +distancePPointToPLineWithErr point line = fst $ distancePPToPL point line + -- | Create a normalized projective line from a euclidian line segment. eToNPLine2 :: LineSeg -> NPLine2 diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 347dd711c..a33064a1b 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -53,7 +53,7 @@ module Graphics.Slicer.Math.PGA( angleBetween2PL, canonicalizedIntersectionOf2PL, combineConsecutiveLineSegs, - distancePPointToPLineWithErr, + distancePPToPL, distance2PP, distance2PL, eToPL, @@ -168,8 +168,8 @@ pLineIsLeft (pl1, _) (pl2, _) -- | Find the distance between a projective point and a projective line, along with the difference's error quotent. -- Note: Fails in the case of ideal points. -distancePPointToPLineWithErr :: (ProjectivePoint2 a, ProjectiveLine2 b) => (a, PPoint2Err) -> (b, PLine2Err) -> (ℝ, (PPoint2Err, PLine2Err, ([ErrVal],[ErrVal]), PLine2Err, PPoint2Err, UlpSum)) -distancePPointToPLineWithErr (inPoint, inPointErr) (inLine, inLineErr) +distanceProjectivePointToProjectiveLine, distancePPToPL :: (ProjectivePoint2 a, ProjectiveLine2 b) => (a, PPoint2Err) -> (b, PLine2Err) -> (ℝ, (PPoint2Err, PLine2Err, ([ErrVal],[ErrVal]), PLine2Err, PPoint2Err, UlpSum)) +distanceProjectivePointToProjectiveLine (inPoint, inPointErr) (inLine, inLineErr) | isIdealP inPoint = error "attempted to get the distance of an ideal point." | otherwise = (res, resErr) where @@ -187,6 +187,8 @@ distancePPointToPLineWithErr (inPoint, inPointErr) (inLine, inLineErr) pointErr = inPointErr <> cPointErr (nLine, nLineErr) = normalizeL inLine (cPoint, cPointErr) = canonicalizeP inPoint +-- FIXME: return result is a bit soupy. +distancePPToPL = distanceProjectivePointToProjectiveLine -- | Determine if two points are on the same side of a given line. -- Returns Nothing if one of the points is on the line. diff --git a/Graphics/Slicer/Math/Skeleton/Line.hs b/Graphics/Slicer/Math/Skeleton/Line.hs index 5cef1785b..ffbb930f0 100644 --- a/Graphics/Slicer/Math/Skeleton/Line.hs +++ b/Graphics/Slicer/Math/Skeleton/Line.hs @@ -42,9 +42,9 @@ import Graphics.Slicer.Math.Intersections (intersectionOf) import Graphics.Slicer.Math.Skeleton.Face (Face(Face)) -import Graphics.Slicer.Math.Lossy (eToNPLine2, eToPLine2, distancePPointToPLine, translatePLine2, pToEPoint2) +import Graphics.Slicer.Math.Lossy (eToNPLine2, eToPLine2, distancePPointToPLine, distancePPointToPLineWithErr, translatePLine2, pToEPoint2) -import Graphics.Slicer.Math.PGA (PLine2, distancePPointToPLineWithErr, eToPL, pLineIsLeft) +import Graphics.Slicer.Math.PGA (PLine2, eToPL, pLineIsLeft) import Graphics.Slicer.Machine.Infill (makeInfill, InfillType) @@ -106,7 +106,7 @@ addLineSegsToFace distance insets face@(Face edge firstArc midArcs@(Slist rawMid [] -> error "no remains for an nSideRemainder?" -- | Find the closest point where two of our arcs intersect, relative to our side. - arcIntersections = initSafe $ mapWithFollower (\a b -> (fst $ distancePPointToPLineWithErr (intersectionOf (a, mempty) (b, mempty)) (eToNPLine2 edge, mempty), (a, b))) $ [firstArc] <> rawMidArcs <> [lastArc] + arcIntersections = initSafe $ mapWithFollower (\a b -> (distancePPointToPLineWithErr (intersectionOf (a, mempty) (b, mempty)) (eToNPLine2 edge, mempty), (a, b))) $ [firstArc] <> rawMidArcs <> [lastArc] findClosestArc :: (ℝ, (PLine2, PLine2)) findClosestArc = case sortOn fst arcIntersections of [] -> error "empty arcIntersections?" @@ -140,13 +140,13 @@ addLineSegsToFace distance insets face@(Face edge firstArc midArcs@(Slist rawMid midArc = case midArcs of (Slist [oneArc] 1) -> oneArc (Slist _ _) -> error $ "evaluated midArc with the wrong insets of items\nd: " <> show distance <> "\nn: " <> show insets <> "\nFace: " <> show face <> "\n" - threeSideRemainder = if fst (distancePPointToPLineWithErr (intersectionOf (firstArc, mempty) (midArc, mempty)) (eToNPLine2 edge, mempty)) /= fst (distancePPointToPLineWithErr (intersectionOf (midArc, mempty) (lastArc, mempty)) (eToNPLine2 edge, mempty)) + threeSideRemainder = if distancePPointToPLineWithErr (intersectionOf (firstArc, mempty) (midArc, mempty)) (eToNPLine2 edge, mempty) /= distancePPointToPLineWithErr (intersectionOf (midArc, mempty) (lastArc, mempty)) (eToNPLine2 edge, mempty) then subRemains else Nothing (subSides, subRemains) = if firstArcLonger then addLineSegsToFace distance insets (Face finalSide firstArc (slist []) midArc) else addLineSegsToFace distance insets (Face finalSide midArc (slist []) lastArc) - firstArcLonger = fst (distancePPointToPLineWithErr (intersectionOf (firstArc, mempty) (midArc, mempty)) (eToNPLine2 edge, mempty)) > fst (distancePPointToPLineWithErr (intersectionOf (midArc,mempty) (lastArc, mempty)) (eToNPLine2 edge, mempty)) + firstArcLonger = distancePPointToPLineWithErr (intersectionOf (firstArc, mempty) (midArc, mempty)) (eToNPLine2 edge, mempty) > distancePPointToPLineWithErr (intersectionOf (midArc,mempty) (lastArc, mempty)) (eToNPLine2 edge, mempty) ---------------------------------------------- -- functions only used by a three-sided n-gon. ---------------------------------------------- diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index 1dc992a3f..93908b3f9 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -64,7 +64,7 @@ import Graphics.Slicer.Math.Intersections (outputIntersectsLineSeg) import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenPLines, distancePPointToPLine, eToPLine2, getFirstArc, join2PPoint2, normalizePLine2, pPointOnPerp) -- Our 2D Projective Geometric Algebra library. -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PLine2Err(PLine2Err), canonicalizeP, distance2PP, distancePPointToPLineWithErr, eToPL, eToPP, eToPP, interpolate2PP, intersect2PL, translateL, translateRotatePPoint2WithErr, angleBetween2PL, flipL, join2PP, makePPoint2, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, distancePPointToPLineWithErr, errOfOut, pPointOnPerpWithErr, outOf, pPointOf) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PLine2Err(PLine2Err), canonicalizeP, distance2PP, distancePPToPL, eToPL, eToPP, eToPP, interpolate2PP, intersect2PL, translateL, translateRotatePPoint2WithErr, angleBetween2PL, flipL, join2PP, makePPoint2, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, errOfOut, pPointOnPerpWithErr, outOf, pPointOf) -- The primitives of our PGA only library, and error estimation code. @@ -1244,8 +1244,8 @@ prop_PLineWithinErrRange1 x1 y1 rawX2 rawY2 <> "PPoint1: " <> show pPoint1 <> "\n" <> "PPoint2: " <> show pPoint2 <> "\n" -- distance1 and distance2 should be 0, in an ideal world. - (distance1, (_,_,_,_,_,UlpSum distance1Err)) = distancePPointToPLineWithErr (pPoint1, mempty) (nPLine, nPLineErr) - (distance2, (_,_,_,_,_,UlpSum distance2Err)) = distancePPointToPLineWithErr (pPoint2, mempty) (nPLine, nPLineErr) + (distance1, (_,_,_,_,_,UlpSum distance1Err)) = distancePPToPL (pPoint1, mempty) (nPLine, nPLineErr) + (distance2, (_,_,_,_,_,UlpSum distance2Err)) = distancePPToPL (pPoint2, mempty) (nPLine, nPLineErr) pPoint1 = makePPoint2 x1 y1 pPoint2 = makePPoint2 x2 y2 (nPLine, nPLineErr) = normalizeL pLine @@ -1278,8 +1278,8 @@ prop_PLineWithinErrRange2 x1 y1 rawX2 rawY2 <> "xIntercept(PLine1): " <> show (xIntercept (pLine1,pLine1Err)) <> "\n" <> "yIntercept(PLine1): " <> show (yIntercept (pLine1,pLine1Err)) <> "\n" -- distance1 and distance2 should be 0, in an ideal world. - (distance1, (_,_,_,_,_,distance1Err)) = distancePPointToPLineWithErr (pPoint1, mempty) (pLine1, pLine1Err) - (distance2, (_,_,_,_,_,distance2Err)) = distancePPointToPLineWithErr (pPoint2, mempty) (pLine1, pLine1Err) + (distance1, (_,_,_,_,_,distance1Err)) = distancePPToPL (pPoint1, mempty) (pLine1, pLine1Err) + (distance2, (_,_,_,_,_,distance2Err)) = distancePPToPL (pPoint2, mempty) (pLine1, pLine1Err) pPoint1 = makePPoint2 x1 y1 pPoint2 = makePPoint2 x2 y2 (pLine1, (_,_,pLine1Err)) = join2PP pPoint1 pPoint2 @@ -1307,8 +1307,8 @@ prop_PPointOnPerpWithinErrRange x1 y1 rawX2 rawY2 rawD <> "ulpTotal1: " <> show ulpTotal1 <> "\n" <> "ulpTotal2: " <> show ulpTotal2 <> "\n" -- res should be d, in an ideal world. - (res1,(_,_,_,_,_, UlpSum res1Err)) = distancePPointToPLineWithErr (perp1, mempty) (pLine, mempty) - (res2,(_,_,_,_,_, UlpSum res2Err)) = distancePPointToPLineWithErr (perp2, mempty) (pLine, mempty) + (res1,(_,_,_,_,_, UlpSum res1Err)) = distancePPToPL (perp1, mempty) (pLine, mempty) + (res2,(_,_,_,_,_, UlpSum res2Err)) = distancePPToPL (perp2, mempty) (pLine, mempty) (perp1, (_,_,_, UlpSum ulpSumPerp1)) = pPointOnPerpWithErr pLine pPoint1 d (perp2, (_,_,_, UlpSum ulpSumPerp2)) = pPointOnPerpWithErr pLine pPoint2 d pPoint1 = makePPoint2 x1 y1 From 20104ea5bf21d2f66b7323cc8c8a2ededb1c40eb Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 18 Dec 2022 16:15:14 +0000 Subject: [PATCH 160/206] split averageNodes into averageNodes and safeAverageNodes. --- Graphics/Slicer/Math/ContourIntersections.hs | 1 + Graphics/Slicer/Math/Lossy.hs | 2 +- Graphics/Slicer/Math/PGA.hs | 2 +- Graphics/Slicer/Math/Skeleton/Concave.hs | 53 +++++++++++--------- Graphics/Slicer/Math/Skeleton/Definitions.hs | 6 ++- 5 files changed, 36 insertions(+), 28 deletions(-) diff --git a/Graphics/Slicer/Math/ContourIntersections.hs b/Graphics/Slicer/Math/ContourIntersections.hs index 0310fa653..133b54e2c 100644 --- a/Graphics/Slicer/Math/ContourIntersections.hs +++ b/Graphics/Slicer/Math/ContourIntersections.hs @@ -60,6 +60,7 @@ contourIntersectionCount contour (start, end) = len $ getIntersections contour ( openCircuit v = Just <$> v -- | Get the intersections between a Line and a contour as a series of points. always returns an even number of intersections. +{-# INLINABLE getLineContourIntersections #-} getLineContourIntersections :: (ProjectiveLine2 a) => (a, PLine2Err) -> Contour -> [Point2] getLineContourIntersections (line, lineErr) c | odd $ length res = error $ "odd number of transitions: " <> show (length res) <> "\n" <> show c <> "\n" <> show line <> "\n" <> show res <> "\n" diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index 35713d00f..5f026a566 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -59,7 +59,7 @@ canonicalizePPoint2 point = fst $ canonicalizeP point distanceBetweenPPoints :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> ℝ distanceBetweenPPoints point1 point2 = fst $ distance2PP (point1, mempty) (point2, mempty) --- | find the distance between two projective points, with error quotents attached. +-- | Find the distance between two projective points, with attached error quotents. distanceBetweenPPointsWithErr :: (ProjectivePoint2 a, ProjectivePoint2 b) => (a, PPoint2Err) -> (b, PPoint2Err) -> ℝ distanceBetweenPPointsWithErr point1 point2 = fst $ distance2PP point1 point2 diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index a33064a1b..3f822316c 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -54,8 +54,8 @@ module Graphics.Slicer.Math.PGA( canonicalizedIntersectionOf2PL, combineConsecutiveLineSegs, distancePPToPL, - distance2PP, distance2PL, + distance2PP, eToPL, eToPP, flipL, diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index b86ee19bf..6981fb7fa 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -58,7 +58,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum)) import Graphics.Slicer.Math.Intersections (intersectionOf, intersectionsAtSamePoint, isAntiCollinear, isAntiParallel, isCollinear, isParallel, noIntersection) -import Graphics.Slicer.Math.PGA (Arcable(errOfOut, hasArc, outOf), Pointable(canPoint, pPointOf), PLine2, PLine2Err, distance2PP, eToPL, flipL, outAndErrOf, pLineIsLeft) +import Graphics.Slicer.Math.PGA (Arcable(errOfOut, hasArc, outOf), Pointable(canPoint, pPointOf), PLine2, PLine2Err, distance2PP, eToPL, flipL, outAndErrOf, pPointAndErrOf, pLineIsLeft) import Graphics.Slicer.Math.Skeleton.Definitions (ENode(ENode), ENodeSet(ENodeSet), INode(INode), INodeSet(INodeSet), NodeTree(NodeTree), concavePLines, getFirstLineSeg, getLastLineSeg, finalOutOf, firstInOf, getPairs, indexPLinesTo, insOf, lastINodeOf, linePairs, makeINode, sortedPLinesWithErr, isLoop) @@ -166,25 +166,7 @@ errorIfLeft (Right val) = val -- | For a given pair of nodes, construct a new internal node, where it's parents are the given nodes, and the line leaving it is along the the obtuse bisector. -- Note: this should be hidden in skeletonOfConcaveRegion, but it's exposed here, for testing. averageNodes :: (Arcable a, Pointable a, Arcable b, Pointable b) => a -> b -> INode -averageNodes n1 n2 - | not (hasArc n1) || not (hasArc n2) = error $ "Cannot get the average of nodes if one of the nodes does not have an out!\n" <> dumpInput - | not (canPoint n1) || not (canPoint n2) = error $ "Cannot get the average of nodes if we cannot resolve them to a point!\n" <> dumpInput - | isParallel (outAndErrOf n1) (outAndErrOf n2) = error $ "Cannot get the average of nodes if their outputs never intersect!\n" <> dumpInput - | isAntiParallel (outAndErrOf n1) (outAndErrOf n2) = error $ "Cannot get the average of nodes if their outputs never intersect!\n" <> dumpInput - | isCollinear (outAndErrOf n1) (outAndErrOf n2) = error $ "Cannot (yet) handle two input plines that are collinear.\n" <> dumpInput - | nodesAreAntiCollinear n1 n2 = error $ "Cannot (yet) handle two input plines that are collinear.\n" <> dumpInput - | n1Distance < getRounded n1Err = error $ "intersection is AT the point of n1!\n" <> dumpInput - | n2Distance < getRounded n2Err = error $ "intersection is AT the point of n2!\n" <> dumpInput - | otherwise = makeINode (sortedPair n1 n2) $ Just $ getOutsideArc (pPointOf n1, mempty) (outAndErrOf n1) (pPointOf n2, mempty) (outAndErrOf n2) - where - (n1Distance, (_,_, UlpSum n1Err)) = distance2PP (intersectionOf (outAndErrOf n1) (outAndErrOf n2)) (pPointOf n1, mempty) - (n2Distance, (_,_, UlpSum n2Err)) = distance2PP (intersectionOf (outAndErrOf n1) (outAndErrOf n2)) (pPointOf n2, mempty) - dumpInput = "Node1: " <> show n1 - <> "\nNode2: " <> show n2 - <> "\nNode1Out: " <> show (outOf n1) - <> "\nNode2Out: "<> show (outOf n2) - <> "\nNode1PPoint: " <> show (pPointOf n1) - <> "\nNode2PPoint: " <> show (pPointOf n2) <> "\n" +averageNodes n1 n2 = makeINode (sortedPair n1 n2) $ Just $ getOutsideArc (pPointAndErrOf n1) (outAndErrOf n1) (pPointAndErrOf n2) (outAndErrOf n2) -- | Take a pair of arcables, and return their outOfs, in a sorted order. sortedPair :: (Arcable a, Arcable b) => a -> b -> [(PLine2, PLine2Err)] @@ -607,15 +589,15 @@ skeletonOfNodes connectedLoop inSegSets iNodes = $ "shortestPairDistance: " <> show shortestPairDistance <> "\n" <> "ePairDistance: " <> show shortestEPairDistance <> "\n" <> "shortestEPairs: " <> show (shortestPairs eNodes) <> "\n" - <> "ePairResults: " <> show (uncurry averageNodes <$> shortestPairs eNodes) <> "\n" + <> "ePairResults: " <> show (uncurry safeAverageNodes <$> shortestPairs eNodes) <> "\n" <> show (isSomething shortestEPairDistance) <> "\n" <> "iPairDistance: " <> show shortestIPairDistance <> "\n" <> "shortestIPairs: " <> show (shortestPairs iNodes) <> "\n" - <> "iPairResults: " <> show (uncurry averageNodes <$> shortestPairs iNodes) <> "\n" + <> "iPairResults: " <> show (uncurry safeAverageNodes <$> shortestPairs iNodes) <> "\n" <> show (isSomething shortestIPairDistance) <> "\n" <> "mixedPairDistance: " <> show shortestMixedPairDistance <> "\n" <> "shortestMixedPairs: " <> show shortestMixedPairs <> "\n" - <> "MixedPairResults: " <> show (uncurry averageNodes <$> shortestMixedPairs) <> "\n" + <> "MixedPairResults: " <> show (uncurry safeAverageNodes <$> shortestMixedPairs) <> "\n" <> show (isSomething shortestMixedPairDistance) <> "\n" <> show (shortestEPairDistance == shortestPairDistance) <> "\n" <> "remainingLineSegs: " <> show remainingLineSegs <> "\n" @@ -696,7 +678,7 @@ skeletonOfNodes connectedLoop inSegSets iNodes = -- | collect our set of result nodes. -- Note: we're putting these in the order "most likely to contain INodes" to least likely. to make the optimizer easier to write. averageOfShortestPairs :: [INode] - averageOfShortestPairs = (uncurry averageNodes <$> iPairsFound) <> (uncurry averageNodes <$> mixedPairsFound) <> (uncurry averageNodes <$> ePairsFound) + averageOfShortestPairs = (uncurry safeAverageNodes <$> iPairsFound) <> (uncurry safeAverageNodes <$> mixedPairsFound) <> (uncurry safeAverageNodes <$> ePairsFound) iPairsFound = if isSomething shortestIPairDistance && shortestIPairDistance == shortestPairDistance @@ -749,6 +731,29 @@ skeletonOfNodes connectedLoop inSegSets iNodes = [a] -> [a] (x@(node1, node2) :xs) -> x : filterCommonIns (filter (\(myNode1, myNode2) -> node1 /= myNode1 && node2 /= myNode1 && node1 /= myNode2 && node2 /= myNode2) xs) + safeAverageNodes n1 n2 + | not (hasArc n1) || not (hasArc n2) = error $ "Cannot get the average of nodes if one of the nodes does not have an out!\n" <> dumpInput + | not (canPoint n1) || not (canPoint n2) = error $ "Cannot get the average of nodes if we cannot resolve them to a point!\n" <> dumpInput + | isParallel (outAndErrOf n1) (outAndErrOf n2) = error $ "Cannot get the average of nodes if their outputs never intersect!\n" <> dumpInput + | isAntiParallel (outAndErrOf n1) (outAndErrOf n2) = error $ "Cannot get the average of nodes if their outputs never intersect!\n" <> dumpInput + | isCollinear (outAndErrOf n1) (outAndErrOf n2) = error $ "Cannot (yet) handle two input plines that are collinear.\n" <> dumpInput + | nodesAreAntiCollinear n1 n2 = error $ "Cannot (yet) handle two input plines that are collinear.\n" <> dumpInput + | n1Distance < getRounded n1Err = error $ "intersection is AT the point of n1!\n" <> dumpInput + | n2Distance < getRounded n2Err = error $ "intersection is AT the point of n2!\n" <> dumpInput + | n1Distance > getRounded n1Err && n2Distance > getRounded n2Err = averageNodes n1 n2 + | otherwise = error $ "found node too close:\n" + <> show n1 <> "\n" + <> show n2 <> "\n" + where + (n1Distance, (_,_, UlpSum n1Err)) = distance2PP (intersectionOf (outAndErrOf n1) (outAndErrOf n2)) (pPointOf n1, mempty) + (n2Distance, (_,_, UlpSum n2Err)) = distance2PP (intersectionOf (outAndErrOf n1) (outAndErrOf n2)) (pPointOf n2, mempty) + dumpInput = "Node1: " <> show n1 + <> "\nNode2: " <> show n2 + <> "\nNode1Out: " <> show (outOf n1) + <> "\nNode2Out: "<> show (outOf n2) + <> "\nNode1PPoint: " <> show (pPointOf n1) + <> "\nNode2PPoint: " <> show (pPointOf n2) <> "\n" + -- | get the list of sorted pairs of intersecting nodes. shortestNeighboringPairs :: (Arcable a, Pointable a, Eq a) => [(a,a)] -> [(a, a)] shortestNeighboringPairs myNodePairs = case nodePairsSortedByDistance myNodePairs of diff --git a/Graphics/Slicer/Math/Skeleton/Definitions.hs b/Graphics/Slicer/Math/Skeleton/Definitions.hs index 064f693ad..eadd78c16 100644 --- a/Graphics/Slicer/Math/Skeleton/Definitions.hs +++ b/Graphics/Slicer/Math/Skeleton/Definitions.hs @@ -122,6 +122,7 @@ instance Pointable INode where canPoint iNode = len (allPLinesOfINode iNode) > 1 && hasIntersectingPairs (allPLinesOfINode iNode) where hasIntersectingPairs (Slist pLines _) = any (\(pl1, pl2) -> not $ noIntersection pl1 pl2) $ getPairs pLines + errOfPPoint _ = mempty -- FIXME: if we have multiple intersecting pairs, is there a preferred pair to use for resolving? angle based, etc? pPointOf iNode | allPointsSame = case results of @@ -176,14 +177,15 @@ instance Eq Motorcycle where instance Arcable Motorcycle where -- A Motorcycle always has an arc, which is it's path. hasArc _ = True - outOf (Motorcycle _ outArc _) = outArc errOfOut (Motorcycle _ _ outErr) = outErr + outOf (Motorcycle _ outArc _) = outArc instance Pointable Motorcycle where -- A motorcycle always contains a point. canPoint _ = True - pPointOf a = (\(CPPoint2 v) -> PPoint2 v) $ eToPP $ ePointOf a ePointOf (Motorcycle (_, LineSeg point _) _ _) = point + errOfPPoint _ = mempty + pPointOf a = (\(CPPoint2 v) -> PPoint2 v) $ eToPP $ ePointOf a -- | The motorcycles that are involved in dividing two cells. data DividingMotorcycles = DividingMotorcycles { firstMotorcycle :: !Motorcycle, moreMotorcycles :: !(Slist Motorcycle) } From 0e755f7aa460d6837a4ae542cd7aad2c667d2beb Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 18 Dec 2022 22:56:15 +0000 Subject: [PATCH 161/206] pass the original segment set through skepetonOfNodes, so we can generate errors, and have the whole set to dump. --- Graphics/Slicer/Math/Lossy.hs | 4 ++-- Graphics/Slicer/Math/PGA.hs | 4 ++-- Graphics/Slicer/Math/Skeleton/Cells.hs | 4 +--- Graphics/Slicer/Math/Skeleton/Concave.hs | 8 ++++---- 4 files changed, 9 insertions(+), 11 deletions(-) diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index 5f026a566..3957889a5 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -87,7 +87,7 @@ eToPLine2 l1 = fst $ eToPL l1 getFirstArc :: Point2 -> Point2 -> Point2 -> PLine2 getFirstArc p1 p2 p3 = fst $ Arcs.getFirstArc p1 p2 p3 -getInsideArc :: PLine2 -> PLine2 -> PLine2 +getInsideArc :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> PLine2 getInsideArc pl1 pl2 = fst $ Arcs.getInsideArc (pl1, mempty) (pl2, mempty) -- | a typed join function. join two points, returning a line. @@ -119,7 +119,7 @@ pPointOnPerp :: (ProjectiveLine2 a, ProjectivePoint2 b) => a -> b -> ℝ -> PPoi pPointOnPerp pline ppoint d = fst $ pPointOnPerpWithErr pline ppoint d -- | translate a PLine2 along it's perpendicular bisector. -translatePLine2 :: PLine2 -> ℝ -> PLine2 +translatePLine2 :: (ProjectiveLine2 a) => a -> ℝ -> PLine2 translatePLine2 pline distance = fst $ translateL pline distance -- | Translate a point a given distance away from where it is, rotating it a given amount clockwise (in radians) around it's original location, with 0 degrees being aligned to the X axis. diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 3f822316c..eb3668865 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -68,14 +68,14 @@ module Graphics.Slicer.Math.PGA( join2PP, makePPoint2, outAndErrOf, + pLineErrAtPPoint, pLineIntersectsLineSeg, pLineIsLeft, + plinesIntersectIn, pPointAndErrOf, pPointOnPerpWithErr, pPointsOnSameSideOfPLine, pToEP, - pLineErrAtPPoint, - plinesIntersectIn, translateL, translateRotatePPoint2WithErr, vecOfP diff --git a/Graphics/Slicer/Math/Skeleton/Cells.hs b/Graphics/Slicer/Math/Skeleton/Cells.hs index e2d51468f..487fc4a07 100644 --- a/Graphics/Slicer/Math/Skeleton/Cells.hs +++ b/Graphics/Slicer/Math/Skeleton/Cells.hs @@ -58,9 +58,7 @@ import Graphics.Slicer.Math.Intersections (intersectionBetweenArcsOf, isAntiColl import Graphics.Slicer.Math.Lossy (distanceBetweenPPoints, distanceBetweenPPointsWithErr, eToPLine2, pToEPoint2) -import Graphics.Slicer.Math.PGA (Arcable(outOf), CPPoint2, Pointable(canPoint, ePointOf, pPointOf), angleBetween2PL, distance2PP, eToPL, eToPP, outAndErrOf, pPointAndErrOf) - -import Graphics.Slicer.Math.PGAPrimitives (join2PP) +import Graphics.Slicer.Math.PGA (Arcable(outOf), CPPoint2, Pointable(canPoint, ePointOf, pPointOf), angleBetween2PL, distance2PP, eToPL, eToPP, join2PP, outAndErrOf, pPointAndErrOf) data UnsupportedReason = INodeCrossesDivide ![(INode,CellDivide)] !NodeTree deriving (Show, Eq) diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index 6981fb7fa..720528470 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -101,7 +101,7 @@ findINodes inSegSets | len inSegSets == 1 = -- One continuous wall without gaps. may gap between the beginning and end of the contour, if this is not a loop. -- Just return the output of skeletonOfNodes. - errorIfLeft $ skeletonOfNodes (isLoop inSegSets) inSegSets [] + errorIfLeft $ skeletonOfNodes (isLoop inSegSets) inSegSets inSegSets [] | len inSegSets == 2 = -- Two walls, no closed ends. solve the ends of a hallway region, so we can then hand off the solutioning to our regular process. case initialENodes of @@ -531,8 +531,8 @@ sortINodesByENodes loop inSegSets inGens@(INodeSet rawGenerations) -- | Apply a recursive algorithm to obtain a raw INode set. -- FIXME: does not handle more than two point intersections of arcs properly. -skeletonOfNodes :: Bool -> Slist [LineSeg] -> [INode] -> Either PartialNodes INodeSet -skeletonOfNodes connectedLoop inSegSets iNodes = +skeletonOfNodes :: Bool -> Slist [LineSeg] -> Slist [LineSeg] -> [INode] -> Either PartialNodes INodeSet +skeletonOfNodes connectedLoop origSegSets inSegSets iNodes = case eNodes of [] -> case iNodes of [] -> -- zero nodes == return emptyset. allows us to simplify our return loop. @@ -581,7 +581,7 @@ skeletonOfNodes connectedLoop inSegSets iNodes = | endsAtSamePoint && contourLooped = Right $ INodeSet $ one [makeINode (sortedPLinesWithErr $ (outAndErrOf <$> eNodes) <> (outAndErrOf <$> iNodes)) Nothing] -- FIXME: this can happen for non-loops. which means this Nothing is wrong. it should be the result of the intersection tree from the first and last node in the segment. | endsAtSamePoint && not contourLooped = error $ show $ INodeSet $ one [makeINode (sortedPLinesWithErr $ (outAndErrOf <$> eNodes) <> (outAndErrOf <$> iNodes)) Nothing] - | hasShortestNeighboringPair = Right $ INodeSet $ averageOfShortestPairs `cons` inodesOf (errorIfLeft (skeletonOfNodes remainingLoop remainingLineSegs (remainingINodes <> averageOfShortestPairs))) + | hasShortestNeighboringPair = Right $ INodeSet $ averageOfShortestPairs `cons` inodesOf (errorIfLeft (skeletonOfNodes remainingLoop origSegSets remainingLineSegs (remainingINodes <> averageOfShortestPairs))) | otherwise = errorLen3 where inodesOf (INodeSet set) = set From 2e07211e521fb451ca587f9ba0cad6c854d1b5c0 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Mon, 19 Dec 2022 00:08:16 +0000 Subject: [PATCH 162/206] use safeAverageNodes more, and change errorLen3 into being a string. --- Graphics/Slicer/Math/Skeleton/Concave.hs | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index 720528470..47dce1a36 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -28,7 +28,7 @@ module Graphics.Slicer.Math.Skeleton.Concave (skeletonOfConcaveRegion, findINodes, makeENode, makeENodes, averageNodes, eNodesOfOutsideContour) where -import Prelude (Eq, Show, Bool(True, False), Either(Left, Right), String, Ord, Ordering(GT,LT), notElem, otherwise, ($), (>), (<), (<$>), (==), (/=), (>=), error, (&&), fst, (<>), show, not, max, compare, uncurry, null, (||), min, snd, filter, zip, any, (*), (+), Int, (.), (-), concatMap, mempty, realToFrac) +import Prelude (Eq, Show, Bool(True, False), Either(Left, Right), String, Ord, Ordering(GT,LT), all, notElem, otherwise, ($), (>), (<), (<$>), (==), (/=), (>=), error, (&&), fst, (<>), show, not, max, compare, uncurry, null, (||), min, snd, filter, zip, any, (*), (+), Int, (.), (-), concatMap, mempty, realToFrac) import Prelude as PL (head, last, tail, init) @@ -421,7 +421,7 @@ sortINodesByENodes loop inSegSets inGens@(INodeSet rawGenerations) -- check to see if an INode can be merged with another INode. canMergeWith :: INode -> INode -> Bool - canMergeWith inode1@(INode _ _ _ maybeOut) inode2 = isJust maybeOut && hasIn inode2 (outAndErrOf inode1) + canMergeWith inode1 inode2 = hasArc inode1 && hasIn inode2 (outAndErrOf inode1) where hasIn :: INode -> (PLine2, PLine2Err) -> Bool hasIn iNode pLine2 = case filter (\a -> isCollinear a pLine2) $ insOf iNode of @@ -571,22 +571,21 @@ skeletonOfNodes connectedLoop origSegSets inSegSets iNodes = | contourLooped = -- this is a complete loop, so this last INode will be re-written in sortINodesByENodes anyways. Right $ INodeSet $ one [makeINode (sortedPLinesWithErr [outAndErrOf node1,outAndErrOf node2]) Nothing] - | intersectsInPoint node1 node2 = Right $ INodeSet $ one [averageNodes node1 node2] + | intersectsInPoint node1 node2 = Right $ INodeSet $ one [safeAverageNodes node1 node2] | otherwise = errorLen2 where errorLen2 = Left $ PartialNodes (INodeSet $ one iNodes) $ "NOMATCH - length 2?\n" <> show node1 <> "\n" <> show node2 <> "\n" <> show contourLooped <> "\n" <> show eNodes <> "\n" <> show iNodes <> "\n" - -- Handle the the case of 3 or more nodes. handleThreeOrMoreNodes + | not (all hasArc iNodes) = error "found an Inode without an output!" | endsAtSamePoint && contourLooped = Right $ INodeSet $ one [makeINode (sortedPLinesWithErr $ (outAndErrOf <$> eNodes) <> (outAndErrOf <$> iNodes)) Nothing] -- FIXME: this can happen for non-loops. which means this Nothing is wrong. it should be the result of the intersection tree from the first and last node in the segment. | endsAtSamePoint && not contourLooped = error $ show $ INodeSet $ one [makeINode (sortedPLinesWithErr $ (outAndErrOf <$> eNodes) <> (outAndErrOf <$> iNodes)) Nothing] | hasShortestNeighboringPair = Right $ INodeSet $ averageOfShortestPairs `cons` inodesOf (errorIfLeft (skeletonOfNodes remainingLoop origSegSets remainingLineSegs (remainingINodes <> averageOfShortestPairs))) - | otherwise = errorLen3 + | otherwise = error $ "len3\n" <> errorLen3 where inodesOf (INodeSet set) = set - errorLen3 = error - $ "shortestPairDistance: " <> show shortestPairDistance <> "\n" + errorLen3 = "shortestPairDistance: " <> show shortestPairDistance <> "\n" <> "ePairDistance: " <> show shortestEPairDistance <> "\n" <> "shortestEPairs: " <> show (shortestPairs eNodes) <> "\n" <> "ePairResults: " <> show (uncurry safeAverageNodes <$> shortestPairs eNodes) <> "\n" @@ -603,14 +602,17 @@ skeletonOfNodes connectedLoop origSegSets inSegSets iNodes = <> "remainingLineSegs: " <> show remainingLineSegs <> "\n" <> "remainingINodes: " <> show remainingINodes <> "\n" <> "thisGen: " <> show averageOfShortestPairs <> "\n" + <> "origSegSets: " <> show origSegSets <> "\n" - -- | When all of our nodes end in the same point we should create a single Node with all of them as input. This checks for that case. + -- | check to see if all of our nodes end in the same point + -- If so, this is a sign that we should create a single Node with all of them as input. endsAtSamePoint :: Bool endsAtSamePoint = intersectionsAtSamePoint nodeOutsAndErrs where nodeOutsAndErrs = nonAntiCollinearOutErrPairs allOuts (antiCollinearOutErrPairsOf allOuts) <> firstofAntiCollinearOutErrPairs (antiCollinearOutErrPairsOf allOuts) - allOuts = (outAndErrOf <$> eNodes) <> (outAndErrOf <$> iNodes) + where + allOuts = (outAndErrOf <$> eNodes) <> (outAndErrOf <$> iNodes) -- since anti-collinear nodes end at the same point, only count one of them. firstofAntiCollinearOutErrPairs nodePairs = fst <$> nodePairs -- filter out collinear pairs. eliminates both ends. From 8b188378c9f79d450b61d5ace2f52a34d02158b2 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Mon, 19 Dec 2022 01:06:48 +0000 Subject: [PATCH 163/206] use errorLen3 in safeAverageNodes, and use filter and uncurry instead of constructing them. --- Graphics/Slicer/Math/Skeleton/Concave.hs | 52 ++++++++++++------------ 1 file changed, 25 insertions(+), 27 deletions(-) diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index 47dce1a36..d5174adb7 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -58,7 +58,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum)) import Graphics.Slicer.Math.Intersections (intersectionOf, intersectionsAtSamePoint, isAntiCollinear, isAntiParallel, isCollinear, isParallel, noIntersection) -import Graphics.Slicer.Math.PGA (Arcable(errOfOut, hasArc, outOf), Pointable(canPoint, pPointOf), PLine2, PLine2Err, distance2PP, eToPL, flipL, outAndErrOf, pPointAndErrOf, pLineIsLeft) +import Graphics.Slicer.Math.PGA (Arcable(errOfOut, hasArc, outOf), Pointable(canPoint, pPointOf), PLine2, PLine2Err, ProjectiveLine2, distance2PP, eToPL, flipL, outAndErrOf, pPointAndErrOf, pLineIsLeft) import Graphics.Slicer.Math.Skeleton.Definitions (ENode(ENode), ENodeSet(ENodeSet), INode(INode), INodeSet(INodeSet), NodeTree(NodeTree), concavePLines, getFirstLineSeg, getLastLineSeg, finalOutOf, firstInOf, getPairs, indexPLinesTo, insOf, lastINodeOf, linePairs, makeINode, sortedPLinesWithErr, isLoop) @@ -622,6 +622,7 @@ skeletonOfNodes connectedLoop origSegSets inSegSets iNodes = where allAntiCollinearNodes myNodePairs = (fst <$> myNodePairs) <> (snd <$> myNodePairs) -- Find our anti-collinear pairs. + antiCollinearOutErrPairsOf :: (ProjectiveLine2 a) => [(a, PLine2Err)] -> [((a, PLine2Err),(a, PLine2Err))] antiCollinearOutErrPairsOf inOutErrPairs = filter (uncurry isAntiCollinear) $ getPairs inOutErrPairs -- | make sure we have a potential intersection between two nodes to work with. @@ -648,11 +649,10 @@ skeletonOfNodes connectedLoop origSegSets inSegSets iNodes = where removeENodesFromSegList :: Slist ENode -> [LineSeg] -> [[LineSeg]] removeENodesFromSegList eNodesIn lineSegs = - filterTooShorts $ case eNodesIn of - (Slist [] _) -> [lineSegs] - (Slist (oneENode:moreENodes) _) -> concatMap (removeENodeFromSegList oneENode) $ removeENodesFromSegList (slist moreENodes) lineSegs + mapMaybe isTooShort $ case eNodesIn of + (Slist [] _) -> [lineSegs] + (Slist (oneENode:moreENodes) _) -> concatMap (removeENodeFromSegList oneENode) $ removeENodesFromSegList (slist moreENodes) lineSegs where - filterTooShorts sets = mapMaybe isTooShort sets isTooShort set = case set of [] -> Nothing [val] -> Just [val] @@ -689,13 +689,14 @@ skeletonOfNodes connectedLoop origSegSets inSegSets iNodes = mixedPairsFound = if isSomething shortestMixedPairDistance && shortestMixedPairDistance == shortestPairDistance - then filterINodesOf shortestMixedPairs + then shortestINodesOf shortestMixedPairs else [] where -- | remove pairs containing INodes from the shortest INode pairs from a list of mixed pairs. - filterINodesOf :: [(ENode, INode)] -> [(ENode, INode)] - filterINodesOf = filter (\(_,myINode) -> myINode `notElem` ((fst <$> iPairsFound) <> (snd <$> iPairsFound))) - + shortestINodesOf :: [(ENode, INode)] -> [(ENode, INode)] + shortestINodesOf = filter onlyShortestPairs + where + onlyShortestPairs (_,myINode) = myINode `notElem` ((fst <$> iPairsFound) <> (snd <$> iPairsFound)) ePairsFound = if isSomething shortestEPairDistance && shortestEPairDistance == shortestPairDistance then filterENodesOf $ shortestNeighboringPairs $ mapWithFollower (,) eNodes @@ -721,7 +722,7 @@ skeletonOfNodes connectedLoop origSegSets inSegSets iNodes = shortestPairs :: (Arcable a, Pointable a, Eq a) => [a] -> [(a, a)] shortestPairs myNodes = case nodePairsSortedByDistance myNodes of [] -> [] - [onePair] -> [onePair] + [(node1, node2)] -> [(node1, node2)] (pair:morePairs) -> filterCommonIns $ pair : takeWhile (\a -> uncurry distanceToIntersection a == uncurry distanceToIntersection pair) morePairs where -- | get the intersection of each node pair, sorted based on which one has the shortest maximum distance of the two line segments from it's ancestor nodes to the intersection point. @@ -733,15 +734,16 @@ skeletonOfNodes connectedLoop origSegSets inSegSets iNodes = [a] -> [a] (x@(node1, node2) :xs) -> x : filterCommonIns (filter (\(myNode1, myNode2) -> node1 /= myNode1 && node2 /= myNode1 && node1 /= myNode2 && node2 /= myNode2) xs) + safeAverageNodes :: (Arcable a, Pointable a, Arcable b, Pointable b) => a -> b -> INode safeAverageNodes n1 n2 - | not (hasArc n1) || not (hasArc n2) = error $ "Cannot get the average of nodes if one of the nodes does not have an out!\n" <> dumpInput - | not (canPoint n1) || not (canPoint n2) = error $ "Cannot get the average of nodes if we cannot resolve them to a point!\n" <> dumpInput - | isParallel (outAndErrOf n1) (outAndErrOf n2) = error $ "Cannot get the average of nodes if their outputs never intersect!\n" <> dumpInput - | isAntiParallel (outAndErrOf n1) (outAndErrOf n2) = error $ "Cannot get the average of nodes if their outputs never intersect!\n" <> dumpInput - | isCollinear (outAndErrOf n1) (outAndErrOf n2) = error $ "Cannot (yet) handle two input plines that are collinear.\n" <> dumpInput - | nodesAreAntiCollinear n1 n2 = error $ "Cannot (yet) handle two input plines that are collinear.\n" <> dumpInput - | n1Distance < getRounded n1Err = error $ "intersection is AT the point of n1!\n" <> dumpInput - | n2Distance < getRounded n2Err = error $ "intersection is AT the point of n2!\n" <> dumpInput + | not (hasArc n1) || not (hasArc n2) = error $ "Cannot get the average of nodes if one of the nodes does not have an out!\n" <> errorLen3 + | not (canPoint n1) || not (canPoint n2) = error $ "Cannot get the average of nodes if we cannot resolve them to a point!\n" <> errorLen3 + | isParallel (outAndErrOf n1) (outAndErrOf n2) = error $ "Cannot get the average of nodes if their outputs never intersect!\n" <> errorLen3 + | isAntiParallel (outAndErrOf n1) (outAndErrOf n2) = error $ "Cannot get the average of nodes if their outputs never intersect!\n" <> errorLen3 + | isCollinear (outAndErrOf n1) (outAndErrOf n2) = error $ "Cannot (yet) handle two input plines that are collinear.\n" <> errorLen3 + | nodesAreAntiCollinear n1 n2 = error $ "Cannot (yet) handle two input plines that are collinear.\n" <> errorLen3 + | n1Distance < getRounded n1Err = error $ "intersection is AT the point of n1!\n" <> errorLen3 + | n2Distance < getRounded n2Err = error $ "intersection is AT the point of n2!\n" <> errorLen3 | n1Distance > getRounded n1Err && n2Distance > getRounded n2Err = averageNodes n1 n2 | otherwise = error $ "found node too close:\n" <> show n1 <> "\n" @@ -749,12 +751,6 @@ skeletonOfNodes connectedLoop origSegSets inSegSets iNodes = where (n1Distance, (_,_, UlpSum n1Err)) = distance2PP (intersectionOf (outAndErrOf n1) (outAndErrOf n2)) (pPointOf n1, mempty) (n2Distance, (_,_, UlpSum n2Err)) = distance2PP (intersectionOf (outAndErrOf n1) (outAndErrOf n2)) (pPointOf n2, mempty) - dumpInput = "Node1: " <> show n1 - <> "\nNode2: " <> show n2 - <> "\nNode1Out: " <> show (outOf n1) - <> "\nNode2Out: "<> show (outOf n2) - <> "\nNode1PPoint: " <> show (pPointOf n1) - <> "\nNode2PPoint: " <> show (pPointOf n2) <> "\n" -- | get the list of sorted pairs of intersecting nodes. shortestNeighboringPairs :: (Arcable a, Pointable a, Eq a) => [(a,a)] -> [(a, a)] @@ -790,25 +786,27 @@ skeletonOfNodes connectedLoop origSegSets inSegSets iNodes = -- | find nodes of two different types that can intersect. intersectingMixedNodePairs :: [(ENode, INode)] - intersectingMixedNodePairs = mapMaybe (\(node1, node2) -> if intersectsInPoint node1 node2 then Just (node1, node2) else Nothing) $ getMixedPairs eNodes iNodes + intersectingMixedNodePairs = filter (uncurry intersectsInPoint) $ getMixedPairs eNodes iNodes where getMixedPairs :: [a] -> [b] -> [(a, b)] getMixedPairs set1 set2 = concatMap (\a -> (a,) <$> set2) set1 -- | find nodes of the same type that can intersect. intersectingNodePairsOf :: (Arcable a, Pointable a) => [a] -> [(a, a)] - intersectingNodePairsOf inNodes = mapMaybe (\(node1, node2) -> if intersectsInPoint node1 node2 then Just (node1, node2) else Nothing) $ getPairs inNodes + intersectingNodePairsOf inNodes = filter (uncurry intersectsInPoint) $ getPairs inNodes -- | find nodes of the same type that can intersect. -- NOTE: accepts node pairs, so that we can ensure we check just following ENodes. intersectingNeighboringNodePairsOf :: (Arcable a, Pointable a) => [(a,a)] -> [(a, a)] - intersectingNeighboringNodePairsOf inNodePairs = mapMaybe (\(node1, node2) -> if intersectsInPoint node1 node2 then Just (node1, node2) else Nothing) $ inNodePairs + intersectingNeighboringNodePairsOf = filter (uncurry intersectsInPoint) -- | for a given pair of nodes, find the longest distance between one of the two nodes and the intersection of the two output plines. distanceToIntersection :: (Pointable a, Arcable a, Pointable b, Arcable b) => a -> b -> Maybe ℝ distanceToIntersection node1 node2 | canPoint node1 && canPoint node2 + && hasArc node1 + && hasArc node2 && intersectsInPoint node1 node2 = Just $ fst (distance2PP (pPointOf node1, mempty) (intersectionOf (outAndErrOf node1) (outAndErrOf node2))) `max` From a1c5f87176766742ea1bd52dc4c82b5d87ee026e Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Mon, 19 Dec 2022 22:23:46 +0000 Subject: [PATCH 164/206] make shortest node finding easier to read. --- Graphics/Slicer/Math/Skeleton/Concave.hs | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index d5174adb7..5a5bb3196 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -689,22 +689,25 @@ skeletonOfNodes connectedLoop origSegSets inSegSets iNodes = mixedPairsFound = if isSomething shortestMixedPairDistance && shortestMixedPairDistance == shortestPairDistance - then shortestINodesOf shortestMixedPairs + then removeFoundINodesOf shortestMixedPairs else [] where - -- | remove pairs containing INodes from the shortest INode pairs from a list of mixed pairs. - shortestINodesOf :: [(ENode, INode)] -> [(ENode, INode)] - shortestINodesOf = filter onlyShortestPairs + -- | Filter out any node pairs in our list that contain an INode from the iPairsFound list. + removeFoundINodesOf :: [(ENode, INode)] -> [(ENode, INode)] + removeFoundINodesOf = filter removeFoundPairs where - onlyShortestPairs (_,myINode) = myINode `notElem` ((fst <$> iPairsFound) <> (snd <$> iPairsFound)) + withoutINodes (_,myINode) = myINode `notElem` ((fst <$> iPairsFound) <> (snd <$> iPairsFound)) + ePairsFound = if isSomething shortestEPairDistance && shortestEPairDistance == shortestPairDistance - then filterENodesOf $ shortestNeighboringPairs $ mapWithFollower (,) eNodes + then removeFoundENodesOf $ shortestNeighboringPairs $ mapWithFollower (,) eNodes else [] where - -- | remove pairs containing ENodes from the shortest mixed pairs from a list of ENode pairs - filterENodesOf :: [(ENode, ENode)] -> [(ENode, ENode)] - filterENodesOf = filter (\(myENode1,myENode2) -> myENode1 `notElem` (fst <$> mixedPairsFound) && myENode2 `notElem` (fst <$> mixedPairsFound)) + -- | Filter out any nodes pairs in our list that contain an ENode from the mixedPairsFound list. + removeFoundENodesOf :: [(ENode, ENode)] -> [(ENode, ENode)] + removeFoundENodesOf = filter withoutENodes + where + withoutENodes (myENode1, myENode2) = myENode1 `notElem` (fst <$> mixedPairsFound) && myENode2 `notElem` (fst <$> mixedPairsFound) -- | calculate the distances to the shortest pairs of nodes. the shortest pair, along with all of the pairs of the same length, will be in our result set. shortestPairDistance = min (min shortestEPairDistance shortestMixedPairDistance) (min shortestIPairDistance shortestMixedPairDistance) From beb47c26cc7a9312e8e1f14525e144b00145e169 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Mon, 19 Dec 2022 22:53:55 +0000 Subject: [PATCH 165/206] typo. --- Graphics/Slicer/Math/Skeleton/Concave.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index 5a5bb3196..c3b913591 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -694,7 +694,7 @@ skeletonOfNodes connectedLoop origSegSets inSegSets iNodes = where -- | Filter out any node pairs in our list that contain an INode from the iPairsFound list. removeFoundINodesOf :: [(ENode, INode)] -> [(ENode, INode)] - removeFoundINodesOf = filter removeFoundPairs + removeFoundINodesOf = filter withoutINodes where withoutINodes (_,myINode) = myINode `notElem` ((fst <$> iPairsFound) <> (snd <$> iPairsFound)) @@ -703,7 +703,7 @@ skeletonOfNodes connectedLoop origSegSets inSegSets iNodes = then removeFoundENodesOf $ shortestNeighboringPairs $ mapWithFollower (,) eNodes else [] where - -- | Filter out any nodes pairs in our list that contain an ENode from the mixedPairsFound list. + -- | Filter out any node pairs in our list that contain an ENode from the mixedPairsFound list. removeFoundENodesOf :: [(ENode, ENode)] -> [(ENode, ENode)] removeFoundENodesOf = filter withoutENodes where From 653d62dd63008eb8de7815b35072a1f8a005a61b Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Wed, 21 Dec 2022 11:56:42 +0000 Subject: [PATCH 166/206] break ulpVal into ulpRaw and ulpVal, remove a LOT of realtofrac calls. --- Graphics/Slicer/Math/Arcs.hs | 12 ++--- Graphics/Slicer/Math/Contour.hs | 10 ++-- Graphics/Slicer/Math/GeometricAlgebra.hs | 11 +++-- Graphics/Slicer/Math/Intersections.hs | 10 ++-- Graphics/Slicer/Math/PGA.hs | 44 ++++++++--------- Graphics/Slicer/Math/PGAPrimitives.hs | 18 +++---- Graphics/Slicer/Math/Skeleton/Cells.hs | 6 +-- Graphics/Slicer/Math/Skeleton/Concave.hs | 43 ++++++++--------- Graphics/Slicer/Math/Skeleton/Motorcycles.hs | 14 +++--- tests/Math/PGA.hs | 50 ++++++++++---------- 10 files changed, 109 insertions(+), 109 deletions(-) diff --git a/Graphics/Slicer/Math/Arcs.hs b/Graphics/Slicer/Math/Arcs.hs index 95e8472ae..9d3b8d8fd 100644 --- a/Graphics/Slicer/Math/Arcs.hs +++ b/Graphics/Slicer/Math/Arcs.hs @@ -22,7 +22,7 @@ module Graphics.Slicer.Math.Arcs (getFirstArc, getInsideArc, getOutsideArc, towardIntersection) where -import Prelude (Bool, ($), (<>), (==), (>), (<=), (&&), (||), error, mempty, otherwise, realToFrac, show) +import Prelude (Bool, ($), (<>), (==), (>), (<=), (&&), (||), error, mempty, otherwise, show) import Graphics.Slicer.Math.Definitions (Point2, addPoints, distance, makeLineSeg, scalePoint) @@ -93,12 +93,12 @@ getObtuseAngleBisectorFromPointedLines ppoint1 line1 ppoint2 line2 | isCollinear line1 line2 = error "Asked to find the obtuse bisector of two colinear lines!" | isAntiCollinear line1 line2 = error "Asked to find the obtuse bisector of two anti-colinear lines!" | noIntersection line1 line2 = error $ "No intersection between line " <> show line1 <> " and line " <> show line2 <> ".\n" - | pointDistance <= realToFrac (ulpVal pointDistanceErr) = error $ "cannot have two identical input points:\n" <> show ppoint1 <> "\n" <> show ppoint2 <> "\n" - | point1IntersectDistance <= realToFrac (ulpVal point1IntersectDistanceErr) = error $ "intersection of plines is at first ppoint:\n" + | pointDistance <= ulpVal pointDistanceErr = error $ "cannot have two identical input points:\n" <> show ppoint1 <> "\n" <> show ppoint2 <> "\n" + | point1IntersectDistance <= ulpVal point1IntersectDistanceErr = error $ "intersection of plines is at first ppoint:\n" <> show ppoint1 <> "\n" <> show line1 <> "\n" <> show line2 <> "\n" - | point2IntersectDistance <= realToFrac (ulpVal point2IntersectDistanceErr) = error $ "intersection of plines is at second ppoint:\n" + | point2IntersectDistance <= ulpVal point2IntersectDistanceErr = error $ "intersection of plines is at second ppoint:\n" <> show ppoint2 <> "\n" <> show line1 <> "\n" <> show line2 <> "\n" @@ -119,8 +119,8 @@ getObtuseAngleBisectorFromPointedLines ppoint1 line1 ppoint2 line2 {-# INLINABLE towardIntersection #-} towardIntersection :: (ProjectivePoint2 a, ProjectiveLine2 b, ProjectivePoint2 c) => (a, PPoint2Err) -> (b, PLine2Err) -> (c, PPoint2Err) -> Bool towardIntersection point1@(pp1, _) (pl1, _) point2@(pp2, _) - | d <= realToFrac (ulpVal dErr) = error $ "cannot resolve points finely enough.\nPPoint1: " <> show pp1 <> "\nPPoint2: " <> show pp2 <> "\nPLineIn: " <> show pl1 <> "\nnewPLine: " <> show newPLine <> "\n" - | otherwise = angleFound > realToFrac (ulpVal angleErr) + | d <= ulpVal dErr = error $ "cannot resolve points finely enough.\nPPoint1: " <> show pp1 <> "\nPPoint2: " <> show pp2 <> "\nPLineIn: " <> show pl1 <> "\nnewPLine: " <> show newPLine <> "\n" + | otherwise = angleFound > ulpVal angleErr where -- FIXME: angleBetween2PL should be handling line error. (angleFound, (_,_, angleErr)) = angleBetween2PL newPLine pl1 diff --git a/Graphics/Slicer/Math/Contour.hs b/Graphics/Slicer/Math/Contour.hs index bb52d9265..6ce2cc287 100644 --- a/Graphics/Slicer/Math/Contour.hs +++ b/Graphics/Slicer/Math/Contour.hs @@ -24,7 +24,7 @@ -- | functions for handling contours. module Graphics.Slicer.Math.Contour (followingLineSeg, getContours, makeContourTreeSet, ContourTree(ContourTree), ContourTreeSet(ContourTreeSet), contourContainsContour, numPointsOfContour, pointsOfContour, firstLineSegOfContour, firstPointOfContour, justOneContourFrom, lastPointOfContour, makePointContour, firstContourOfContourTreeSet, lineSegsOfContour, makeLineSegContour, maybeFlipContour, firstPointPairOfContour, insideIsLeft, innerContourPoint, pointFarOutsideContour) where -import Prelude ((==), (&&), (*), (<), Int, (+), otherwise, (.), null, (<$>), ($), Show, filter, (/=), odd, snd, error, (<>), show, fst, Bool(True,False), Eq, Show, compare, maximum, minimum, min, (-), not, realToFrac) +import Prelude ((==), (&&), (*), (>), Int, (+), otherwise, (.), null, (<$>), ($), Show, filter, (/=), odd, snd, error, (<>), show, fst, Bool(True,False), Eq, compare, maximum, minimum, min, (-), not) import Data.List (partition, reverse, sortBy) @@ -239,10 +239,10 @@ insideIsLeft contour -- | Find a point on the interior of a given contour, on the perpendicular bisector of the first line segment, a given distance away from the line segment. innerContourPoint :: Contour -> Maybe PPoint2 innerContourPoint contour - | odd numIntersections && realToFrac (ulpVal perpErr) < minDistanceFromSeg = Just perpPoint - | odd numIntersections = error "cannot ensure perp point is on right side of contour." - | odd otherIntersections && realToFrac (ulpVal otherErr) < minDistanceFromSeg = Just otherPoint - | odd otherIntersections = error "cannot ensure other point is on the right side of the contour." + | odd numIntersections && minDistanceFromSeg > ulpVal perpErr = Just perpPoint + | odd numIntersections = error "cannot ensure perp point is on the correct side of contour." + | odd otherIntersections && minDistanceFromSeg > ulpVal otherErr = Just otherPoint + | odd otherIntersections = error "cannot ensure other point is on the correct side of the contour." | otherwise = Nothing where numIntersections = contourIntersectionCount contour (pToEPoint2 perpPoint, outsidePoint) diff --git a/Graphics/Slicer/Math/GeometricAlgebra.hs b/Graphics/Slicer/Math/GeometricAlgebra.hs index 5007a79f1..df4ce9a6d 100644 --- a/Graphics/Slicer/Math/GeometricAlgebra.hs +++ b/Graphics/Slicer/Math/GeometricAlgebra.hs @@ -63,6 +63,7 @@ module Graphics.Slicer.Math.GeometricAlgebra( subValPairWithErr, subVecPair, sumErrVals, + ulpRaw, ulpVal, unlikeVecPair, valOf, @@ -95,7 +96,7 @@ import Data.Set (Set, singleton, disjoint, elems, size, elemAt, fromAscList) import Data.Set as S (filter) -import Numeric.Rounded.Hardware (Rounded, RoundingMode(TowardInf, ToNearest)) +import Numeric.Rounded.Hardware (Rounded, RoundingMode(TowardInf, ToNearest), getRounded) import Safe (headMay) @@ -129,9 +130,13 @@ data GRVal = GRVal deriving (Eq, Generic, NFData, Show) -- | A constantly increasing sum of error. Used for increasing our error bars proportonally to error collected from the FPU during calculations. -newtype UlpSum = UlpSum { ulpVal :: Rounded 'TowardInf ℝ } +newtype UlpSum = UlpSum { ulpRaw :: Rounded 'TowardInf ℝ } deriving (Show, Eq, Generic, NFData, Ord) +-- provide a value extractor directly to ℝ, which is a newtype of Double. +ulpVal :: UlpSum -> ℝ +ulpVal = getRounded . ulpRaw + instance Semigroup UlpSum where (<>) (UlpSum sum1) (UlpSum sum2) = UlpSum $ sum1 + sum2 @@ -792,4 +797,4 @@ vectorPart (GVec vals) = GVec $ foldl' addVal [] $ P.filter noRealValue vals -- | Temporary hack. sumErrVals :: [ErrVal] -> UlpSum -sumErrVals errVals = UlpSum $ sum $ ulpVal . (\(ErrVal a _) -> a) <$> errVals +sumErrVals errVals = UlpSum $ sum $ ulpRaw . (\(ErrVal a _) -> a) <$> errVals diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index ecef5124f..763a5cfac 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -34,7 +34,7 @@ module Graphics.Slicer.Math.Intersections ( outputIntersectsPLineAt ) where -import Prelude (Bool(True), Either(Left, Right), (<>), ($), (<), (||), (==), (&&), (<$>), (<=), and, error, show, otherwise, realToFrac) +import Prelude (Bool(True), Either(Left, Right), (<>), ($), (<), (||), (==), (&&), (<$>), (<=), and, error, show, otherwise) import Data.Either (rights, lefts) @@ -85,10 +85,10 @@ intersectionBetween line1@(l1, _) line2@(l2, _) = saneIntersection $ plinesInter (foundDistance, (_,_, foundErr)) = distance2PL l1 l2 saneIntersection PAntiCollinear = Just $ Left line1 saneIntersection PCollinear = Just $ Left line1 - saneIntersection PParallel = if foundDistance < realToFrac (ulpVal foundErr) + saneIntersection PParallel = if foundDistance < ulpVal foundErr then Just $ Left line1 else Nothing - saneIntersection PAntiParallel = if foundDistance < realToFrac (ulpVal foundErr) + saneIntersection PAntiParallel = if foundDistance < ulpVal foundErr then Just $ Left line1 else Nothing saneIntersection (IntersectsIn p (_,_, pErr)) = Just $ Right (p, pErr) @@ -147,7 +147,7 @@ intersectionsAtSamePoint nodeOutsAndErrs -- intersections that resulted in a point. pointIntersections = rights $ catMaybes intersections -- Minor optimization: first check against resErr, then actually use the fuzziness. - pairCloseEnough (a1, b1, point1@(c1,_)) (a2, b2, point2@(c2,_)) = res <= realToFrac (ulpVal resErr) || res < realToFrac errSum + pairCloseEnough (a1, b1, point1@(c1,_)) (a2, b2, point2@(c2,_)) = res <= ulpVal resErr || res < errSum where errSum = ulpVal $ resErr <> fuzzinessOfP point1 @@ -162,7 +162,7 @@ intersectionsAtSamePoint nodeOutsAndErrs [] -> True [(a1,b1,l1)] -> case pointIntersections of [] -> error "one line, no points.. makes no sense." - ((a2,b2,ppoint1@(p1,_)):_) -> pointsCloseEnough && foundDistance < realToFrac errSum + ((a2,b2,ppoint1@(p1,_)):_) -> pointsCloseEnough && foundDistance < errSum where (foundDistance, (_, _, _, _, _, resErr)) = distancePPToPL ppoint1 l1 errSum = ulpVal $ resErr diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index eb3668865..8cc4d642f 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -103,7 +103,7 @@ import Graphics.Slicer.Definitions (ℝ) import Graphics.Slicer.Math.Definitions (Point2(Point2), LineSeg(LineSeg), addPoints, startPoint, endPoint, distance) -import Graphics.Slicer.Math.GeometricAlgebra (ErrVal, GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎤+), (⨅+), (•), addValWithoutErr, addVecPairWithoutErr, eValOf, getVal, mulScalarVecWithErr, ulpVal, valOf) +import Graphics.Slicer.Math.GeometricAlgebra (ErrVal, GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎤+), (⨅+), (•), addValWithoutErr, addVecPairWithoutErr, eValOf, getVal, mulScalarVecWithErr, ulpRaw, ulpVal, valOf) import Graphics.Slicer.Math.Line (combineLineSegs, makeLineSeg) @@ -128,7 +128,7 @@ data PIntersection = plinesIntersectIn :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> PIntersection plinesIntersectIn (pl1, pl1Err) (pl2, pl2Err) | isNothing canonicalizedIntersection - || (idealNorm <= realToFrac (ulpVal idnErr) + || (idealNorm <= ulpVal idnErr && (sameDirection pl1 pl2 || oppositeDirection pl1 pl2)) = if sameDirection pl1 pl2 then PCollinear @@ -143,7 +143,7 @@ plinesIntersectIn (pl1, pl1Err) (pl2, pl2Err) where -- | The distance within which we consider (anti)parallel lines to be (anti)colinear. parallelFuzziness :: ℝ - parallelFuzziness = realToFrac $ ulpVal $ dErr <> pLineErrAtPPoint (npl1, npl1Err <> pl1Err) res <> pLineErrAtPPoint (npl2, npl2Err <> pl2Err) res + parallelFuzziness = ulpVal $ dErr <> pLineErrAtPPoint (npl1, npl1Err <> pl1Err) res <> pLineErrAtPPoint (npl2, npl2Err <> pl2Err) res -- | When two lines are really close to parallel or antiparallel, we use the distance between the lines to decide whether to promote them to being (anti)colinear. (d, (_, _, dErr)) = distance2PL npl1 npl2 (idealNorm, idnErr) = idealNormOfP res @@ -161,7 +161,7 @@ pLineIsLeft (pl1, _) (pl2, _) | otherwise = Just $ res > 0 where angleFuzz :: ℝ - angleFuzz = realToFrac $ ulpVal angleFuzzRaw + angleFuzz = ulpVal angleFuzzRaw (res, (_,_, angleFuzzRaw)) = angleCosBetween2PL pl1 pl2 (npl1, _) = normalizeL pl1 (npl2, _) = normalizeL pl2 @@ -199,10 +199,10 @@ pPointsOnSameSideOfPLine point1 point2 line | otherwise = Just $ signum foundP1 == signum foundP2 where foundErr1, foundErr2 :: ℝ - foundErr1 = realToFrac $ ulpVal (eValOf mempty (getVal [GEZero 1, GEPlus 1, GEPlus 2] unlikeP1AddErr)) + - ulpVal (eValOf mempty (getVal [GEZero 1, GEPlus 1, GEPlus 2] unlikeP1MulErr)) - foundErr2 = realToFrac $ ulpVal (eValOf mempty (getVal [GEZero 1, GEPlus 1, GEPlus 2] unlikeP2AddErr)) + - ulpVal (eValOf mempty (getVal [GEZero 1, GEPlus 1, GEPlus 2] unlikeP2MulErr)) + foundErr1 = realToFrac $ ulpRaw (eValOf mempty (getVal [GEZero 1, GEPlus 1, GEPlus 2] unlikeP1AddErr)) + + ulpRaw (eValOf mempty (getVal [GEZero 1, GEPlus 1, GEPlus 2] unlikeP1MulErr)) + foundErr2 = realToFrac $ ulpRaw (eValOf mempty (getVal [GEZero 1, GEPlus 1, GEPlus 2] unlikeP2AddErr)) + + ulpRaw (eValOf mempty (getVal [GEZero 1, GEPlus 1, GEPlus 2] unlikeP2MulErr)) foundP1 = valOf 0 $ getVal [GEZero 1, GEPlus 1, GEPlus 2] unlikeP1 foundP2 = valOf 0 $ getVal [GEZero 1, GEPlus 1, GEPlus 2] unlikeP2 (GVec unlikeP1, (unlikeP1MulErr, unlikeP1AddErr)) = pv1 ⎤+ lv1 @@ -217,7 +217,7 @@ sameDirection a b = res >= maxAngle where -- ceiling value. a value bigger than maxAngle is considered to be going the same direction. maxAngle :: ℝ - maxAngle = realToFrac (1 - ulpVal resErr :: Rounded 'TowardInf ℝ) + maxAngle = realToFrac (1 - ulpRaw resErr :: Rounded 'TowardInf ℝ) (res, (_,_,resErr)) = angleBetween2PL a b -- | A checker, to ensure two Projective Lines are going the opposite direction, and are parallel. @@ -226,7 +226,7 @@ oppositeDirection a b = res <= minAngle where -- floor value. a value smaller than minAngle is considered to be going the opposite direction. minAngle :: ℝ - minAngle = realToFrac (realToFrac (ulpVal resErr) + (-1) :: Rounded 'TowardNegInf ℝ) + minAngle = realToFrac (realToFrac (ulpRaw resErr) + (-1) :: Rounded 'TowardNegInf ℝ) (res, (_,_,resErr)) = angleBetween2PL a b -- | Find a projective point a given distance along a line perpendicularly bisecting the given line at a given point. @@ -344,7 +344,7 @@ pLineIntersectsLineSeg (pl1, pl1ErrOrigin) l1 | res == PAntiParallel = Right PAntiParallel | res == PCollinear = Right PCollinear | res == PAntiCollinear = Right PAntiCollinear - | hasIntersection && distance (startPoint l1) (endPoint l1) < realToFrac (ulpVal $ startFudgeFactor <> endFudgeFactor <> tFuzz) = error $ "cannot resolve endpoints of segment: " <> show l1 <> ".\n" <> dumpMiss + | hasIntersection && distance (startPoint l1) (endPoint l1) < ulpVal (startFudgeFactor <> endFudgeFactor <> tFuzz) = error $ "cannot resolve endpoints of segment: " <> show l1 <> ".\n" <> dumpMiss | hasIntersection && startDistance <= ulpStartSum = Left $ HitStartPoint l1 | hasIntersection && endDistance <= ulpEndSum = Left $ HitEndPoint l1 | hasIntersection = Right $ IntersectsIn rawIntersection (pl1Err, pl2Err, rawIntersectionErr) @@ -353,8 +353,8 @@ pLineIntersectsLineSeg (pl1, pl1ErrOrigin) l1 where res = plinesIntersectIn (pl1, pl1Err) (pl2, pl2Err) ulpStartSum, ulpEndSum :: ℝ - ulpStartSum = realToFrac $ ulpVal startDistanceErr - ulpEndSum = realToFrac $ ulpVal endDistanceErr + ulpStartSum = ulpVal startDistanceErr + ulpEndSum = ulpVal endDistanceErr (startDistance, (_,_, startDistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (start, mempty) (endDistance, (_,_, endDistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (end, mempty) startFudgeFactor = startDistanceErr <> startErr @@ -393,10 +393,10 @@ lineSegIntersectsLineSeg l1 l2 | res == PAntiParallel = Right PAntiParallel | hasIntersection && res == PCollinear = Right PCollinear | hasIntersection && res == PAntiCollinear = Right PAntiCollinear - | hasIntersection && distance (startPoint l1) (endPoint l1) < realToFrac (ulpVal $ start1FudgeFactor <> end1FudgeFactor <> tFuzz1) = error $ "cannot resolve endpoints of segment: " <> show l1 <> ".\n" <> dumpMiss + | hasIntersection && distance (startPoint l1) (endPoint l1) < ulpVal (start1FudgeFactor <> end1FudgeFactor <> tFuzz1) = error $ "cannot resolve endpoints of segment: " <> show l1 <> ".\n" <> dumpMiss | hasIntersection && start1Distance <= ulpStart1Sum = Left $ HitStartPoint l1 | hasIntersection && end1Distance <= ulpEnd1Sum = Left $ HitEndPoint l1 - | hasIntersection && distance (startPoint l2) (endPoint l2) < realToFrac (ulpVal $ start2FudgeFactor <> end2FudgeFactor <> tFuzz2) = error $ "cannot resolve endpoints of segment: " <> show l2 <> ".\n" <> dumpMiss + | hasIntersection && distance (startPoint l2) (endPoint l2) < ulpVal (start2FudgeFactor <> end2FudgeFactor <> tFuzz2) = error $ "cannot resolve endpoints of segment: " <> show l2 <> ".\n" <> dumpMiss | hasIntersection && start2Distance <= ulpStart2Sum = Left $ HitStartPoint l2 | hasIntersection && end2Distance <= ulpEnd2Sum = Left $ HitEndPoint l2 | hasIntersection = Right $ IntersectsIn rawIntersection (pl1Err, pl2Err, rawIntersectionErr) @@ -409,11 +409,11 @@ lineSegIntersectsLineSeg l1 l2 start2FudgeFactor = start2DistanceErr <> pLineErrAtPPoint (pl2,pl2Err) start2 end2FudgeFactor = end2DistanceErr <> pLineErrAtPPoint (pl2,pl2Err) end2 ulpStart1Sum, ulpEnd1Sum :: ℝ - ulpStart1Sum = realToFrac $ ulpVal start1DistanceErr - ulpEnd1Sum = realToFrac $ ulpVal end1DistanceErr + ulpStart1Sum = ulpVal start1DistanceErr + ulpEnd1Sum = ulpVal end1DistanceErr ulpStart2Sum, ulpEnd2Sum :: ℝ - ulpStart2Sum = realToFrac $ ulpVal start2DistanceErr - ulpEnd2Sum = realToFrac $ ulpVal end2DistanceErr + ulpStart2Sum = ulpVal start2DistanceErr + ulpEnd2Sum = ulpVal end2DistanceErr (start1Distance, (_,_, start1DistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (start1, mempty) (start2Distance, (_,_, start2DistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (start2, mempty) (end1Distance, (_,_, end1DistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (end1, mempty) @@ -461,9 +461,9 @@ onSegment ls i = tFuzz = fuzzinessOfL $ eToPL ls lengthOfSegment = distance (startPoint ls) (endPoint ls) startFudgeFactor, midFudgeFactor, endFudgeFactor :: ℝ - startFudgeFactor = realToFrac $ ulpVal $ startDistanceErr <> tFuzz <> pLineErrAtPPoint (eToPL ls) start - midFudgeFactor = realToFrac $ ulpVal $ midDistanceErr <> tFuzz <> pLineErrAtPPoint (eToPL ls) mid - endFudgeFactor = realToFrac $ ulpVal $ endDistanceErr <> tFuzz <> pLineErrAtPPoint (eToPL ls) end + startFudgeFactor = ulpVal $ startDistanceErr <> tFuzz <> pLineErrAtPPoint (eToPL ls) start + midFudgeFactor = ulpVal $ midDistanceErr <> tFuzz <> pLineErrAtPPoint (eToPL ls) mid + endFudgeFactor = ulpVal $ endDistanceErr <> tFuzz <> pLineErrAtPPoint (eToPL ls) end -- | Combine consecutive line segments. expects line segments with their end points connecting, EG, a contour generated by makeContours. combineConsecutiveLineSegs :: [LineSeg] -> [LineSeg] diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index a42b706ac..b3e8bb605 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -80,7 +80,7 @@ import Graphics.Slicer.Definitions (ℝ) import Graphics.Slicer.Math.Definitions (Point2(Point2)) -import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎣+), (⎤+), (∧), (•), addErr, addValWithoutErr, addVecPairWithErr, addVecPairWithoutErr, divVecScalarWithErr, eValOf, getVal, mulScalarVecWithErr, scalarPart, sumErrVals, ulpVal, valOf) +import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎣+), (⎤+), (∧), (•), addErr, addValWithoutErr, addVecPairWithErr, addVecPairWithoutErr, divVecScalarWithErr, eValOf, getVal, mulScalarVecWithErr, scalarPart, sumErrVals, ulpRaw, ulpVal, valOf) -------------------------------- --- common support functions --- @@ -390,13 +390,13 @@ pLineErrAtPPoint (line, lineErr) errPoint yInterceptIsRight = isJust (yIntercept (nPLine, nPLineErr)) && isRight (fst $ fromJust $ yIntercept (nPLine, nPLineErr)) && fromRight 0 (fst $ fromJust $ yIntercept (nPLine, nPLineErr)) /= 0 - xInterceptFuzz = UlpSum $ ulpVal rawXInterceptFuzz * ( realToFrac $ xMax / (sqrt (xMin*xMin*yMax*yMax))) * realToFrac (abs xPos) - yInterceptFuzz = UlpSum $ ulpVal rawYInterceptFuzz * ( realToFrac $ yMax / (sqrt (xMax*xMax*yMin*yMin))) * realToFrac (abs yPos) + xInterceptFuzz = UlpSum $ ulpRaw rawXInterceptFuzz * ( realToFrac $ xMax / (sqrt (xMin*xMin*yMax*yMax))) * realToFrac (abs xPos) + yInterceptFuzz = UlpSum $ ulpRaw rawYInterceptFuzz * ( realToFrac $ yMax / (sqrt (xMax*xMax*yMin*yMin))) * realToFrac (abs yPos) xMin, xMax, yMin, yMax :: ℝ - xMax = xInterceptDistance + realToFrac (ulpVal rawXInterceptFuzz) - yMax = yInterceptDistance + realToFrac (ulpVal rawYInterceptFuzz) - xMin = xInterceptDistance - realToFrac (ulpVal rawXInterceptFuzz) - yMin = yInterceptDistance - realToFrac (ulpVal rawYInterceptFuzz) + xMax = xInterceptDistance + ulpVal rawXInterceptFuzz + yMax = yInterceptDistance + ulpVal rawYInterceptFuzz + xMin = xInterceptDistance - ulpVal rawXInterceptFuzz + yMin = yInterceptDistance - ulpVal rawYInterceptFuzz rawYInterceptFuzz = snd $ fromJust $ yIntercept (nPLine, nPLineErr) rawXInterceptFuzz = snd $ fromJust $ xIntercept (nPLine, nPLineErr) yInterceptDistance = abs $ fromRight 0 $ fst $ fromJust $ xIntercept (nPLine, nPLineErr) @@ -724,9 +724,9 @@ sumPPointErrs errs = eValOf mempty (getVal [GEZero 1, GEPlus 1] errs) -- FIXME: This 1000 here is completely made up BS. fuzzinessOfProjectivePoint, fuzzinessOfP :: (ProjectivePoint2 a) => (a, PPoint2Err) -> UlpSum -- | Actual implementation. -fuzzinessOfProjectivePoint (point, pointErr) = UlpSum $ sumTotal * realToFrac (1+(1000*(abs angleIn + realToFrac (ulpVal $ sumPPointErrs angleUnlikeAddErr <> sumPPointErrs angleUnlikeMulErr)))) +fuzzinessOfProjectivePoint (point, pointErr) = UlpSum $ sumTotal * realToFrac (1+(1000*(abs angleIn + realToFrac (ulpRaw $ sumPPointErrs angleUnlikeAddErr <> sumPPointErrs angleUnlikeMulErr)))) where - sumTotal = ulpVal $ sumPPointErrs pJoinAddErr + sumTotal = ulpRaw $ sumPPointErrs pJoinAddErr <> sumPPointErrs pJoinMulErr <> sumPPointErrs pCanonicalizeErr <> sumPPointErrs pAddErr diff --git a/Graphics/Slicer/Math/Skeleton/Cells.hs b/Graphics/Slicer/Math/Skeleton/Cells.hs index 487fc4a07..65a681d36 100644 --- a/Graphics/Slicer/Math/Skeleton/Cells.hs +++ b/Graphics/Slicer/Math/Skeleton/Cells.hs @@ -26,7 +26,7 @@ -- a contour into cells. module Graphics.Slicer.Math.Skeleton.Cells (UnsupportedReason(INodeCrossesDivide), findDivisions, findFirstCellOfContour, findNextCell, getNodeTreeOfCell, nodeTreesDoNotOverlap, addNodeTreesAlongDivide, nodeTreesFromDivision, startOfDivide, endOfDivide, findRemainder, createCellFromStraightWalls, gatherLineSegsPreceedingDivide, startBeforeEnd) where -import Prelude (Bool(False), Eq, Ordering(LT, GT, EQ), Show, elem, filter, null, otherwise, ($), (<$>), (==), error, (<>), show, (&&), compare, concat, (/=), (||), (<), (<=), fst, snd, (*), mempty, realToFrac) +import Prelude (Bool(False), Eq, Ordering(LT, GT, EQ), Show, elem, filter, null, otherwise, ($), (<$>), (==), error, (<>), show, (&&), compare, concat, (/=), (||), (<), (<=), fst, snd, (*), mempty) import Data.Either(Either(Left, Right)) @@ -109,7 +109,7 @@ findDivisions contour crashTree = case motorcyclesIn crashTree of -- LOWHANGINGFRUIT: what about two motorcycles that are anticolinear? error "don't know what to do with these motorcycles." where - intersectionIsBehind m = angleFound < realToFrac (ulpVal angleErr) + intersectionIsBehind m = angleFound < ulpVal angleErr where (angleFound, (_,_, angleErr)) = angleBetween2PL (outOf m) (eToPLine2 $ lineSegToIntersection m) lineSegToIntersection m = makeLineSeg (ePointOf m) (pToEPoint2 intersectionPPoint) @@ -401,7 +401,7 @@ nodeTreesDoNotOverlap nodeTree1 nodeTree2 cellDivide@(CellDivide motorcycles1 _) -- | Check that the outputs of the NodeTrees collide at the same point at the division between the two cells the NodeTrees correspond to. lastOutsIntersect :: NodeTree -> NodeTree -> CellDivide -> Bool lastOutsIntersect nt1 nt2 (CellDivide motorcycles _) = case motorcycles of - (DividingMotorcycles m (Slist _ 0)) -> d < realToFrac (ulpVal dErr) + (DividingMotorcycles m (Slist _ 0)) -> d < ulpVal dErr where (d, (_,_, dErr)) = distance2PP point1 point2 point1 = fromMaybe (error "no outArc?") $ outputIntersectsPLineAt m (finalPLine nt1) diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index c3b913591..a5c3bd4a0 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -28,7 +28,7 @@ module Graphics.Slicer.Math.Skeleton.Concave (skeletonOfConcaveRegion, findINodes, makeENode, makeENodes, averageNodes, eNodesOfOutsideContour) where -import Prelude (Eq, Show, Bool(True, False), Either(Left, Right), String, Ord, Ordering(GT,LT), all, notElem, otherwise, ($), (>), (<), (<$>), (==), (/=), (>=), error, (&&), fst, (<>), show, not, max, compare, uncurry, null, (||), min, snd, filter, zip, any, (*), (+), Int, (.), (-), concatMap, mempty, realToFrac) +import Prelude (Eq, Show, Bool(True, False), Either(Left, Right), String, Ord, Ordering(GT,LT), all, notElem, otherwise, ($), (>), (<), (<$>), (==), (/=), (>=), error, (&&), fst, (<>), show, not, max, compare, uncurry, null, (||), min, snd, filter, zip, any, (*), (+), Int, (.), (-), concatMap, mempty) import Prelude as PL (head, last, tail, init) @@ -36,8 +36,6 @@ import Data.Maybe (Maybe(Just,Nothing), fromMaybe, isJust, isNothing, mapMaybe) import Data.List (takeWhile, dropWhile, sortBy, nub) -import Numeric.Rounded.Hardware (getRounded) - import Data.List.Extra (unsnoc) import Slist.Type (Slist(Slist)) @@ -54,11 +52,11 @@ import Graphics.Slicer.Math.Contour (lineSegsOfContour) import Graphics.Slicer.Math.Definitions (Contour, LineSeg(LineSeg), Point2, endPoint, mapWithFollower, startPoint) -import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum)) +import Graphics.Slicer.Math.GeometricAlgebra (ulpVal) -import Graphics.Slicer.Math.Intersections (intersectionOf, intersectionsAtSamePoint, isAntiCollinear, isAntiParallel, isCollinear, isParallel, noIntersection) +import Graphics.Slicer.Math.Intersections (intersectionOf, intersectionBetweenArcsOf, intersectionsAtSamePoint, isAntiCollinear, isAntiParallel, isCollinear, isParallel, noIntersection) -import Graphics.Slicer.Math.PGA (Arcable(errOfOut, hasArc, outOf), Pointable(canPoint, pPointOf), PLine2, PLine2Err, ProjectiveLine2, distance2PP, eToPL, flipL, outAndErrOf, pPointAndErrOf, pLineIsLeft) +import Graphics.Slicer.Math.PGA (Arcable(errOfOut, hasArc, outOf), Pointable(canPoint), PLine2, PLine2Err, ProjectiveLine2, distance2PP, eToPL, flipL, outAndErrOf, pPointAndErrOf, pLineIsLeft) import Graphics.Slicer.Math.Skeleton.Definitions (ENode(ENode), ENodeSet(ENodeSet), INode(INode), INodeSet(INodeSet), NodeTree(NodeTree), concavePLines, getFirstLineSeg, getLastLineSeg, finalOutOf, firstInOf, getPairs, indexPLinesTo, insOf, lastINodeOf, linePairs, makeINode, sortedPLinesWithErr, isLoop) @@ -588,20 +586,16 @@ skeletonOfNodes connectedLoop origSegSets inSegSets iNodes = errorLen3 = "shortestPairDistance: " <> show shortestPairDistance <> "\n" <> "ePairDistance: " <> show shortestEPairDistance <> "\n" <> "shortestEPairs: " <> show (shortestPairs eNodes) <> "\n" - <> "ePairResults: " <> show (uncurry safeAverageNodes <$> shortestPairs eNodes) <> "\n" <> show (isSomething shortestEPairDistance) <> "\n" <> "iPairDistance: " <> show shortestIPairDistance <> "\n" <> "shortestIPairs: " <> show (shortestPairs iNodes) <> "\n" - <> "iPairResults: " <> show (uncurry safeAverageNodes <$> shortestPairs iNodes) <> "\n" <> show (isSomething shortestIPairDistance) <> "\n" <> "mixedPairDistance: " <> show shortestMixedPairDistance <> "\n" <> "shortestMixedPairs: " <> show shortestMixedPairs <> "\n" - <> "MixedPairResults: " <> show (uncurry safeAverageNodes <$> shortestMixedPairs) <> "\n" <> show (isSomething shortestMixedPairDistance) <> "\n" <> show (shortestEPairDistance == shortestPairDistance) <> "\n" <> "remainingLineSegs: " <> show remainingLineSegs <> "\n" <> "remainingINodes: " <> show remainingINodes <> "\n" - <> "thisGen: " <> show averageOfShortestPairs <> "\n" <> "origSegSets: " <> show origSegSets <> "\n" -- | check to see if all of our nodes end in the same point @@ -745,15 +739,16 @@ skeletonOfNodes connectedLoop origSegSets inSegSets iNodes = | isAntiParallel (outAndErrOf n1) (outAndErrOf n2) = error $ "Cannot get the average of nodes if their outputs never intersect!\n" <> errorLen3 | isCollinear (outAndErrOf n1) (outAndErrOf n2) = error $ "Cannot (yet) handle two input plines that are collinear.\n" <> errorLen3 | nodesAreAntiCollinear n1 n2 = error $ "Cannot (yet) handle two input plines that are collinear.\n" <> errorLen3 - | n1Distance < getRounded n1Err = error $ "intersection is AT the point of n1!\n" <> errorLen3 - | n2Distance < getRounded n2Err = error $ "intersection is AT the point of n2!\n" <> errorLen3 - | n1Distance > getRounded n1Err && n2Distance > getRounded n2Err = averageNodes n1 n2 - | otherwise = error $ "found node too close:\n" - <> show n1 <> "\n" - <> show n2 <> "\n" + | n1Distance < ulpVal n1Err = error $ "intersection is AT the point of n1!\n" <> show n1Distance <> "\n" <> show n2Distance <> "\n" <> show intersectionPoint <> "\n" <> show n1 <> "\n" <> show n2 <> "\n" <> errorLen3 + | n2Distance < ulpVal n2Err = error $ "intersection is AT the point of n2!\n" <> show n1Distance <> "\n" <> show n2Distance <> "\n" <> show intersectionPoint <> "\n" <> show n1 <> "\n" <> show n2 <> "\n" <> errorLen3 + | n1Distance > ulpVal n1Err && n2Distance > ulpVal n2Err = averageNodes n1 n2 + | otherwise = error $ "found node too close:\n" + <> show n1 <> "\n" + <> show n2 <> "\n" where - (n1Distance, (_,_, UlpSum n1Err)) = distance2PP (intersectionOf (outAndErrOf n1) (outAndErrOf n2)) (pPointOf n1, mempty) - (n2Distance, (_,_, UlpSum n2Err)) = distance2PP (intersectionOf (outAndErrOf n1) (outAndErrOf n2)) (pPointOf n2, mempty) + intersectionPoint = fromMaybe (error "has arcs, but no intersection?") $ intersectionBetweenArcsOf n1 n2 + (n1Distance, (_,_, n1Err)) = distance2PP (intersectionOf (outAndErrOf n1) (outAndErrOf n2)) (pPointAndErrOf n1) + (n2Distance, (_,_, n2Err)) = distance2PP (intersectionOf (outAndErrOf n1) (outAndErrOf n2)) (pPointAndErrOf n2) -- | get the list of sorted pairs of intersecting nodes. shortestNeighboringPairs :: (Arcable a, Pointable a, Eq a) => [(a,a)] -> [(a, a)] @@ -811,17 +806,17 @@ skeletonOfNodes connectedLoop origSegSets inSegSets iNodes = && hasArc node1 && hasArc node2 && intersectsInPoint node1 node2 = - Just $ fst (distance2PP (pPointOf node1, mempty) (intersectionOf (outAndErrOf node1) (outAndErrOf node2))) + Just $ fst (distance2PP (pPointAndErrOf node1) (intersectionOf (outAndErrOf node1) (outAndErrOf node2))) `max` - fst (distance2PP (pPointOf node2, mempty) (intersectionOf (outAndErrOf node1) (outAndErrOf node2))) + fst (distance2PP (pPointAndErrOf node2) (intersectionOf (outAndErrOf node1) (outAndErrOf node2))) | otherwise = Nothing -- | Check if the intersection of two nodes results in a point or not. intersectsInPoint :: (Arcable a, Pointable a, Arcable b, Pointable b) => a -> b -> Bool intersectsInPoint node1 node2 | hasArc node1 && hasArc node2 = not (noIntersection (outAndErrOf node1) (outAndErrOf node2)) - && (dist1 >= realToFrac dist1Err) - && (dist2 >= realToFrac dist2Err) + && dist1 >= ulpVal dist1Err + && dist2 >= ulpVal dist2Err | otherwise = error $ "cannot intersect a node with no output:\nNode1: " <> show node1 <> "\nNode2: " <> show node2 <> "\nnodes: " <> show iNodes <> "\n" where - (dist1, (_,_,UlpSum dist1Err)) = distance2PP (pPointOf node1, mempty) (intersectionOf (outAndErrOf node1) (outAndErrOf node2)) - (dist2, (_,_,UlpSum dist2Err)) = distance2PP (pPointOf node2, mempty) (intersectionOf (outAndErrOf node1) (outAndErrOf node2)) + (dist1, (_,_,dist1Err)) = distance2PP (pPointAndErrOf node1) (intersectionOf (outAndErrOf node1) (outAndErrOf node2)) + (dist2, (_,_,dist2Err)) = distance2PP (pPointAndErrOf node2) (intersectionOf (outAndErrOf node1) (outAndErrOf node2)) diff --git a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs index e3440bc2f..b63dc34b7 100644 --- a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs +++ b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs @@ -26,7 +26,7 @@ module Graphics.Slicer.Math.Skeleton.Motorcycles (CollisionType(HeadOn), CrashTree(CrashTree), motorcycleToENode, Collision(Collision), motorcycleIntersectsAt, intersectionSameSide, crashMotorcycles, collisionResult, convexMotorcycles, lastCrashType, motorcyclesAreAntiCollinear, motorcyclesInDivision, motorcycleMightIntersectWith, motorcycleDivisor) where -import Prelude (Bool(True, False), Either(Left,Right), Eq((==)), Show(show), Ordering (EQ, GT, LT), (&&), (<>), ($), (<), (>), compare, error, fst, mempty, notElem, null, otherwise, realToFrac, zip) +import Prelude (Bool(True, False), Either(Left,Right), Eq((==)), Show(show), Ordering (EQ, GT, LT), (&&), (<>), ($), (<), (>), compare, error, fst, mempty, notElem, null, otherwise, zip) import Prelude as PL (init, last) @@ -157,7 +157,7 @@ crashMotorcycles contour holes _ -> Nothing where intersectionPPoint = intersectionOf (outAndErrOf mot1) (outAndErrOf mot2) - intersectionIsBehind m = angleFound < realToFrac (ulpVal angleErr) + intersectionIsBehind m = angleFound < ulpVal angleErr where (angleFound, (_,_, angleErr)) = angleBetween2PL (outOf m) (eToPLine2 $ lineSegToIntersection m) lineSegToIntersection m = makeLineSeg (ePointOf m) (pToEPoint2 $ fst intersectionPPoint) @@ -257,10 +257,10 @@ motorcycleMightIntersectWith lineSegs motorcycle then Nothing else Just intersection where - intersectionPointIsBehind point = angleFound < realToFrac (ulpVal angleErr) + intersectionPointIsBehind point = angleFound < ulpVal angleErr where (angleFound, (_,_, angleErr)) = angleBetween2PL (outOf motorcycle) (eToPLine2 $ lineSegToIntersection point) - intersectionCPPointIsBehind pPoint = angleFound < realToFrac (ulpVal angleErr) + intersectionCPPointIsBehind pPoint = angleFound < ulpVal angleErr where (angleFound, (_,_, angleErr)) = angleBetween2PL (outOf motorcycle) (eToPLine2 $ lineSegToIntersectionP pPoint) lineSegToIntersection myPoint = makeLineSeg (ePointOf motorcycle) myPoint @@ -300,10 +300,10 @@ motorcycleIntersectsAt contour motorcycle = case intersections of then Nothing else Just intersection where - intersectionPointIsBehind point = angleFound < realToFrac (ulpVal angleErr) + intersectionPointIsBehind point = angleFound < ulpVal angleErr where (angleFound, (_,_, angleErr)) = angleBetween2PL (outOf motorcycle) (eToPLine2 $ lineSegToIntersection point) - intersectionPPointIsBehind pPoint = angleFound < realToFrac (ulpVal angleErr) + intersectionPPointIsBehind pPoint = angleFound < ulpVal angleErr where (angleFound, (_,_, angleErr)) = angleBetween2PL (outOf motorcycle) (eToPLine2 $ lineSegToIntersectionP pPoint) lineSegToIntersection myPoint = makeLineSeg (ePointOf motorcycle) myPoint @@ -316,7 +316,7 @@ motorcycleIntersectsAt contour motorcycle = case intersections of {-# INLINABLE intersectionSameSide #-} intersectionSameSide :: (ProjectivePoint2 a, Pointable b) => (a, PPoint2Err) -> b -> Motorcycle -> Maybe Bool intersectionSameSide point@(pp1, _) node (Motorcycle _ path _) - | canPoint node && d < realToFrac (ulpVal dErr) = Just True + | canPoint node && d < ulpVal dErr = Just True | canPoint node = pPointsOnSameSideOfPLine (pPointOf node) pp1 path | otherwise = error $ "cannot resolve provided item to a point: " <> show node <> "\n" where diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index 93908b3f9..510752d7f 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -25,6 +25,9 @@ -- So we can add Eq instances here, instead of in the library. {-# LANGUAGE StandaloneDeriving #-} +-- Ignore the orphan instances we create for testing purposes. +{-# OPTIONS_GHC -Wno-orphans #-} + module Math.PGA (linearAlgSpec, geomAlgSpec, pgaSpec, proj2DGeomAlgSpec, facetSpec, facetFlakeySpec, contourSpec, lineSpec) where -- Be explicit about what we import. @@ -57,7 +60,7 @@ import Graphics.Slicer (ℝ) import Graphics.Slicer.Math.Definitions(Point2(Point2), Contour(LineSegContour), LineSeg(LineSeg), roundPoint2, startPoint, distance, xOf, yOf, minMaxPoints, makeLineSeg, endPoint) -- Our Geometric Algebra library. -import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(GEZero, GEPlus, G0), GVal(GVal), GVec(GVec), UlpSum(UlpSum), addValPairWithErr, subValPairWithErr, addValWithErr, ulpVal, subVal, addVecPair, subVecPair, mulScalarVecWithErr, divVecScalarWithErr, scalarPart, vectorPart, (•), (∧), (⋅), (⎣), (⎤)) +import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(GEZero, GEPlus, G0), GVal(GVal), GVec(GVec), UlpSum(UlpSum), addValPairWithErr, subValPairWithErr, addValWithErr, ulpRaw, ulpVal, subVal, addVecPair, subVecPair, mulScalarVecWithErr, divVecScalarWithErr, scalarPart, vectorPart, (•), (∧), (⋅), (⎣), (⎤)) import Graphics.Slicer.Math.Intersections (outputIntersectsLineSeg) @@ -82,8 +85,8 @@ import Graphics.Slicer.Machine.Infill (InfillType(Horiz, Vert), makeInfill) -- Our Facet library. import Graphics.Slicer.Math.Arcs (getOutsideArc, towardIntersection) import Graphics.Slicer.Math.Skeleton.Cells (findFirstCellOfContour, findDivisions, findNextCell) -import Graphics.Slicer.Math.Skeleton.Concave (makeENode, makeENodes, averageNodes) -import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle), RemainingContour(RemainingContour), Spine(Spine), StraightSkeleton(StraightSkeleton), INode(INode), Cell(Cell), getFirstLineSeg, getLastLineSeg) +import Graphics.Slicer.Math.Skeleton.Concave (makeENode, makeENodes) +import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle), RemainingContour(RemainingContour), Spine(Spine), StraightSkeleton(StraightSkeleton), Cell(Cell), getFirstLineSeg, getLastLineSeg) import Graphics.Slicer.Math.Skeleton.Face (Face(Face), facesOf, orderedFacesOf) import Graphics.Slicer.Math.Skeleton.Line (addInset) import Graphics.Slicer.Math.Skeleton.Motorcycles (convexMotorcycles, crashMotorcycles, CrashTree(CrashTree)) @@ -407,7 +410,7 @@ prop_AxisProjection v xAxis whichDirection dv -- A property test making sure than for any LineSeg, a pointOnPerp is in fact on a 90 degree perpendicular line. prop_perpAt90Degrees :: ℝ -> ℝ -> Positive ℝ -> ℝ -> NonZero ℝ -> Bool prop_perpAt90Degrees x y rawX2 y2 rawD - | angle2 < realToFrac errTotal4 = True + | angle2 < errTotal4 = True | otherwise = error $ "wrong angle?\n" <> "pline3Err: " <> show pline3Err <> "\n" @@ -422,9 +425,9 @@ prop_perpAt90Degrees x y rawX2 y2 rawD <> "angle2Err: " <> show angle2Err <> "\n" where (angle2, (_,_, angle2Err)) = angleBetween2PL normedPLine3 normedPLine4 - (PPoint2 rawBisectorStart, bisectorStartErr) = interpolate2PP sourceStart sourceEnd 0.5 0.5 - (bisectorEndRaw, bisectorEndRawErr) = pPointOnPerpWithErr pline4 (PPoint2 rawBisectorStart) d - (bisectorEnd, bisectorEndErr) = canonicalizeP bisectorEndRaw + (PPoint2 rawBisectorStart, _) = interpolate2PP sourceStart sourceEnd 0.5 0.5 + (bisectorEndRaw, _) = pPointOnPerpWithErr pline4 (PPoint2 rawBisectorStart) d + (bisectorEnd, _) = canonicalizeP bisectorEndRaw (pline3, pline3Err) = join2PP (CPPoint2 rawBisectorStart) bisectorEnd (normedPLine3, norm3Err) = normalizeL pline3 sourceStart = makePPoint2 x y @@ -485,9 +488,9 @@ prop_PerpTranslateID x y dx dy rawT res = distanceBetweenPLines resPLine origPLine (resPLine, resPLineErr) = translateL translatedPLine (-t) (translatedPLine, translatedPLineErr) = translateL origPLine t - (origPLine, origPLineErr) = randomPLineWithErr x y dx dy + (origPLine, _) = randomPLineWithErr x y dx dy resErr, t :: ℝ - resErr = realToFrac $ ulpVal $ fuzzinessOfL (resPLine, resPLineErr) <> fuzzinessOfL (translatedPLine, translatedPLineErr) + resErr = ulpVal $ fuzzinessOfL (resPLine, resPLineErr) <> fuzzinessOfL (translatedPLine, translatedPLineErr) t = coerce rawT pgaSpec :: Spec @@ -583,8 +586,8 @@ prop_QuadBisectorCrossesMultiple rawX1 rawY1 rawX2 rawY2 rawTimes intersect3 = outputIntersectsLineSeg eNode lineSeg1 intersect4 = outputIntersectsLineSeg eNode lineSeg2 -- note that our bisector always intersects the origin. - (bisector1, bisector1ErrRaw) = normalizeL bisector - (bisector, bisectorErr) = eToPL $ makeLineSeg (Point2 (0,0)) (Point2 (x3,y3)) + (bisector1, _) = normalizeL bisector + (bisector, _) = eToPL $ makeLineSeg (Point2 (0,0)) (Point2 (x3,y3)) eNode = makeENode (Point2 (x1,y1)) (Point2 (0,0)) (Point2 (x2,y2)) -- X1, Y1 and X2 forced uniqueness. additionally, forced "not 180 degree opposition). x1,y1,x2,y2,times :: ℝ @@ -725,7 +728,7 @@ prop_LineSegIntersectionStableAtX1Y1Point pointD rawD1 x1 y1 rawX2 rawY2 -- | A checker, to ensure an angle is what is expected. myAngleBetween :: NPLine2 -> NPLine2 -> Bool myAngleBetween a b - | realToFrac res + (ulpVal resErr) >= 1.0-(ulpVal resErr) = True + | realToFrac res + (ulpRaw resErr) >= 1.0-(ulpRaw resErr) = True | otherwise = error $ "angle wrong?\n" <> show a <> "\n" @@ -1261,8 +1264,8 @@ prop_PLineWithinErrRange1 x1 y1 rawX2 rawY2 prop_PLineWithinErrRange2 :: ℝ -> ℝ -> ℝ -> ℝ -> Bool prop_PLineWithinErrRange2 x1 y1 rawX2 rawY2 - | distance1 > realToFrac (ulpVal ulpTotal1) = error $ "startPoint outside of expected range:\n" <> dumpRes - | distance2 > realToFrac (ulpVal ulpTotal2) = error $ "endPoint outside of expected range:\n" <> dumpRes + | distance1 > ulpVal ulpTotal1 = error $ "startPoint outside of expected range:\n" <> dumpRes + | distance2 > ulpVal ulpTotal2 = error $ "endPoint outside of expected range:\n" <> dumpRes | otherwise = True where dumpRes = "distance1: " <> show distance1 <> "\n" @@ -1283,7 +1286,6 @@ prop_PLineWithinErrRange2 x1 y1 rawX2 rawY2 pPoint1 = makePPoint2 x1 y1 pPoint2 = makePPoint2 x2 y2 (pLine1, (_,_,pLine1Err)) = join2PP pPoint1 pPoint2 - ulpTotal1, ulpTotal2 :: UlpSum ulpTotal1 = distance1Err <> pLineErrAtPPoint (pLine1, pLine1Err) pPoint1 ulpTotal2 = distance2Err <> pLineErrAtPPoint (pLine1, pLine1Err) pPoint2 -- make sure we do not try to create a 0 length line segment. @@ -1336,7 +1338,7 @@ prop_obtuseBisectorOnBiggerSide_makeENode x y d1 rawR1 d2 rawR2 testFirstLine bisector = (flipL $ outOf eNode, errOfOut eNode) prop_obtuseBisectorOnBiggerSide_makeINode :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> Positive ℝ -> Radian ℝ -> Bool -> Bool -> Expectation -prop_obtuseBisectorOnBiggerSide_makeINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 = (angleFound > realToFrac (1-(ulpVal angleErr)), angleFound < realToFrac (-1 + (ulpVal angleErr) :: Rounded 'TowardInf ℝ)) --> (True, False) +prop_obtuseBisectorOnBiggerSide_makeINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 = (angleFound > (1-ulpVal angleErr), angleFound < realToFrac (-1 + (ulpRaw angleErr) :: Rounded 'TowardInf ℝ)) --> (True, False) where (angleFound, (_,_, angleErr)) = angleBetween2PL bisector1 bisector2 eNode = randomENode x y d1 rawR1 d2 rawR2 @@ -1388,7 +1390,6 @@ prop_PLinesIntersectAtOrigin rawX y rawX2 rawY2 (intersectionPPoint2, (_,_,intersectionErr)) = intersect2PL randomPLine1 randomPLine2 (randomPLine1, _) = randomPLineThroughOrigin x y (randomPLine2, _) = randomPLineThroughOrigin x2 y2 - (_, canonicalizationErr) = canonicalizeP intersectionPPoint2 errSum = distanceErr -- + canonicalizationErr x,x2,y2 :: ℝ x = coerce rawX @@ -1416,7 +1417,6 @@ prop_PLinesIntersectAtPoint rawX y rawX2 rawY2 targetX targetY (intersectionPPoint2, (_,_, intersectionErr)) = intersect2PL randomPLine1 randomPLine2 (randomPLine1, _) = randomPLineWithErr x y targetX targetY (randomPLine2, _) = randomPLineWithErr x2 y2 targetX targetY - (_, canonicalizationErr) = canonicalizeP intersectionPPoint2 errSum = distanceErr -- + canonicalizationErr x,x2,y2 :: ℝ x = coerce rawX @@ -1433,7 +1433,7 @@ prop_PLineIntersectsAtXAxis x y rawX2 y2 m | isNothing axisIntersection = True -- Ignore the case where the random PLine is colinear to the X axis. | isLeft $ fst $ fromJust axisIntersection = True - | foundDistance < realToFrac errSum = True + | foundDistance < errSum = True | otherwise = error $ "wtf\n" <> show foundDistance <> "\n" @@ -1459,7 +1459,7 @@ prop_PLineIntersectsAtYAxis x y x2 rawY2 m | isNothing axisIntersection = True -- Ignore the case where the random PLine is colinear to the X axis. | isLeft $ fst $ fromJust axisIntersection = True - | foundDistance < realToFrac errSum = True + | foundDistance < errSum = True | otherwise = error $ "wtf\n" <> show foundDistance <> "\n" @@ -1891,11 +1891,11 @@ facetSpec = do -- ~~~ <-- corner 3 -- ^-- corner 4 -- the top and the left side. - c2c2E1 = makeENode (Point2 (1.0,1.0)) (Point2 (-1.0,1.0)) (Point2 (-1.0,-1.0)) +-- c2c2E1 = makeENode (Point2 (1.0,1.0)) (Point2 (-1.0,1.0)) (Point2 (-1.0,-1.0)) -- the left and the bottom side. - c2c3E1 = makeENode (Point2 (-1.0,1.0)) (Point2 (-1.0,-1.0)) (Point2 (1.0,-1.0)) +-- c2c3E1 = makeENode (Point2 (-1.0,1.0)) (Point2 (-1.0,-1.0)) (Point2 (1.0,-1.0)) -- the bottom and the entrance to the convex angle. - c2c4E1 = makeENode (Point2 (-1.0,-1.0)) (Point2 (1.0,-1.0)) (Point2 (0.0,0.0)) +-- c2c4E1 = makeENode (Point2 (-1.0,-1.0)) (Point2 (1.0,-1.0)) (Point2 (0.0,0.0)) -- The next corners are part of a 2x2 square around the origin with a slice and a corner missing: (c7 from above) -- v----- corner 2 -- ┌───┐ ┌─┐<-- corner 1 @@ -1903,7 +1903,7 @@ facetSpec = do -- └───┐ │ -- │ │ -- └───┘ - c7c1E1 = makeENode (Point2 (1.0,-1.0)) (Point2 (1.0,1.0)) (Point2 (0.5,1.0)) - c7c2E1 = makeENode (Point2 (1.0,1.0)) (Point2 (0.5,1.0)) (Point2 (0.5,0.0)) +-- c7c1E1 = makeENode (Point2 (1.0,-1.0)) (Point2 (1.0,1.0)) (Point2 (0.5,1.0)) +-- c7c2E1 = makeENode (Point2 (1.0,1.0)) (Point2 (0.5,1.0)) (Point2 (0.5,0.0)) -- A simple triangle. triangle = makePointContour [Point2 (2,0), Point2 (1.0,sqrt 3), Point2 (0,0)] From 308dae260c1af03304a462615384da3a6a908e6e Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Thu, 22 Dec 2022 22:42:49 +0000 Subject: [PATCH 167/206] precision increases, and spacing fixes. --- Graphics/Slicer/Math/Arcs.hs | 12 ++++++------ Graphics/Slicer/Math/Contour.hs | 2 +- Graphics/Slicer/Math/GeometricAlgebra.hs | 2 +- Graphics/Slicer/Math/Intersections.hs | 4 ++-- Graphics/Slicer/Math/PGA.hs | 13 +++---------- Graphics/Slicer/Math/PGAPrimitives.hs | 14 +++++++++----- Graphics/Slicer/Math/RandomGeometry.hs | 7 +++---- 7 files changed, 25 insertions(+), 29 deletions(-) diff --git a/Graphics/Slicer/Math/Arcs.hs b/Graphics/Slicer/Math/Arcs.hs index 9d3b8d8fd..5ced5d88b 100644 --- a/Graphics/Slicer/Math/Arcs.hs +++ b/Graphics/Slicer/Math/Arcs.hs @@ -95,13 +95,13 @@ getObtuseAngleBisectorFromPointedLines ppoint1 line1 ppoint2 line2 | noIntersection line1 line2 = error $ "No intersection between line " <> show line1 <> " and line " <> show line2 <> ".\n" | pointDistance <= ulpVal pointDistanceErr = error $ "cannot have two identical input points:\n" <> show ppoint1 <> "\n" <> show ppoint2 <> "\n" | point1IntersectDistance <= ulpVal point1IntersectDistanceErr = error $ "intersection of plines is at first ppoint:\n" - <> show ppoint1 <> "\n" - <> show line1 <> "\n" - <> show line2 <> "\n" + <> show ppoint1 <> "\n" + <> show line1 <> "\n" + <> show line2 <> "\n" | point2IntersectDistance <= ulpVal point2IntersectDistanceErr = error $ "intersection of plines is at second ppoint:\n" - <> show ppoint2 <> "\n" - <> show line1 <> "\n" - <> show line2 <> "\n" + <> show ppoint2 <> "\n" + <> show line1 <> "\n" + <> show line2 <> "\n" | l1TowardPoint && l2TowardPoint = flipFst $ getAcuteAngleBisectorFromLines line1 $ flipFst line2 | l1TowardPoint = flipFst $ getAcuteAngleBisectorFromLines line1 line2 | l2TowardPoint = getAcuteAngleBisectorFromLines line1 line2 diff --git a/Graphics/Slicer/Math/Contour.hs b/Graphics/Slicer/Math/Contour.hs index 6ce2cc287..f9ce9f06e 100644 --- a/Graphics/Slicer/Math/Contour.hs +++ b/Graphics/Slicer/Math/Contour.hs @@ -46,7 +46,7 @@ import Graphics.Implicit.Definitions (ℝ) import Graphics.Slicer.Math.ContourIntersections (contourIntersectionCount) -import Graphics.Slicer.Math.Definitions (Contour(PointContour, LineSegContour), Point2(Point2), LineSeg(endPoint, startPoint), fudgeFactor, lineSegsOfContour, makeLineSeg, minMaxPoints, xOf, yOf) +import Graphics.Slicer.Math.Definitions (Contour(PointContour, LineSegContour), LineSeg(endPoint, startPoint), Point2(Point2), fudgeFactor, lineSegsOfContour, makeLineSeg, minMaxPoints, xOf, yOf) import Graphics.Slicer.Math.GeometricAlgebra (ulpVal) diff --git a/Graphics/Slicer/Math/GeometricAlgebra.hs b/Graphics/Slicer/Math/GeometricAlgebra.hs index df4ce9a6d..79c6311c8 100644 --- a/Graphics/Slicer/Math/GeometricAlgebra.hs +++ b/Graphics/Slicer/Math/GeometricAlgebra.hs @@ -133,7 +133,7 @@ data GRVal = GRVal newtype UlpSum = UlpSum { ulpRaw :: Rounded 'TowardInf ℝ } deriving (Show, Eq, Generic, NFData, Ord) --- provide a value extractor directly to ℝ, which is a newtype of Double. +-- | A value extractor directly to ℝ, which is a newtype of Double. ulpVal :: UlpSum -> ℝ ulpVal = getRounded . ulpRaw diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index 763a5cfac..51cc42a79 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -34,9 +34,9 @@ module Graphics.Slicer.Math.Intersections ( outputIntersectsPLineAt ) where -import Prelude (Bool(True), Either(Left, Right), (<>), ($), (<), (||), (==), (&&), (<$>), (<=), and, error, show, otherwise) +import Prelude (Bool(True), (<>), ($), (<), (||), (==), (&&), (<$>), (<=), and, error, otherwise, show) -import Data.Either (rights, lefts) +import Data.Either (Either(Left, Right), lefts, rights) import Data.Maybe (Maybe(Just, Nothing), catMaybes, isJust, isNothing) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 8cc4d642f..d4efa9126 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -19,6 +19,7 @@ -- for adding Generic and NFData to our types. {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} +-- for using Rounded flexibly. {-# LANGUAGE DataKinds #-} -- | The purpose of this file is to hold projective geometric algebraic arithmatic. It defines a 2D PGA with mixed linear components. @@ -142,7 +143,6 @@ plinesIntersectIn (pl1, pl1Err) (pl2, pl2Err) | otherwise = IntersectsIn res (pl1Err <> npl1Err, pl2Err <> npl2Err, resErr) where -- | The distance within which we consider (anti)parallel lines to be (anti)colinear. - parallelFuzziness :: ℝ parallelFuzziness = ulpVal $ dErr <> pLineErrAtPPoint (npl1, npl1Err <> pl1Err) res <> pLineErrAtPPoint (npl2, npl2Err <> pl2Err) res -- | When two lines are really close to parallel or antiparallel, we use the distance between the lines to decide whether to promote them to being (anti)colinear. (d, (_, _, dErr)) = distance2PL npl1 npl2 @@ -160,7 +160,6 @@ pLineIsLeft (pl1, _) (pl2, _) | abs res <= angleFuzz = Nothing | otherwise = Just $ res > 0 where - angleFuzz :: ℝ angleFuzz = ulpVal angleFuzzRaw (res, (_,_, angleFuzzRaw)) = angleCosBetween2PL pl1 pl2 (npl1, _) = normalizeL pl1 @@ -198,11 +197,8 @@ pPointsOnSameSideOfPLine point1 point2 line abs foundP2 < foundErr2 = Nothing | otherwise = Just $ signum foundP1 == signum foundP2 where - foundErr1, foundErr2 :: ℝ - foundErr1 = realToFrac $ ulpRaw (eValOf mempty (getVal [GEZero 1, GEPlus 1, GEPlus 2] unlikeP1AddErr)) + - ulpRaw (eValOf mempty (getVal [GEZero 1, GEPlus 1, GEPlus 2] unlikeP1MulErr)) - foundErr2 = realToFrac $ ulpRaw (eValOf mempty (getVal [GEZero 1, GEPlus 1, GEPlus 2] unlikeP2AddErr)) + - ulpRaw (eValOf mempty (getVal [GEZero 1, GEPlus 1, GEPlus 2] unlikeP2MulErr)) + foundErr1 = ulpVal $ eValOf mempty (getVal [GEZero 1, GEPlus 1, GEPlus 2] unlikeP1AddErr) <> eValOf mempty (getVal [GEZero 1, GEPlus 1, GEPlus 2] unlikeP1MulErr) + foundErr2 = ulpVal $ eValOf mempty (getVal [GEZero 1, GEPlus 1, GEPlus 2] unlikeP2AddErr) <> eValOf mempty (getVal [GEZero 1, GEPlus 1, GEPlus 2] unlikeP2MulErr) foundP1 = valOf 0 $ getVal [GEZero 1, GEPlus 1, GEPlus 2] unlikeP1 foundP2 = valOf 0 $ getVal [GEZero 1, GEPlus 1, GEPlus 2] unlikeP2 (GVec unlikeP1, (unlikeP1MulErr, unlikeP1AddErr)) = pv1 ⎤+ lv1 @@ -352,7 +348,6 @@ pLineIntersectsLineSeg (pl1, pl1ErrOrigin) l1 | otherwise = Left $ NoIntersection ((\(PPoint2 v) -> CPPoint2 v) rawIntersect) (pl1Err, pl2Err, rawIntersectErr) where res = plinesIntersectIn (pl1, pl1Err) (pl2, pl2Err) - ulpStartSum, ulpEndSum :: ℝ ulpStartSum = ulpVal startDistanceErr ulpEndSum = ulpVal endDistanceErr (startDistance, (_,_, startDistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (start, mempty) @@ -408,10 +403,8 @@ lineSegIntersectsLineSeg l1 l2 end1FudgeFactor = end1DistanceErr <> pLineErrAtPPoint (pl1,pl1Err) end1 start2FudgeFactor = start2DistanceErr <> pLineErrAtPPoint (pl2,pl2Err) start2 end2FudgeFactor = end2DistanceErr <> pLineErrAtPPoint (pl2,pl2Err) end2 - ulpStart1Sum, ulpEnd1Sum :: ℝ ulpStart1Sum = ulpVal start1DistanceErr ulpEnd1Sum = ulpVal end1DistanceErr - ulpStart2Sum, ulpEnd2Sum :: ℝ ulpStart2Sum = ulpVal start2DistanceErr ulpEnd2Sum = ulpVal end2DistanceErr (start1Distance, (_,_, start1DistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (start1, mempty) diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index b3e8bb605..c00a241cf 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -19,6 +19,9 @@ -- for adding Generic and NFData to our types. {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} +-- for using Rounded flexibly. +{-# LANGUAGE DataKinds #-} + -- | The purpose of this file is to hold primitive projective geometric algebraic arithmatic. -- Primitives here are defined as functions that work on types which have an implementation of the ProjectivePoint2 or ProjectiveLine2 typeclasses. Think "Pure 2D PGA functions only". @@ -82,6 +85,8 @@ import Graphics.Slicer.Math.Definitions (Point2(Point2)) import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎣+), (⎤+), (∧), (•), addErr, addValWithoutErr, addVecPairWithErr, addVecPairWithoutErr, divVecScalarWithErr, eValOf, getVal, mulScalarVecWithErr, scalarPart, sumErrVals, ulpRaw, ulpVal, valOf) +import Numeric.Rounded.Hardware (Rounded, RoundingMode(TowardNegInf), getRounded) + -------------------------------- --- common support functions --- -------------------------------- @@ -392,11 +397,10 @@ pLineErrAtPPoint (line, lineErr) errPoint && fromRight 0 (fst $ fromJust $ yIntercept (nPLine, nPLineErr)) /= 0 xInterceptFuzz = UlpSum $ ulpRaw rawXInterceptFuzz * ( realToFrac $ xMax / (sqrt (xMin*xMin*yMax*yMax))) * realToFrac (abs xPos) yInterceptFuzz = UlpSum $ ulpRaw rawYInterceptFuzz * ( realToFrac $ yMax / (sqrt (xMax*xMax*yMin*yMin))) * realToFrac (abs yPos) - xMin, xMax, yMin, yMax :: ℝ - xMax = xInterceptDistance + ulpVal rawXInterceptFuzz - yMax = yInterceptDistance + ulpVal rawYInterceptFuzz - xMin = xInterceptDistance - ulpVal rawXInterceptFuzz - yMin = yInterceptDistance - ulpVal rawYInterceptFuzz + xMax = ulpVal $ UlpSum (realToFrac xInterceptDistance) <> rawXInterceptFuzz + yMax = ulpVal $ UlpSum (realToFrac yInterceptDistance) <> rawYInterceptFuzz + xMin = getRounded $ realToFrac xInterceptDistance - (realToFrac (ulpVal rawXInterceptFuzz) :: Rounded 'TowardNegInf ℝ) + yMin = getRounded $ realToFrac yInterceptDistance - (realToFrac (ulpVal rawYInterceptFuzz) :: Rounded 'TowardNegInf ℝ) rawYInterceptFuzz = snd $ fromJust $ yIntercept (nPLine, nPLineErr) rawXInterceptFuzz = snd $ fromJust $ xIntercept (nPLine, nPLineErr) yInterceptDistance = abs $ fromRight 0 $ fst $ fromJust $ xIntercept (nPLine, nPLineErr) diff --git a/Graphics/Slicer/Math/RandomGeometry.hs b/Graphics/Slicer/Math/RandomGeometry.hs index fa2550d2b..72dba3c30 100644 --- a/Graphics/Slicer/Math/RandomGeometry.hs +++ b/Graphics/Slicer/Math/RandomGeometry.hs @@ -91,7 +91,7 @@ import Graphics.Slicer.Math.Ganja (dumpGanjas, toGanja) import Graphics.Slicer.Math.Lossy (pToEPoint2, translateRotatePPoint2) -import Graphics.Slicer.Math.PGA (PLine2(PLine2), PLine2Err, eToPL, eToPP, flipL, join2EP, normalizeL, pPointOf, NPLine2(NPLine2)) +import Graphics.Slicer.Math.PGA (PLine2, PLine2Err, eToPL, eToPP, flipL, join2EP, pPointOf) import Graphics.Slicer.Math.Skeleton.Concave (makeENode) @@ -396,7 +396,7 @@ randomENode x y d1 rawR1 d2 rawR2 = makeENode p1 intersectionPoint p2 intersectionPPoint = eToPP intersectionPoint randomINode :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> Positive ℝ -> Radian ℝ -> Bool -> Bool -> INode -randomINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 = makeINode [maybeFlippedpl1,maybeFlippedpl2] (Just $ (\(NPLine2 a,b) -> (PLine2 a,b <> outsideResErr)) bisector1) +randomINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 = makeINode [maybeFlippedpl1,maybeFlippedpl2] (Just outsideRes) where r1 = rawR1 / 2 r2 = r1 + (rawR2 / 2) @@ -410,8 +410,7 @@ randomINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 = makeINode [maybeFlippedpl1,m pp2 = translateRotatePPoint2 intersectionPPoint (coerce d2) (coerce r2) maybeFlippedpl1 = (if flipIn1 then flipL pl1 else pl1, pl1Err) maybeFlippedpl2 = (if flipIn2 then flipL pl2 else pl2, pl2Err) - bisector1 = normalizeL outsideRes - (outsideRes, outsideResErr) = getOutsideArc (pp1, mempty) maybeFlippedpl1 (pp2, mempty) maybeFlippedpl2 + outsideRes = getOutsideArc (pp1, mempty) maybeFlippedpl1 (pp2, mempty) maybeFlippedpl2 -- | A helper function. constructs a random PLine. randomPLine :: ℝ -> ℝ -> NonZero ℝ -> NonZero ℝ -> PLine2 From 8184c129e78abfda01bfc3f5e796e6be6b3da4f3 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 24 Dec 2022 21:36:25 +0000 Subject: [PATCH 168/206] use Lossy functions better, and comment changes. --- Graphics/Slicer/Math/RandomGeometry.hs | 4 +- Graphics/Slicer/Math/Skeleton/Concave.hs | 24 +++++---- Graphics/Slicer/Math/Skeleton/Definitions.hs | 55 ++++++++++---------- 3 files changed, 42 insertions(+), 41 deletions(-) diff --git a/Graphics/Slicer/Math/RandomGeometry.hs b/Graphics/Slicer/Math/RandomGeometry.hs index 72dba3c30..2f0c322e9 100644 --- a/Graphics/Slicer/Math/RandomGeometry.hs +++ b/Graphics/Slicer/Math/RandomGeometry.hs @@ -396,7 +396,7 @@ randomENode x y d1 rawR1 d2 rawR2 = makeENode p1 intersectionPoint p2 intersectionPPoint = eToPP intersectionPoint randomINode :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> Positive ℝ -> Radian ℝ -> Bool -> Bool -> INode -randomINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 = makeINode [maybeFlippedpl1,maybeFlippedpl2] (Just outsideRes) +randomINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 = makeINode [maybeFlippedpl1,maybeFlippedpl2] (Just bisector) where r1 = rawR1 / 2 r2 = r1 + (rawR2 / 2) @@ -410,7 +410,7 @@ randomINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 = makeINode [maybeFlippedpl1,m pp2 = translateRotatePPoint2 intersectionPPoint (coerce d2) (coerce r2) maybeFlippedpl1 = (if flipIn1 then flipL pl1 else pl1, pl1Err) maybeFlippedpl2 = (if flipIn2 then flipL pl2 else pl2, pl2Err) - outsideRes = getOutsideArc (pp1, mempty) maybeFlippedpl1 (pp2, mempty) maybeFlippedpl2 + bisector = getOutsideArc (pp1, mempty) maybeFlippedpl1 (pp2, mempty) maybeFlippedpl2 -- | A helper function. constructs a random PLine. randomPLine :: ℝ -> ℝ -> NonZero ℝ -> NonZero ℝ -> PLine2 diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index a5c3bd4a0..d0118ea76 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -28,7 +28,7 @@ module Graphics.Slicer.Math.Skeleton.Concave (skeletonOfConcaveRegion, findINodes, makeENode, makeENodes, averageNodes, eNodesOfOutsideContour) where -import Prelude (Eq, Show, Bool(True, False), Either(Left, Right), String, Ord, Ordering(GT,LT), all, notElem, otherwise, ($), (>), (<), (<$>), (==), (/=), (>=), error, (&&), fst, (<>), show, not, max, compare, uncurry, null, (||), min, snd, filter, zip, any, (*), (+), Int, (.), (-), concatMap, mempty) +import Prelude (Eq, Show, Bool(True, False), Either(Left, Right), String, Ord, Ordering(GT,LT), all, notElem, otherwise, ($), (>), (<=), (<$>), (==), (/=), (>=), error, (&&), fst, (<>), show, not, max, compare, uncurry, null, (||), min, snd, filter, zip, any, (*), (+), Int, (.), (-), concatMap, mempty) import Prelude as PL (head, last, tail, init) @@ -56,6 +56,8 @@ import Graphics.Slicer.Math.GeometricAlgebra (ulpVal) import Graphics.Slicer.Math.Intersections (intersectionOf, intersectionBetweenArcsOf, intersectionsAtSamePoint, isAntiCollinear, isAntiParallel, isCollinear, isParallel, noIntersection) +import Graphics.Slicer.Math.Lossy (distanceBetweenPPointsWithErr) + import Graphics.Slicer.Math.PGA (Arcable(errOfOut, hasArc, outOf), Pointable(canPoint), PLine2, PLine2Err, ProjectiveLine2, distance2PP, eToPL, flipL, outAndErrOf, pPointAndErrOf, pLineIsLeft) import Graphics.Slicer.Math.Skeleton.Definitions (ENode(ENode), ENodeSet(ENodeSet), INode(INode), INodeSet(INodeSet), NodeTree(NodeTree), concavePLines, getFirstLineSeg, getLastLineSeg, finalOutOf, firstInOf, getPairs, indexPLinesTo, insOf, lastINodeOf, linePairs, makeINode, sortedPLinesWithErr, isLoop) @@ -739,16 +741,16 @@ skeletonOfNodes connectedLoop origSegSets inSegSets iNodes = | isAntiParallel (outAndErrOf n1) (outAndErrOf n2) = error $ "Cannot get the average of nodes if their outputs never intersect!\n" <> errorLen3 | isCollinear (outAndErrOf n1) (outAndErrOf n2) = error $ "Cannot (yet) handle two input plines that are collinear.\n" <> errorLen3 | nodesAreAntiCollinear n1 n2 = error $ "Cannot (yet) handle two input plines that are collinear.\n" <> errorLen3 - | n1Distance < ulpVal n1Err = error $ "intersection is AT the point of n1!\n" <> show n1Distance <> "\n" <> show n2Distance <> "\n" <> show intersectionPoint <> "\n" <> show n1 <> "\n" <> show n2 <> "\n" <> errorLen3 - | n2Distance < ulpVal n2Err = error $ "intersection is AT the point of n2!\n" <> show n1Distance <> "\n" <> show n2Distance <> "\n" <> show intersectionPoint <> "\n" <> show n1 <> "\n" <> show n2 <> "\n" <> errorLen3 + | n1Distance <= ulpVal n1Err = error $ "intersection is AT the point of n1!\n" <> show n1Distance <> "\n" <> show n2Distance <> "\n" <> show intersectionPoint <> "\n" <> show n1 <> "\n" <> show n2 <> "\n" <> errorLen3 + | n2Distance <= ulpVal n2Err = error $ "intersection is AT the point of n2!\n" <> show n1Distance <> "\n" <> show n2Distance <> "\n" <> show intersectionPoint <> "\n" <> show n1 <> "\n" <> show n2 <> "\n" <> errorLen3 | n1Distance > ulpVal n1Err && n2Distance > ulpVal n2Err = averageNodes n1 n2 | otherwise = error $ "found node too close:\n" <> show n1 <> "\n" <> show n2 <> "\n" where intersectionPoint = fromMaybe (error "has arcs, but no intersection?") $ intersectionBetweenArcsOf n1 n2 - (n1Distance, (_,_, n1Err)) = distance2PP (intersectionOf (outAndErrOf n1) (outAndErrOf n2)) (pPointAndErrOf n1) - (n2Distance, (_,_, n2Err)) = distance2PP (intersectionOf (outAndErrOf n1) (outAndErrOf n2)) (pPointAndErrOf n2) + (n1Distance, (_,_, n1Err)) = distance2PP intersectionPoint (pPointAndErrOf n1) + (n2Distance, (_,_, n2Err)) = distance2PP intersectionPoint (pPointAndErrOf n2) -- | get the list of sorted pairs of intersecting nodes. shortestNeighboringPairs :: (Arcable a, Pointable a, Eq a) => [(a,a)] -> [(a, a)] @@ -806,17 +808,17 @@ skeletonOfNodes connectedLoop origSegSets inSegSets iNodes = && hasArc node1 && hasArc node2 && intersectsInPoint node1 node2 = - Just $ fst (distance2PP (pPointAndErrOf node1) (intersectionOf (outAndErrOf node1) (outAndErrOf node2))) + Just $ distanceBetweenPPointsWithErr (pPointAndErrOf node1) (intersectionOf (outAndErrOf node1) (outAndErrOf node2)) `max` - fst (distance2PP (pPointAndErrOf node2) (intersectionOf (outAndErrOf node1) (outAndErrOf node2))) + distanceBetweenPPointsWithErr (pPointAndErrOf node2) (intersectionOf (outAndErrOf node1) (outAndErrOf node2)) | otherwise = Nothing -- | Check if the intersection of two nodes results in a point or not. intersectsInPoint :: (Arcable a, Pointable a, Arcable b, Pointable b) => a -> b -> Bool intersectsInPoint node1 node2 | hasArc node1 && hasArc node2 = not (noIntersection (outAndErrOf node1) (outAndErrOf node2)) - && dist1 >= ulpVal dist1Err - && dist2 >= ulpVal dist2Err + && not (dist1 <= ulpVal dist1Err) + && not (dist2 <= ulpVal dist2Err) | otherwise = error $ "cannot intersect a node with no output:\nNode1: " <> show node1 <> "\nNode2: " <> show node2 <> "\nnodes: " <> show iNodes <> "\n" where - (dist1, (_,_,dist1Err)) = distance2PP (pPointAndErrOf node1) (intersectionOf (outAndErrOf node1) (outAndErrOf node2)) - (dist2, (_,_,dist2Err)) = distance2PP (pPointAndErrOf node2) (intersectionOf (outAndErrOf node1) (outAndErrOf node2)) + (dist1, (_,_, dist1Err)) = distance2PP (pPointAndErrOf node1) (intersectionOf (outAndErrOf node1) (outAndErrOf node2)) + (dist2, (_,_, dist2Err)) = distance2PP (pPointAndErrOf node2) (intersectionOf (outAndErrOf node1) (outAndErrOf node2)) diff --git a/Graphics/Slicer/Math/Skeleton/Definitions.hs b/Graphics/Slicer/Math/Skeleton/Definitions.hs index eadd78c16..e59057801 100644 --- a/Graphics/Slicer/Math/Skeleton/Definitions.hs +++ b/Graphics/Slicer/Math/Skeleton/Definitions.hs @@ -16,22 +16,20 @@ - along with this program. If not, see . -} -{- Purpose of this file: to hold the logic and routines required for building - a Straight Skeleton of a contour, with a set of sub-contours cut out of it. +{- Purpose of this file: +-- Hold Common types and functions used in the code responsible for generating straight skeletons of contours. -} --- inherit instances when deriving. +-- Inherit instances when deriving. {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DerivingStrategies #-} --- So we can section tuples +-- So we can section tuples. {-# LANGUAGE TupleSections #-} --- | Common types and functions used in the code responsible for generating straight skeletons. - module Graphics.Slicer.Math.Skeleton.Definitions (RemainingContour(RemainingContour), StraightSkeleton(StraightSkeleton), Spine(Spine), ENode(ENode), INode(INode), ENodeSet(ENodeSet), INodeSet(INodeSet), NodeTree(NodeTree), ancestorsOf, Motorcycle(Motorcycle), Cell(Cell), CellDivide(CellDivide), DividingMotorcycles(DividingMotorcycles), MotorcycleIntersection(WithENode, WithMotorcycle, WithLineSeg), concavePLines, getFirstLineSeg, getLastLineSeg, hasNoINodes, getPairs, linePairs, finalPLine, finalINodeOf, finalOutOf, makeINode, sortedPLines, sortedPLinesWithErr, indexPLinesTo, insOf, lastINodeOf, firstInOf, isLoop, lastInOf) where -import Prelude (Eq, Show, Bool(True, False), Ordering(LT,GT), otherwise, ($), (<$>), (==), (/=), error, (>), (&&), any, fst, (||), (<>), show, (<), (*), mempty, not) +import Prelude (Eq, Show, Bool(True, False), Ordering(LT,GT), ($), (<$>), (==), (/=), (||), (<>), (<), (*), (>), (&&), any, error, fst, mempty, not, otherwise, show) import Prelude as PL (head, last) @@ -51,13 +49,13 @@ import Slist as SL (last, head, init) import Slist.Type (Slist(Slist)) -import Graphics.Slicer.Math.Definitions (Contour, LineSeg(LineSeg), Point2, mapWithFollower, fudgeFactor, startPoint, distance, endPoint, lineSegsOfContour, makeLineSeg) +import Graphics.Slicer.Math.Definitions (Contour, LineSeg(LineSeg), Point2, distance, endPoint, fudgeFactor, lineSegsOfContour, makeLineSeg, mapWithFollower, startPoint) import Graphics.Slicer.Math.GeometricAlgebra (addVecPair) -import Graphics.Slicer.Math.Intersections (noIntersection, intersectionsAtSamePoint) +import Graphics.Slicer.Math.Intersections (intersectionsAtSamePoint, noIntersection) -import Graphics.Slicer.Math.PGA (plinesIntersectIn, PIntersection(IntersectsIn), flipL, PLine2(PLine2), PLine2Err, pLineIsLeft, Pointable(canPoint, pPointOf, ePointOf, errOfPPoint), Arcable(errOfOut, hasArc, outOf), CPPoint2(CPPoint2), PPoint2(PPoint2), eToPL, eToPP, outAndErrOf, pToEP, vecOfL, vecOfP) +import Graphics.Slicer.Math.PGA (Arcable(errOfOut, hasArc, outOf), CPPoint2(CPPoint2), PIntersection(IntersectsIn), PLine2(PLine2), PLine2Err, Pointable(canPoint, pPointOf, ePointOf, errOfPPoint), PPoint2(PPoint2), eToPL, eToPP, flipL, outAndErrOf, plinesIntersectIn, pLineIsLeft, pToEP, vecOfL, vecOfP) -- | A point where two lines segments that are part of a contour intersect, emmiting an arc toward the interior of a contour. -- FIXME: a source should have a different UlpSum for it's point and it's output. @@ -70,45 +68,44 @@ data ENode = ENode !PLine2Err deriving stock Show --- Since the PLine2 and PLine2Err are derived from the points, only check the points for Eq. +-- Since the PLine2 and PLine2Err of an ENode are derived from the input points, only check the points for Eq. instance Eq ENode where (==) (ENode points _ _) (ENode morePoints _ _) = points == morePoints (/=) a b = not $ a == b +-- | an ENode always has an arc. instance Arcable ENode where errOfOut (ENode _ _ outErr) = outErr - -- | an ENode always has an arc. hasArc _ = True outOf (ENode _ outArc _) = outArc +-- | an ENode is always resolvable to a point. instance Pointable ENode where - -- | an ENode always contains a point. canPoint _ = True ePointOf (ENode (_,centerPoint,_) _ _) = centerPoint errOfPPoint _ = mempty -- FIXME: this is going to cause double canonicalization. pPointOf a = PPoint2 $ vecOfP $ eToPP $ ePointOf a --- | A point in our straight skeleton where two arcs intersect, resulting in the creation of another arc. --- FIXME: a source should have a different UlpSum for it's point and it's output. +-- | A point in our straight skeleton where arcs intersect, resulting in the creation of another arc. data INode = INode - -- _firstInArc :: + -- The first input arc. We break out the first and second input arc to expose that we need at least two arcs to the type system. !(PLine2, PLine2Err) - -- _secondInArc :: + -- The second input arc. !(PLine2, PLine2Err) - -- _moreInArcs :: + -- More input arcs. !(Slist (PLine2, PLine2Err)) - -- _outArc :: + -- An output arc. !(Maybe (PLine2, PLine2Err)) deriving stock Show --- Since the outgoing PLine2 and PLine2Err are derived from the input arcs, only check the input arcs for Eq. +-- | Since the outgoing PLine2 and PLine2Err are derived from the input arcs, only check the input arcs for Eq. instance Eq INode where (==) (INode arcA1 arcA2 moreA _) (INode arcB1 arcB2 moreB _) = arcA1 == arcB1 && arcA2 == arcB2 && moreA == moreB (/=) a b = not $ a == b +-- | Not all INodes have an output Arc. instance Arcable INode where - -- an INode might just end here. errOfOut (INode _ _ _ outArc) = case outArc of (Just (_,rawOutErr)) -> rawOutErr Nothing -> error "tried to get an outArc that has no output arc." @@ -117,13 +114,17 @@ instance Arcable INode where (Just (rawOutArc,_)) -> rawOutArc Nothing -> error "tried to get an outArc that has no output arc." +-- | INodes are only resolvable to a point sometimes. instance Pointable INode where - -- an INode does not contain a point, we have to attempt to resolve one instead. - canPoint iNode = len (allPLinesOfINode iNode) > 1 && hasIntersectingPairs (allPLinesOfINode iNode) + -- Since an INode does not contain a point, we have to attempt to resolve one instead. + canPoint iNode = hasIntersectingPairs (allPLinesOfINode iNode) where hasIntersectingPairs (Slist pLines _) = any (\(pl1, pl2) -> not $ noIntersection pl1 pl2) $ getPairs pLines + -- just convert our resolved point. + ePointOf a = fst $ pToEP $ pPointOf a + -- FIXME: implement this properly. errOfPPoint _ = mempty - -- FIXME: if we have multiple intersecting pairs, is there a preferred pair to use for resolving? angle based, etc? + -- FIXME: if we have multiple intersecting pairs, is there a preferred pair to use for resolving? maybe a pair that is at as close as possible to a right angle? pPointOf iNode | allPointsSame = case results of [] -> error $ "cannot get a PPoint of this iNode: " <> show iNode <> "/n" @@ -139,7 +140,6 @@ instance Pointable INode where where saneIntersect (IntersectsIn a _) = Just $ (\(CPPoint2 v) -> PPoint2 v) a saneIntersect _ = Nothing - ePointOf a = fst $ pToEP $ pPointOf a -- | get all of the PLines that come from, or exit an iNode. allPLinesOfINode :: INode -> Slist (PLine2, PLine2Err) @@ -165,11 +165,10 @@ data Motorcycle = Motorcycle -- The output arc of this motorcycle. really, the motorcycle. !PLine2 -- The error quotent of the output arc. - PLine2Err + !PLine2Err deriving stock Show - --- Since the PLine2 and PLine2Err are derived from the line segments, only check them for Eq. +-- | Since the PLine2 and PLine2Err are derived from the line segments, only check them for Eq. instance Eq Motorcycle where (==) (Motorcycle segsA _ _) (Motorcycle segsB _ _) = segsA == segsB (/=) a b = not $ a == b From 8ebdd12c015033613330d26d3b644f33d651b32c Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 25 Dec 2022 22:02:48 +0000 Subject: [PATCH 169/206] use isEmpty instead of len, and formatting changes. --- Graphics/Slicer/Math/Skeleton/Definitions.hs | 22 ++++++++++---------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/Graphics/Slicer/Math/Skeleton/Definitions.hs b/Graphics/Slicer/Math/Skeleton/Definitions.hs index e59057801..99563c796 100644 --- a/Graphics/Slicer/Math/Skeleton/Definitions.hs +++ b/Graphics/Slicer/Math/Skeleton/Definitions.hs @@ -17,7 +17,7 @@ -} {- Purpose of this file: --- Hold Common types and functions used in the code responsible for generating straight skeletons of contours. + To hold common types and functions used in the code responsible for generating straight skeletons of contours. -} -- Inherit instances when deriving. @@ -29,7 +29,7 @@ module Graphics.Slicer.Math.Skeleton.Definitions (RemainingContour(RemainingContour), StraightSkeleton(StraightSkeleton), Spine(Spine), ENode(ENode), INode(INode), ENodeSet(ENodeSet), INodeSet(INodeSet), NodeTree(NodeTree), ancestorsOf, Motorcycle(Motorcycle), Cell(Cell), CellDivide(CellDivide), DividingMotorcycles(DividingMotorcycles), MotorcycleIntersection(WithENode, WithMotorcycle, WithLineSeg), concavePLines, getFirstLineSeg, getLastLineSeg, hasNoINodes, getPairs, linePairs, finalPLine, finalINodeOf, finalOutOf, makeINode, sortedPLines, sortedPLinesWithErr, indexPLinesTo, insOf, lastINodeOf, firstInOf, isLoop, lastInOf) where -import Prelude (Eq, Show, Bool(True, False), Ordering(LT,GT), ($), (<$>), (==), (/=), (||), (<>), (<), (*), (>), (&&), any, error, fst, mempty, not, otherwise, show) +import Prelude (Eq, Show, Bool(True, False), Ordering(LT,GT), ($), (<$>), (==), (/=), (||), (<>), (<), (*), (&&), any, error, fst, mempty, not, otherwise, show) import Prelude as PL (head, last) @@ -43,7 +43,7 @@ import Data.List.Unique (count_) import Data.Maybe (Maybe(Just,Nothing), isJust, mapMaybe) -import Slist (len, slist, isEmpty, safeLast) +import Slist (isEmpty, safeLast, slist) import Slist as SL (last, head, init) @@ -60,7 +60,7 @@ import Graphics.Slicer.Math.PGA (Arcable(errOfOut, hasArc, outOf), CPPoint2(CPPo -- | A point where two lines segments that are part of a contour intersect, emmiting an arc toward the interior of a contour. -- FIXME: a source should have a different UlpSum for it's point and it's output. data ENode = ENode - -- Input points. three points in order, with the inside of the contour to the left. + -- Input points. three points in order, with the inside of the contour to the left. !(Point2, Point2, Point2) -- The projective line eminating from the middle point. refered to as an Arc. !PLine2 @@ -68,7 +68,7 @@ data ENode = ENode !PLine2Err deriving stock Show --- Since the PLine2 and PLine2Err of an ENode are derived from the input points, only check the points for Eq. +-- | Since the PLine2 and PLine2Err of an ENode are derived from the input points, only check the points for Eq. instance Eq ENode where (==) (ENode points _ _) (ENode morePoints _ _) = points == morePoints (/=) a b = not $ a == b @@ -84,7 +84,7 @@ instance Pointable ENode where canPoint _ = True ePointOf (ENode (_,centerPoint,_) _ _) = centerPoint errOfPPoint _ = mempty - -- FIXME: this is going to cause double canonicalization. + -- FIXME: this causes double canonicalization. pPointOf a = PPoint2 $ vecOfP $ eToPP $ ePointOf a -- | A point in our straight skeleton where arcs intersect, resulting in the creation of another arc. @@ -160,7 +160,7 @@ lastINodeOf (INodeSet gens) = case unsnoc (SL.last gens) of -- Motorcycles are emitted from convex (reflex) virtexes of the encircling contour, and concave virtexes of any holes. -- FIXME: Note that a new motorcycle may be created in the case of degenerate polygons... with it's inSegs being two other motorcycles. data Motorcycle = Motorcycle - -- The two line segments from which this motorcycle projects + -- The two line segments from which this motorcycle projects. !(LineSeg, LineSeg) -- The output arc of this motorcycle. really, the motorcycle. !PLine2 @@ -174,9 +174,9 @@ instance Eq Motorcycle where (/=) a b = not $ a == b instance Arcable Motorcycle where + errOfOut (Motorcycle _ _ outErr) = outErr -- A Motorcycle always has an arc, which is it's path. hasArc _ = True - errOfOut (Motorcycle _ _ outErr) = outErr outOf (Motorcycle _ outArc _) = outArc instance Pointable Motorcycle where @@ -293,7 +293,7 @@ makeINode pLines maybeOut = case pLines of -- | Get the output of the given nodetree. fails if the nodetree has no output. finalPLine :: NodeTree -> (PLine2, PLine2Err) finalPLine (NodeTree (ENodeSet (Slist [(firstENode,moreENodes)] _)) iNodeSet) - | hasNoINodes iNodeSet = if len moreENodes == 0 + | hasNoINodes iNodeSet = if isEmpty moreENodes then outAndErrOf firstENode else error "cannot have final PLine of NodeTree with more than one ENode, and no generations!\n" | hasArc (finalINodeOf iNodeSet) = outAndErrOf $ finalINodeOf iNodeSet @@ -367,8 +367,8 @@ indexPLinesTo firstPLine pLines = pLinesBeforeIndex firstPLine pLines <> pLinesA -- | find the last PLine of an INode. lastInOf :: INode -> PLine2 lastInOf (INode _ secondPLine morePLines _) - | len morePLines == 0 = fst $ secondPLine - | otherwise = fst $ SL.last morePLines + | isEmpty morePLines = fst $ secondPLine + | otherwise = fst $ SL.last morePLines -- | find the first PLine of an INode. firstInOf :: INode -> PLine2 From ce1e8ebb3608c6cb9f2f50be86cf14481e2d4edb Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Mon, 26 Dec 2022 13:47:57 +0000 Subject: [PATCH 170/206] normalize comments. --- Graphics/Slicer/Math/Skeleton/Concave.hs | 6 +-- Graphics/Slicer/Math/Skeleton/Definitions.hs | 45 ++++++++++---------- 2 files changed, 26 insertions(+), 25 deletions(-) diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index d0118ea76..484d7e4ed 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -28,7 +28,7 @@ module Graphics.Slicer.Math.Skeleton.Concave (skeletonOfConcaveRegion, findINodes, makeENode, makeENodes, averageNodes, eNodesOfOutsideContour) where -import Prelude (Eq, Show, Bool(True, False), Either(Left, Right), String, Ord, Ordering(GT,LT), all, notElem, otherwise, ($), (>), (<=), (<$>), (==), (/=), (>=), error, (&&), fst, (<>), show, not, max, compare, uncurry, null, (||), min, snd, filter, zip, any, (*), (+), Int, (.), (-), concatMap, mempty) +import Prelude (Eq, Show, Bool(True, False), Either(Left, Right), String, Ord, Ordering(GT,LT), all, notElem, otherwise, ($), (>), (<=), (<$>), (==), (/=), error, (&&), fst, (<>), show, not, max, compare, uncurry, null, (||), min, snd, filter, zip, any, (*), (+), Int, (.), (-), concatMap, mempty) import Prelude as PL (head, last, tail, init) @@ -820,5 +820,5 @@ skeletonOfNodes connectedLoop origSegSets inSegSets iNodes = && not (dist2 <= ulpVal dist2Err) | otherwise = error $ "cannot intersect a node with no output:\nNode1: " <> show node1 <> "\nNode2: " <> show node2 <> "\nnodes: " <> show iNodes <> "\n" where - (dist1, (_,_, dist1Err)) = distance2PP (pPointAndErrOf node1) (intersectionOf (outAndErrOf node1) (outAndErrOf node2)) - (dist2, (_,_, dist2Err)) = distance2PP (pPointAndErrOf node2) (intersectionOf (outAndErrOf node1) (outAndErrOf node2)) + (dist1, (_,_, dist1Err)) = distance2PP (intersectionOf (outAndErrOf node1) (outAndErrOf node2)) (pPointAndErrOf node1) + (dist2, (_,_, dist2Err)) = distance2PP (intersectionOf (outAndErrOf node1) (outAndErrOf node2)) (pPointAndErrOf node2) diff --git a/Graphics/Slicer/Math/Skeleton/Definitions.hs b/Graphics/Slicer/Math/Skeleton/Definitions.hs index 99563c796..301ae0368 100644 --- a/Graphics/Slicer/Math/Skeleton/Definitions.hs +++ b/Graphics/Slicer/Math/Skeleton/Definitions.hs @@ -73,13 +73,13 @@ instance Eq ENode where (==) (ENode points _ _) (ENode morePoints _ _) = points == morePoints (/=) a b = not $ a == b --- | an ENode always has an arc. +-- | An ENode always has an arc. instance Arcable ENode where errOfOut (ENode _ _ outErr) = outErr hasArc _ = True outOf (ENode _ outArc _) = outArc --- | an ENode is always resolvable to a point. +-- | An ENode is always resolvable to a point. instance Pointable ENode where canPoint _ = True ePointOf (ENode (_,centerPoint,_) _ _) = centerPoint @@ -141,13 +141,13 @@ instance Pointable INode where saneIntersect (IntersectsIn a _) = Just $ (\(CPPoint2 v) -> PPoint2 v) a saneIntersect _ = Nothing --- | get all of the PLines that come from, or exit an iNode. +-- | Get all of the PLines that come from, or exit an iNode. allPLinesOfINode :: INode -> Slist (PLine2, PLine2Err) allPLinesOfINode iNode@(INode firstPLine secondPLine (Slist morePLines _) _) | hasArc iNode = slist $ nub $ (outAndErrOf iNode) : firstPLine : secondPLine : morePLines | otherwise = slist $ nub $ firstPLine : secondPLine : morePLines --- Produce a list of the inputs to a given INode. +-- | Produce a list of the inputs to a given INode. insOf :: INode -> [(PLine2, PLine2Err)] insOf (INode firstIn secondIn (Slist moreIns _) _) = firstIn:secondIn:moreIns @@ -173,14 +173,14 @@ instance Eq Motorcycle where (==) (Motorcycle segsA _ _) (Motorcycle segsB _ _) = segsA == segsB (/=) a b = not $ a == b +-- | A Motorcycle always has an arc, which is it's path. instance Arcable Motorcycle where errOfOut (Motorcycle _ _ outErr) = outErr - -- A Motorcycle always has an arc, which is it's path. hasArc _ = True outOf (Motorcycle _ outArc _) = outArc +-- | A motorcycle always contains a point. instance Pointable Motorcycle where - -- A motorcycle always contains a point. canPoint _ = True ePointOf (Motorcycle (_, LineSeg point _) _ _) = point errOfPPoint _ = mempty @@ -191,16 +191,17 @@ data DividingMotorcycles = DividingMotorcycles { firstMotorcycle :: !Motorcycle, deriving Eq deriving stock Show --- A concave region of a contour. +-- | A concave region of a contour. newtype Cell = Cell { _sides :: Slist (Slist LineSeg, Maybe CellDivide)} deriving stock Show --- | the border dividing two cells of a contour. +-- | The border dividing two cells of a contour. data CellDivide = CellDivide { _divMotorcycles :: !DividingMotorcycles, _intersects :: !MotorcycleIntersection } deriving Eq deriving stock Show --- note that if there is an ENode that is part of the division, it's anticolinear to the last motorcycle in _divMotorcycles. +-- | What the last dividing motorcycle in a cell divide intersects with. +-- Note that if the divide ends by coliding with an ENode, it's anticolinear to the last motorcycle in _divMotorcycles. data MotorcycleIntersection = WithLineSeg !LineSeg | WithENode !ENode @@ -208,7 +209,7 @@ data MotorcycleIntersection = deriving Eq deriving stock Show --- The part of a contour that remains once we trim a concave section from it. +-- | The part of a contour that remains once we trim a concave section from it. newtype RemainingContour = RemainingContour (Slist (Slist LineSeg, [CellDivide])) -- | The exterior nodes of a whole contour or just a cell of a contour. @@ -216,7 +217,7 @@ newtype ENodeSet = ENodeSet { _eNodeSides :: Slist (ENode,Slist ENode) } deriving Eq deriving stock Show --- | a set of Interior nodes that are intersections of ENodes or other INodes. +-- | A set of Interior nodes that are intersections of ENodes or other INodes. -- nodes are divided into 'generations', where each generation is a set of nodes that (may) result in the next set of nodes. the last generation always contains just one node. -- Note that not all of the outArcs in a given generation necessarilly are used in the next generation, but they must all be used by following generations in order for a nodetree to be complete. -- The last generation may not have an outArc in the case of a complete contour. @@ -252,7 +253,7 @@ getPairs (x:xs) = ((x,) <$> xs) <> getPairs xs -- Utility functions for our solvers -- --------------------------------------- --- | determine if the given line segment set contains just one loop. +-- | Determine if the given line segment set contains just one loop. isLoop :: Slist [LineSeg] -> Bool isLoop inSegSets = endPoint lastSeg == startPoint firstSeg || distance (endPoint lastSeg) (startPoint firstSeg) < (fudgeFactor*15) where @@ -262,11 +263,11 @@ isLoop inSegSets = endPoint lastSeg == startPoint firstSeg || distance (endPoint oneOrMoreSets@(Slist (_:_:_) _) -> (PL.last $ SL.last oneOrMoreSets, PL.head $ SL.head oneOrMoreSets) (Slist _ _) -> error "just one segment?" --- | get the first line segment of an ENode. +-- | Get the first line segment of an ENode. getFirstLineSeg :: ENode -> LineSeg getFirstLineSeg (ENode (p1,p2,_) _ _) = makeLineSeg p1 p2 --- | get the second line segment of an ENode. +-- | Get the second line segment of an ENode. getLastLineSeg :: ENode -> LineSeg getLastLineSeg (ENode (_,p2,p3) _ _) = makeLineSeg p2 p3 @@ -303,7 +304,7 @@ finalPLine (NodeTree _ iNodeSet) | hasArc (finalINodeOf iNodeSet) = outAndErrOf $ finalINodeOf iNodeSet | otherwise = error "has inodes, has no out, has no enodes?" --- | get the last output PLine of a NodeTree, if there is one. otherwise, Nothing. +-- | Get the last output PLine of a NodeTree, if there is one. otherwise, Nothing. finalOutOf :: NodeTree -> Maybe PLine2 finalOutOf (NodeTree eNodeSet iNodeSet) | hasNoINodes iNodeSet = case eNodeSet of @@ -312,7 +313,7 @@ finalOutOf (NodeTree eNodeSet iNodeSet) | hasArc (finalINodeOf iNodeSet) = Just $ outOf $ finalINodeOf iNodeSet | otherwise = Nothing --- | in a NodeTree, the last generation is always a single item. retrieve this item. +-- | In a NodeTree, the last generation is always a single item. retrieve this item. finalINodeOf :: INodeSet -> INode finalINodeOf (INodeSet generations) | isEmpty generations = error "cannot get final INode if there are no INodes." @@ -325,7 +326,7 @@ finalINodeOf (INodeSet generations) Nothing -> error "either infinite, or empty list" (Just val) -> val --- | strip off the latest generation of the given INodeSet. +-- | Strip off the latest generation of the given INodeSet. ancestorsOf :: INodeSet -> INodeSet ancestorsOf (INodeSet generations) | isEmpty generations = error "cannot get all but the last generation of INodes if there are no INodes." @@ -343,7 +344,7 @@ concavePLines seg1 seg2 pv2 = vecOfL $ flipL pl2 (pl2,_) = eToPL seg2 --- | check if an INodeSet is empty. +-- | Check if an INodeSet is empty. hasNoINodes :: INodeSet -> Bool hasNoINodes iNodeSet = case iNodeSet of (INodeSet (Slist _ 0)) -> True @@ -351,26 +352,26 @@ hasNoINodes iNodeSet = case iNodeSet of -- | Sort a set of PLines. yes, this is 'backwards', to match the counterclockwise order of contours. sortedPLines :: [PLine2] -> [PLine2] -sortedPLines = sortBy (\n1 n2 -> if ((n1, mempty) `pLineIsLeft` (n2, mempty)) == Just True then LT else GT) +sortedPLines = sortBy (\n1 n2 -> if (n1, mempty) `pLineIsLeft` (n2, mempty) == Just True then LT else GT) -- | Sort a set of PLines. yes, this is 'backwards', to match the counterclockwise order of contours. sortedPLinesWithErr :: [(PLine2, PLine2Err)] -> [(PLine2, PLine2Err)] sortedPLinesWithErr = sortBy (\n1 n2 -> if (n1 `pLineIsLeft` n2) == Just True then LT else GT) --- | take a sorted list of PLines, and make sure the list starts with the pline closest to (but not left of) the given PLine. +-- | Take a sorted list of PLines, and make sure the list starts with the pline closest to (but not left of) the given PLine. indexPLinesTo :: PLine2 -> [(PLine2, PLine2Err)] -> [(PLine2, PLine2Err)] indexPLinesTo firstPLine pLines = pLinesBeforeIndex firstPLine pLines <> pLinesAfterIndex firstPLine pLines where pLinesBeforeIndex myFirstPLine = filter (\a -> (myFirstPLine, mempty) `pLineIsLeft` a /= Just False) pLinesAfterIndex myFirstPLine = filter (\a -> (myFirstPLine, mempty) `pLineIsLeft` a == Just False) --- | find the last PLine of an INode. +-- | Find the last PLine of an INode. lastInOf :: INode -> PLine2 lastInOf (INode _ secondPLine morePLines _) | isEmpty morePLines = fst $ secondPLine | otherwise = fst $ SL.last morePLines --- | find the first PLine of an INode. +-- | Find the first PLine of an INode. firstInOf :: INode -> PLine2 firstInOf (INode a _ _ _) = fst a From 77bf640b5668048b1f7da40f3b0b472eda9816ed Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Mon, 26 Dec 2022 14:29:57 +0000 Subject: [PATCH 171/206] use eToPLine2 instead of constructing it. --- Graphics/Slicer/Math/Skeleton/Definitions.hs | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/Graphics/Slicer/Math/Skeleton/Definitions.hs b/Graphics/Slicer/Math/Skeleton/Definitions.hs index 301ae0368..78a12baa8 100644 --- a/Graphics/Slicer/Math/Skeleton/Definitions.hs +++ b/Graphics/Slicer/Math/Skeleton/Definitions.hs @@ -55,14 +55,16 @@ import Graphics.Slicer.Math.GeometricAlgebra (addVecPair) import Graphics.Slicer.Math.Intersections (intersectionsAtSamePoint, noIntersection) -import Graphics.Slicer.Math.PGA (Arcable(errOfOut, hasArc, outOf), CPPoint2(CPPoint2), PIntersection(IntersectsIn), PLine2(PLine2), PLine2Err, Pointable(canPoint, pPointOf, ePointOf, errOfPPoint), PPoint2(PPoint2), eToPL, eToPP, flipL, outAndErrOf, plinesIntersectIn, pLineIsLeft, pToEP, vecOfL, vecOfP) +import Graphics.Slicer.Math.Lossy (eToPLine2) + +import Graphics.Slicer.Math.PGA (Arcable(errOfOut, hasArc, outOf), CPPoint2(CPPoint2), PIntersection(IntersectsIn), PLine2(PLine2), PLine2Err, Pointable(canPoint, pPointOf, ePointOf, errOfPPoint), PPoint2(PPoint2), eToPL, eToPP, flipL, outAndErrOf, plinesIntersectIn, pLineIsLeft, pToEP, vecOfP) -- | A point where two lines segments that are part of a contour intersect, emmiting an arc toward the interior of a contour. -- FIXME: a source should have a different UlpSum for it's point and it's output. data ENode = ENode -- Input points. three points in order, with the inside of the contour to the left. !(Point2, Point2, Point2) - -- The projective line eminating from the middle point. refered to as an Arc. + -- The projective line eminating from the middle point, bisecting the two lines created from the input point (first-middle, last-middle). refered to as an Arc. !PLine2 -- The imprecision of the Arc. !PLine2Err @@ -116,14 +118,14 @@ instance Arcable INode where -- | INodes are only resolvable to a point sometimes. instance Pointable INode where - -- Since an INode does not contain a point, we have to attempt to resolve one instead. canPoint iNode = hasIntersectingPairs (allPLinesOfINode iNode) where hasIntersectingPairs (Slist pLines _) = any (\(pl1, pl2) -> not $ noIntersection pl1 pl2) $ getPairs pLines - -- just convert our resolved point. + -- Just convert our resolved point. ePointOf a = fst $ pToEP $ pPointOf a -- FIXME: implement this properly. errOfPPoint _ = mempty + -- Since an INode does not contain a point, we have to attempt to resolve one instead. -- FIXME: if we have multiple intersecting pairs, is there a preferred pair to use for resolving? maybe a pair that is at as close as possible to a right angle? pPointOf iNode | allPointsSame = case results of @@ -271,7 +273,7 @@ getFirstLineSeg (ENode (p1,p2,_) _ _) = makeLineSeg p1 p2 getLastLineSeg :: ENode -> LineSeg getLastLineSeg (ENode (_,p2,p3) _ _) = makeLineSeg p2 p3 --- | Get pairs of lines from the contour, including one pair that is the last line paired with the first. +-- | Get pairs of lines from a contour, including the final pair that is the last line paired with the first. linePairs :: Contour -> [(LineSeg, LineSeg)] linePairs c = mapWithFollower (,) $ lineSegsOfContour c -- FIXME: this implementation looks better, but causes code to break because of numeric instability? @@ -340,9 +342,8 @@ concavePLines seg1 seg2 | Just True == pLineIsLeft (eToPL seg1) (eToPL seg2) = Just $ PLine2 $ addVecPair pv1 pv2 | otherwise = Nothing where - (PLine2 pv1,_) = eToPL seg1 - pv2 = vecOfL $ flipL pl2 - (pl2,_) = eToPL seg2 + (PLine2 pv1) = eToPLine2 seg1 + (PLine2 pv2) = flipL $ eToPLine2 seg2 -- | Check if an INodeSet is empty. hasNoINodes :: INodeSet -> Bool From ed40b55b70dd266fc6eb0f6deb3b1a0d6baac47b Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Mon, 26 Dec 2022 15:00:36 +0000 Subject: [PATCH 172/206] eliminate eToNPLine2, use isEmpty instead of len, and use outAndErrOf. --- Graphics/Slicer/Math/Lossy.hs | 5 ----- Graphics/Slicer/Math/Skeleton/Face.hs | 11 ++++------- Graphics/Slicer/Math/Skeleton/Line.hs | 14 +++++++------- 3 files changed, 11 insertions(+), 19 deletions(-) diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index 3957889a5..47b95a42b 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -25,7 +25,6 @@ module Graphics.Slicer.Math.Lossy ( distanceBetweenPLines, distancePPointToPLine, distancePPointToPLineWithErr, - eToNPLine2, eToPLine2, getFirstArc, getInsideArc, @@ -75,10 +74,6 @@ distancePPointToPLineWithErr :: (ProjectivePoint2 a, ProjectiveLine2 b) => (a, P distancePPointToPLineWithErr point line = fst $ distancePPToPL point line --- | Create a normalized projective line from a euclidian line segment. -eToNPLine2 :: LineSeg -> NPLine2 -eToNPLine2 l1 = fst $ normalizeL $ fst $ eToPL l1 - -- | Create an un-normalized projective line from a euclidian line segment. eToPLine2 :: LineSeg -> PLine2 eToPLine2 l1 = fst $ eToPL l1 diff --git a/Graphics/Slicer/Math/Skeleton/Face.hs b/Graphics/Slicer/Math/Skeleton/Face.hs index 16bfdcaa9..7a28238de 100644 --- a/Graphics/Slicer/Math/Skeleton/Face.hs +++ b/Graphics/Slicer/Math/Skeleton/Face.hs @@ -46,7 +46,7 @@ import Graphics.Slicer.Math.Skeleton.Definitions (StraightSkeleton(StraightSkele import Graphics.Slicer.Math.Skeleton.NodeTrees (lastSegOf, findENodeByOutput, findINodeByOutput, firstSegOf, lastENodeOf, firstENodeOf, pathFirst, pathLast) -import Graphics.Slicer.Math.PGA (PLine2, PLine2Err, Arcable(hasArc, outOf), ePointOf) +import Graphics.Slicer.Math.PGA (PLine2, PLine2Err, Arcable(hasArc, outOf), ePointOf, outAndErrOf) -------------------------------------------------------------------- -------------------------- Face Placement -------------------------- @@ -73,7 +73,7 @@ orderedFacesOf start skeleton -- | take a straight skeleton, and create faces from it. facesOf :: StraightSkeleton -> Slist Face facesOf straightSkeleton@(StraightSkeleton nodeLists spine) - | len nodeLists == 0 = nodeListError + | isEmpty nodeLists = nodeListError | len nodeLists == 1 && null spine = findFaces (head nodeLists) | not $ null spine = error "cannot yet handle spines, or more than one NodeList." | otherwise = error "whoops. don't know how we got here." @@ -145,14 +145,11 @@ rotateFaces iNodeSet eNodes iNode = rTail <> [rHead] -- | Get the faces for all of the NodeTree under the given INode. -- uses a recursive resolver, and sometimes calls itsself, making it a co-recursive algorithm.. getFaces :: INodeSet -> ENodeSet -> INode -> [Face] -getFaces iNodeSet@(INodeSet myGenerations) eNodes iNode@(INode _ _ _ maybeOut) = findFacesRecurse iNode allPLines +getFaces iNodeSet@(INodeSet myGenerations) eNodes iNode = findFacesRecurse iNode allPLines where - allPLines = sortedPLinesWithErr $ insOf iNode <> out + allPLines = sortedPLinesWithErr $ insOf iNode <> if hasArc iNode then [outAndErrOf iNode] else [] where insOf (INode pLine1 pLine2 (Slist morePLines _) _) = pLine1 : pLine2 : morePLines - out = case maybeOut of - Nothing -> [] - (Just o) -> [o] firstPLine = fst $ head $ slist allPLines -- responsible for placing faces under the first pline given (if applicable), and between that pline, and the following pline. then.. recurse! findFacesRecurse :: INode -> [(PLine2, PLine2Err)] -> [Face] diff --git a/Graphics/Slicer/Math/Skeleton/Line.hs b/Graphics/Slicer/Math/Skeleton/Line.hs index ffbb930f0..45cad1764 100644 --- a/Graphics/Slicer/Math/Skeleton/Line.hs +++ b/Graphics/Slicer/Math/Skeleton/Line.hs @@ -42,7 +42,7 @@ import Graphics.Slicer.Math.Intersections (intersectionOf) import Graphics.Slicer.Math.Skeleton.Face (Face(Face)) -import Graphics.Slicer.Math.Lossy (eToNPLine2, eToPLine2, distancePPointToPLine, distancePPointToPLineWithErr, translatePLine2, pToEPoint2) +import Graphics.Slicer.Math.Lossy (eToPLine2, distancePPointToPLine, distancePPointToPLineWithErr, translatePLine2, pToEPoint2) import Graphics.Slicer.Math.PGA (PLine2, eToPL, pLineIsLeft) @@ -92,10 +92,10 @@ addLineSegsToFace distance insets face@(Face edge firstArc midArcs@(Slist rawMid -- | what is the distance from the edge to the place we can no longer place lines. distanceUntilEnd = case midArcs of - (Slist [] 0) -> distancePPointToPLine (fst $ intersectionOf (firstArc, mempty) (lastArc, mempty)) (eToNPLine2 edge) + (Slist [] 0) -> distancePPointToPLine (fst $ intersectionOf (firstArc, mempty) (lastArc, mempty)) (eToPLine2 edge) (Slist [oneArc] 1) -> if firstArcLonger - then distancePPointToPLine (fst $ intersectionOf (firstArc, mempty) (oneArc, mempty)) (eToNPLine2 edge) - else distancePPointToPLine (fst $ intersectionOf (oneArc, mempty) (lastArc, mempty)) (eToNPLine2 edge) + then distancePPointToPLine (fst $ intersectionOf (firstArc, mempty) (oneArc, mempty)) (eToPLine2 edge) + else distancePPointToPLine (fst $ intersectionOf (oneArc, mempty) (lastArc, mempty)) (eToPLine2 edge) (Slist _ _) -> closestArcDistance ----------------------------------------------------------- @@ -106,7 +106,7 @@ addLineSegsToFace distance insets face@(Face edge firstArc midArcs@(Slist rawMid [] -> error "no remains for an nSideRemainder?" -- | Find the closest point where two of our arcs intersect, relative to our side. - arcIntersections = initSafe $ mapWithFollower (\a b -> (distancePPointToPLineWithErr (intersectionOf (a, mempty) (b, mempty)) (eToNPLine2 edge, mempty), (a, b))) $ [firstArc] <> rawMidArcs <> [lastArc] + arcIntersections = initSafe $ mapWithFollower (\a b -> (distancePPointToPLineWithErr (intersectionOf (a, mempty) (b, mempty)) (eToPL edge), (a, b))) $ [firstArc] <> rawMidArcs <> [lastArc] findClosestArc :: (ℝ, (PLine2, PLine2)) findClosestArc = case sortOn fst arcIntersections of [] -> error "empty arcIntersections?" @@ -140,13 +140,13 @@ addLineSegsToFace distance insets face@(Face edge firstArc midArcs@(Slist rawMid midArc = case midArcs of (Slist [oneArc] 1) -> oneArc (Slist _ _) -> error $ "evaluated midArc with the wrong insets of items\nd: " <> show distance <> "\nn: " <> show insets <> "\nFace: " <> show face <> "\n" - threeSideRemainder = if distancePPointToPLineWithErr (intersectionOf (firstArc, mempty) (midArc, mempty)) (eToNPLine2 edge, mempty) /= distancePPointToPLineWithErr (intersectionOf (midArc, mempty) (lastArc, mempty)) (eToNPLine2 edge, mempty) + threeSideRemainder = if distancePPointToPLineWithErr (intersectionOf (firstArc, mempty) (midArc, mempty)) (eToPL edge) /= distancePPointToPLineWithErr (intersectionOf (midArc, mempty) (lastArc, mempty)) (eToPL edge) then subRemains else Nothing (subSides, subRemains) = if firstArcLonger then addLineSegsToFace distance insets (Face finalSide firstArc (slist []) midArc) else addLineSegsToFace distance insets (Face finalSide midArc (slist []) lastArc) - firstArcLonger = distancePPointToPLineWithErr (intersectionOf (firstArc, mempty) (midArc, mempty)) (eToNPLine2 edge, mempty) > distancePPointToPLineWithErr (intersectionOf (midArc,mempty) (lastArc, mempty)) (eToNPLine2 edge, mempty) + firstArcLonger = distancePPointToPLineWithErr (intersectionOf (firstArc, mempty) (midArc, mempty)) (eToPL edge) > distancePPointToPLineWithErr (intersectionOf (midArc,mempty) (lastArc, mempty)) (eToPL edge) ---------------------------------------------- -- functions only used by a three-sided n-gon. ---------------------------------------------- From adad0acb987830556c50494fc88b93d4393c4923 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Mon, 26 Dec 2022 16:15:33 +0000 Subject: [PATCH 173/206] preserve error in translation result. --- Graphics/Slicer/Math/Skeleton/Line.hs | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/Graphics/Slicer/Math/Skeleton/Line.hs b/Graphics/Slicer/Math/Skeleton/Line.hs index 45cad1764..65727f593 100644 --- a/Graphics/Slicer/Math/Skeleton/Line.hs +++ b/Graphics/Slicer/Math/Skeleton/Line.hs @@ -42,9 +42,9 @@ import Graphics.Slicer.Math.Intersections (intersectionOf) import Graphics.Slicer.Math.Skeleton.Face (Face(Face)) -import Graphics.Slicer.Math.Lossy (eToPLine2, distancePPointToPLine, distancePPointToPLineWithErr, translatePLine2, pToEPoint2) +import Graphics.Slicer.Math.Lossy (distancePPointToPLineWithErr, eToPLine2, pToEPoint2) -import Graphics.Slicer.Math.PGA (PLine2, eToPL, pLineIsLeft) +import Graphics.Slicer.Math.PGA (PLine2, eToPL, pLineIsLeft, translateL) import Graphics.Slicer.Machine.Infill (makeInfill, InfillType) @@ -77,14 +77,14 @@ addLineSegsToFace distance insets face@(Face edge firstArc midArcs@(Slist rawMid linesToRender = maybe linesUntilEnd (min linesUntilEnd) insets -- | The line segments we are placing. - foundLineSegs = [ makeLineSeg (pToEPoint2 $ fst $ intersectionOf (newSide, mempty) (firstArc, mempty)) (pToEPoint2 $ fst $ intersectionOf (newSide, mempty) (lastArc, mempty)) | newSide <- newSides ] + foundLineSegs = [ makeLineSeg (pToEPoint2 $ fst $ intersectionOf newSide (firstArc, mempty)) (pToEPoint2 $ fst $ intersectionOf newSide (lastArc, mempty)) | newSide <- newSides ] where - newSides = [ translatePLine2 (eToPLine2 edge) $ translateDir (-(distance+(distance * fromIntegral segmentNum))) | segmentNum <- [0..linesToRender-1] ] + newSides = [ translateL (eToPLine2 edge) $ translateDir (-(distance+(distance * fromIntegral segmentNum))) | segmentNum <- [0..linesToRender-1] ] -- | The line where we are no longer able to fill this face. from the firstArc to the lastArc, along the point that the lines we place stop. - finalSide = makeLineSeg (pToEPoint2 $ fst $ intersectionOf (finalLine, mempty) (firstArc, mempty)) (pToEPoint2 $ fst $ intersectionOf (finalLine, mempty) (lastArc, mempty)) + finalSide = makeLineSeg (pToEPoint2 $ fst $ intersectionOf finalLine (firstArc, mempty)) (pToEPoint2 $ fst $ intersectionOf finalLine (lastArc, mempty)) where - finalLine = translatePLine2 (eToPLine2 edge) $ translateDir (distance * fromIntegral linesToRender) + finalLine = translateL (eToPLine2 edge) $ translateDir (distance * fromIntegral linesToRender) -- | how many lines can be fit in this Face. linesUntilEnd :: Fastℕ @@ -92,10 +92,10 @@ addLineSegsToFace distance insets face@(Face edge firstArc midArcs@(Slist rawMid -- | what is the distance from the edge to the place we can no longer place lines. distanceUntilEnd = case midArcs of - (Slist [] 0) -> distancePPointToPLine (fst $ intersectionOf (firstArc, mempty) (lastArc, mempty)) (eToPLine2 edge) + (Slist [] 0) -> distancePPointToPLineWithErr (intersectionOf (firstArc, mempty) (lastArc, mempty)) (eToPL edge) (Slist [oneArc] 1) -> if firstArcLonger - then distancePPointToPLine (fst $ intersectionOf (firstArc, mempty) (oneArc, mempty)) (eToPLine2 edge) - else distancePPointToPLine (fst $ intersectionOf (oneArc, mempty) (lastArc, mempty)) (eToPLine2 edge) + then distancePPointToPLineWithErr (intersectionOf (firstArc, mempty) (oneArc, mempty)) (eToPL edge) + else distancePPointToPLineWithErr (intersectionOf (oneArc, mempty) (lastArc, mempty)) (eToPL edge) (Slist _ _) -> closestArcDistance ----------------------------------------------------------- @@ -146,7 +146,7 @@ addLineSegsToFace distance insets face@(Face edge firstArc midArcs@(Slist rawMid (subSides, subRemains) = if firstArcLonger then addLineSegsToFace distance insets (Face finalSide firstArc (slist []) midArc) else addLineSegsToFace distance insets (Face finalSide midArc (slist []) lastArc) - firstArcLonger = distancePPointToPLineWithErr (intersectionOf (firstArc, mempty) (midArc, mempty)) (eToPL edge) > distancePPointToPLineWithErr (intersectionOf (midArc,mempty) (lastArc, mempty)) (eToPL edge) + firstArcLonger = distancePPointToPLineWithErr (intersectionOf (firstArc, mempty) (midArc, mempty)) (eToPL edge) > distancePPointToPLineWithErr (intersectionOf (midArc, mempty) (lastArc, mempty)) (eToPL edge) ---------------------------------------------- -- functions only used by a three-sided n-gon. ---------------------------------------------- From cbc8be500eb68ce2c492d0b2ac46b5298d5d6704 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Mon, 26 Dec 2022 17:28:57 +0000 Subject: [PATCH 174/206] avoid some canonicalization. --- Graphics/Slicer/Math/Skeleton/Motorcycles.hs | 21 ++++++++++---------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs index b63dc34b7..2e934d606 100644 --- a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs +++ b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs @@ -50,9 +50,9 @@ import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, mapWithNeighb import Graphics.Slicer.Math.Intersections (intersectionOf, isAntiCollinear, noIntersection, outputIntersectsLineSeg) -import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, pPointBetweenPPoints, distanceBetweenPPoints, eToPLine2, normalizePLine2, pToEPoint2) +import Graphics.Slicer.Math.Lossy (pPointBetweenPPoints, distanceBetweenPPoints, eToPLine2, normalizePLine2, pToEPoint2) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), PPoint2, PPoint2Err, Arcable(outOf), Pointable(canPoint, ePointOf, pPointOf), eToPL, flipL, pLineIsLeft, pPointsOnSameSideOfPLine, PIntersection(IntersectsIn,PAntiCollinear), ProjectivePoint2, angleBetween2PL, distance2PP, eToPP, join2PP, outAndErrOf, plinesIntersectIn, translateL) +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), PPoint2, PPoint2Err, Arcable(outOf), Pointable(canPoint, ePointOf, pPointOf), eToPL, flipL, pLineIsLeft, pPointsOnSameSideOfPLine, PIntersection(IntersectsIn,PAntiCollinear), ProjectivePoint2, angleBetween2PL, canonicalizeP, distance2PP, eToPP, join2PP, outAndErrOf, plinesIntersectIn, translateL) import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle), ENode(ENode), getFirstLineSeg, linePairs, CellDivide(CellDivide), DividingMotorcycles(DividingMotorcycles), MotorcycleIntersection(WithLineSeg, WithENode, WithMotorcycle)) @@ -81,22 +81,21 @@ motorcycleToENode (Motorcycle (seg1,seg2) mcpath mcErr) = ENode (startPoint seg1 -- | Find the point where the propogation from a motorcycle equals the propogation of what it impacts, taking into account the weight of a motorcycle, and the weight of what it impacts. motorcycleDivisor :: Motorcycle -> MotorcycleIntersection -> PPoint2 -motorcycleDivisor motorcycle target = pPointBetweenPPoints (canonicalizePPoint2 $ pPointOf motorcycle) pointOfTarget (tSpeedOf target) (mSpeedOf motorcycle) +motorcycleDivisor motorcycle target = pPointBetweenPPoints (pPointOf motorcycle) (fst pointOfTarget) (tSpeedOf target) (mSpeedOf motorcycle) where - pointOfTarget :: CPPoint2 pointOfTarget = case target of (WithLineSeg lineSeg) -> case outputIntersectsLineSeg motorcycle lineSeg of - (Right (IntersectsIn p _)) -> p + (Right (IntersectsIn p (_,_, pErr))) -> (p, pErr) v -> error $ "impossible!\n" <> show v <> "\n" <> show lineSeg <> "\n" <> show motorcycle <> "\n" <> show target <> "\n" - (WithENode eNode) -> canonicalizePPoint2 $ pPointOf eNode - (WithMotorcycle motorcycle2) -> canonicalizePPoint2 $ pPointOf motorcycle2 + (WithENode eNode) -> canonicalizeP $ pPointOf eNode + (WithMotorcycle motorcycle2) -> canonicalizeP $ pPointOf motorcycle2 tSpeedOf :: MotorcycleIntersection -> ℝ tSpeedOf myTarget = case myTarget of (WithLineSeg lineSeg) -> distanceBetweenPPoints (justIntersectsIn $ plinesIntersectIn (translateL (eToPLine2 lineSeg) 1) (outAndErrOf motorcycle)) (justIntersectsIn $ plinesIntersectIn (eToPL lineSeg) (outAndErrOf motorcycle)) - (WithENode eNode) -> distanceBetweenPPoints (canonicalizePPoint2 $ pPointOf eNode) (justIntersectsIn $ plinesIntersectIn (translateL (eToPLine2 $ getFirstLineSeg eNode) 1) (outAndErrOf eNode)) + (WithENode eNode) -> distanceBetweenPPoints (pPointOf eNode) (justIntersectsIn $ plinesIntersectIn (translateL (eToPLine2 $ getFirstLineSeg eNode) 1) (outAndErrOf eNode)) (WithMotorcycle motorcycle2) -> mSpeedOf motorcycle2 mSpeedOf :: Motorcycle -> ℝ - mSpeedOf myMotorcycle@(Motorcycle (seg1,_) _ _) = distanceBetweenPPoints (canonicalizePPoint2 $ pPointOf myMotorcycle) (justIntersectsIn $ plinesIntersectIn (translateL (eToPLine2 seg1) 1) (outAndErrOf myMotorcycle)) + mSpeedOf myMotorcycle@(Motorcycle (seg1,_) _ _) = distanceBetweenPPoints (pPointOf myMotorcycle) (justIntersectsIn $ plinesIntersectIn (translateL (eToPLine2 seg1) 1) (outAndErrOf myMotorcycle)) justIntersectsIn :: PIntersection -> CPPoint2 justIntersectsIn res = case res of (IntersectsIn p _) -> p @@ -234,7 +233,7 @@ motorcycleMightIntersectWith lineSegs motorcycle results = slist $ sortByDistance $ mapMaybe filterIntersection intersections sortByDistance :: [(LineSeg, Either Point2 CPPoint2)] -> [(LineSeg, Either Point2 CPPoint2)] sortByDistance = sortBy compareDistances - motorcyclePoint = canonicalizePPoint2 $ pPointOf motorcycle + motorcyclePoint = pPointOf motorcycle compareDistances i1 i2 = case i1 of (_, Right intersectionPPoint1) -> case i2 of @@ -308,7 +307,7 @@ motorcycleIntersectsAt contour motorcycle = case intersections of (angleFound, (_,_, angleErr)) = angleBetween2PL (outOf motorcycle) (eToPLine2 $ lineSegToIntersectionP pPoint) lineSegToIntersection myPoint = makeLineSeg (ePointOf motorcycle) myPoint lineSegToIntersectionP myPPoint = makeLineSeg (ePointOf motorcycle) (pToEPoint2 myPPoint) - motorcyclePoint = canonicalizePPoint2 $ pPointOf motorcycle + motorcyclePoint = pPointOf motorcycle intersections = getMotorcycleContourIntersections motorcycle contour -- | Determine if a node is on one side of a motorcycle, or the other. From a40bc9634a161ef99e7a2f93a3c6c833792841aa Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Wed, 28 Dec 2022 13:01:50 +0000 Subject: [PATCH 175/206] stop pretending some functions return anything but a CPPoint2. also, return error quotents for INodes, and use getInsideArc flipped, rather than implementing getOutsideArc. --- Graphics/Slicer/Math/PGA.hs | 26 ++++---- Graphics/Slicer/Math/PGAPrimitives.hs | 8 ++- Graphics/Slicer/Math/RandomGeometry.hs | 4 +- Graphics/Slicer/Math/Skeleton/Cells.hs | 8 +-- Graphics/Slicer/Math/Skeleton/Concave.hs | 16 ++--- Graphics/Slicer/Math/Skeleton/Definitions.hs | 25 ++++---- Graphics/Slicer/Math/Skeleton/Motorcycles.hs | 62 +++++++++----------- tests/Math/PGA.hs | 53 +++++++++-------- 8 files changed, 101 insertions(+), 101 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index d4efa9126..a48160e96 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -38,9 +38,9 @@ module Graphics.Slicer.Math.PGA( PLine2Err(PLine2Err), Pointable( canPoint, + cPPointOf, ePointOf, - errOfPPoint, - pPointOf + errOfPPoint ), PPoint2(PPoint2), PPoint2Err, @@ -54,6 +54,7 @@ module Graphics.Slicer.Math.PGA( angleBetween2PL, canonicalizedIntersectionOf2PL, combineConsecutiveLineSegs, + cPPointAndErrOf, distancePPToPL, distance2PL, distance2PP, @@ -67,13 +68,12 @@ module Graphics.Slicer.Math.PGA( intersect2PL, join2EP, join2PP, - makePPoint2, + makeCPPoint2, outAndErrOf, pLineErrAtPPoint, pLineIntersectsLineSeg, pLineIsLeft, plinesIntersectIn, - pPointAndErrOf, pPointOnPerpWithErr, pPointsOnSameSideOfPLine, pToEP, @@ -306,13 +306,13 @@ class (Show a) => Pointable a where ePointOf :: a -> Point2 -- | If the point is not a native euclidian point, the error generated while converting from a projective form. otherwise mempty. errOfPPoint :: a -> PPoint2Err - -- | Get a projective representation of this point. - pPointOf :: a -> PPoint2 + -- | Get a canonicalized projective representation of this point. + cPPointOf :: a -> CPPoint2 -- | If the given node can be resolved to a point, return it, along with it's error quotent. -pPointAndErrOf :: (Pointable a) => a -> (PPoint2, PPoint2Err) -pPointAndErrOf node - | canPoint node = (pPointOf node, errOfPPoint node) +cPPointAndErrOf :: (Pointable a) => a -> (CPPoint2, PPoint2Err) +cPPointAndErrOf node + | canPoint node = (cPPointOf node, errOfPPoint node) | otherwise = error "not able to resolve node to a point." ---------------------------------------------------------- @@ -495,14 +495,14 @@ combineConsecutiveLineSegs lines = case lines of euclidianToProjectivePoint2, eToPP :: Point2 -> CPPoint2 euclidianToProjectivePoint2 (Point2 (x,y)) = res where - res = makePPoint2 x y + res = makeCPPoint2 x y eToPP = euclidianToProjectivePoint2 -- | Create a canonical euclidian projective point from the given coordinates. -makePPoint2 :: ℝ -> ℝ -> CPPoint2 -makePPoint2 x y = pPoint +makeCPPoint2 :: ℝ -> ℝ -> CPPoint2 +makeCPPoint2 x y = cPPoint where - pPoint = CPPoint2 $ GVec $ foldl' addValWithoutErr [GVal 1 (fromList [GEPlus 1, GEPlus 2])] [ GVal (negate x) (fromList [GEZero 1, GEPlus 2]), GVal y (fromList [GEZero 1, GEPlus 1])] + cPPoint = CPPoint2 $ GVec $ foldl' addValWithoutErr [GVal 1 (fromList [GEPlus 1, GEPlus 2])] [ GVal (negate x) (fromList [GEZero 1, GEPlus 2]), GVal y (fromList [GEZero 1, GEPlus 1])] -- | Reverse a vector. Really, take every value in it, and recompute it in the reverse order of the vectors (so instead of e0∧e1, e1∧e0). which has the effect of negating bi and tri-vectors. reverseGVec :: GVec -> GVec diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index c00a241cf..dfed0e946 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -63,7 +63,7 @@ module Graphics.Slicer.Math.PGAPrimitives yIntercept ) where -import Prelude(Bool(False), Eq((==),(/=)), Monoid(mempty), Ord, Semigroup((<>)), Show(show), ($), (+), (*), (/), (<$>), (&&), (-), abs, error, filter, fst, negate, otherwise, realToFrac, snd, sqrt) +import Prelude(Bool(False), Eq((==),(/=)), Monoid(mempty), Ord(compare), Ordering(EQ), Semigroup((<>)), Show(show), ($), (+), (*), (/), (<$>), (&&), (-), abs, error, filter, fst, negate, otherwise, realToFrac, snd, sqrt) import Control.DeepSeq (NFData) @@ -524,7 +524,7 @@ newtype PPoint2 = PPoint2 GVec -- | A canonicalized projective point in 2D space. newtype CPPoint2 = CPPoint2 GVec - deriving (Eq, Generic, NFData, Show) + deriving (Eq, Ord, Generic, NFData, Show) -- | The error accumulated when calculating a projective point. data PPoint2Err = @@ -559,6 +559,10 @@ instance Semigroup PPoint2Err where instance Monoid PPoint2Err where mempty = PPoint2Err mempty mempty mempty mempty mempty mempty mempty +-- | A fake instance; so when we are sorting PPoint2, PPoint2Err pairs, the latter doesn't matter. +instance Ord PPoint2Err where + compare _ _ = EQ + class (Show a) => ProjectivePoint2 a where canonicalizeP :: a -> (CPPoint2, PPoint2Err) consLikeP :: a -> (GVec -> a) diff --git a/Graphics/Slicer/Math/RandomGeometry.hs b/Graphics/Slicer/Math/RandomGeometry.hs index 2f0c322e9..4b14070f9 100644 --- a/Graphics/Slicer/Math/RandomGeometry.hs +++ b/Graphics/Slicer/Math/RandomGeometry.hs @@ -91,7 +91,7 @@ import Graphics.Slicer.Math.Ganja (dumpGanjas, toGanja) import Graphics.Slicer.Math.Lossy (pToEPoint2, translateRotatePPoint2) -import Graphics.Slicer.Math.PGA (PLine2, PLine2Err, eToPL, eToPP, flipL, join2EP, pPointOf) +import Graphics.Slicer.Math.PGA (PLine2, PLine2Err, eToPL, eToPP, flipL, join2EP, cPPointOf) import Graphics.Slicer.Math.Skeleton.Concave (makeENode) @@ -404,7 +404,7 @@ randomINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 = makeINode [maybeFlippedpl1,m (pl2, pl2Err) = (flipL ls, lsErr) where (ls, lsErr) = eToPL $ getLastLineSeg eNode - intersectionPPoint = pPointOf eNode + intersectionPPoint = cPPointOf eNode eNode = randomENode x y d1 rawR1 d2 rawR2 pp1 = translateRotatePPoint2 intersectionPPoint (coerce d1) (coerce r1) pp2 = translateRotatePPoint2 intersectionPPoint (coerce d2) (coerce r2) diff --git a/Graphics/Slicer/Math/Skeleton/Cells.hs b/Graphics/Slicer/Math/Skeleton/Cells.hs index 65a681d36..ff3788659 100644 --- a/Graphics/Slicer/Math/Skeleton/Cells.hs +++ b/Graphics/Slicer/Math/Skeleton/Cells.hs @@ -58,7 +58,7 @@ import Graphics.Slicer.Math.Intersections (intersectionBetweenArcsOf, isAntiColl import Graphics.Slicer.Math.Lossy (distanceBetweenPPoints, distanceBetweenPPointsWithErr, eToPLine2, pToEPoint2) -import Graphics.Slicer.Math.PGA (Arcable(outOf), CPPoint2, Pointable(canPoint, ePointOf, pPointOf), angleBetween2PL, distance2PP, eToPL, eToPP, join2PP, outAndErrOf, pPointAndErrOf) +import Graphics.Slicer.Math.PGA (Arcable(outOf), CPPoint2, Pointable(canPoint, ePointOf, cPPointOf), angleBetween2PL, distance2PP, eToPL, eToPP, join2PP, outAndErrOf, cPPointAndErrOf) data UnsupportedReason = INodeCrossesDivide ![(INode,CellDivide)] !NodeTree deriving (Show, Eq) @@ -125,8 +125,8 @@ findDivisions contour crashTree = case motorcyclesIn crashTree of then WithENode oneNode else WithLineSeg $ fst $ motorcycleIntersectsAt myContour myMotorcycle where - cMotorcyclePoint = pPointAndErrOf myMotorcycle - cNodePoint = pPointAndErrOf oneNode + cMotorcyclePoint = cPPointAndErrOf myMotorcycle + cNodePoint = cPPointAndErrOf oneNode motorcycleENodeDistance = distanceBetweenPPointsWithErr cMotorcyclePoint cNodePoint motorcycleLineSegDistance = distanceBetweenPPointsWithErr cMotorcyclePoint $ fromMaybe (error "no outArc?") $ outputIntersectsPLineAt myMotorcycle (eToPL $ fst $ motorcycleIntersectsAt myContour myMotorcycle) (_:_) -> error "more than one opposing exterior node. cannot yet handle this situation." @@ -366,7 +366,7 @@ addNodeTreesAlongDivide nodeTree1 nodeTree2 division = mergeNodeTrees (adjustedN (_:_) -> NodeTree eNodes $ INodeSet $ init gens <> one [makeINode (nub $ insOf $ lastINodeOf iNodeGens) (Just $ (\(res, (_,_,resErr)) -> (res, resErr)) $ join2PP (finalPointOfNodeTree nodeTree) myCrossover)] -- | find the last resolvable point in a NodeTree finalPointOfNodeTree (NodeTree _ iNodeGens) - | canPoint (lastINodeOf iNodeGens) = pPointOf $ lastINodeOf iNodeGens + | canPoint (lastINodeOf iNodeGens) = cPPointOf $ lastINodeOf iNodeGens | otherwise = error "last INode not pointable?" crossoverPoint = case division of (CellDivide (DividingMotorcycles motorcycle1 (Slist [] _)) target) -> -- no eNode, and no opposing motorcycle. diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index 484d7e4ed..0e1ad3c73 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -58,7 +58,7 @@ import Graphics.Slicer.Math.Intersections (intersectionOf, intersectionBetweenAr import Graphics.Slicer.Math.Lossy (distanceBetweenPPointsWithErr) -import Graphics.Slicer.Math.PGA (Arcable(errOfOut, hasArc, outOf), Pointable(canPoint), PLine2, PLine2Err, ProjectiveLine2, distance2PP, eToPL, flipL, outAndErrOf, pPointAndErrOf, pLineIsLeft) +import Graphics.Slicer.Math.PGA (Arcable(errOfOut, hasArc, outOf), Pointable(canPoint), PLine2, PLine2Err, ProjectiveLine2, cPPointAndErrOf, distance2PP, eToPL, flipL, outAndErrOf, pLineIsLeft) import Graphics.Slicer.Math.Skeleton.Definitions (ENode(ENode), ENodeSet(ENodeSet), INode(INode), INodeSet(INodeSet), NodeTree(NodeTree), concavePLines, getFirstLineSeg, getLastLineSeg, finalOutOf, firstInOf, getPairs, indexPLinesTo, insOf, lastINodeOf, linePairs, makeINode, sortedPLinesWithErr, isLoop) @@ -166,7 +166,7 @@ errorIfLeft (Right val) = val -- | For a given pair of nodes, construct a new internal node, where it's parents are the given nodes, and the line leaving it is along the the obtuse bisector. -- Note: this should be hidden in skeletonOfConcaveRegion, but it's exposed here, for testing. averageNodes :: (Arcable a, Pointable a, Arcable b, Pointable b) => a -> b -> INode -averageNodes n1 n2 = makeINode (sortedPair n1 n2) $ Just $ getOutsideArc (pPointAndErrOf n1) (outAndErrOf n1) (pPointAndErrOf n2) (outAndErrOf n2) +averageNodes n1 n2 = makeINode (sortedPair n1 n2) $ Just $ getOutsideArc (cPPointAndErrOf n1) (outAndErrOf n1) (cPPointAndErrOf n2) (outAndErrOf n2) -- | Take a pair of arcables, and return their outOfs, in a sorted order. sortedPair :: (Arcable a, Arcable b) => a -> b -> [(PLine2, PLine2Err)] @@ -749,8 +749,8 @@ skeletonOfNodes connectedLoop origSegSets inSegSets iNodes = <> show n2 <> "\n" where intersectionPoint = fromMaybe (error "has arcs, but no intersection?") $ intersectionBetweenArcsOf n1 n2 - (n1Distance, (_,_, n1Err)) = distance2PP intersectionPoint (pPointAndErrOf n1) - (n2Distance, (_,_, n2Err)) = distance2PP intersectionPoint (pPointAndErrOf n2) + (n1Distance, (_,_, n1Err)) = distance2PP intersectionPoint (cPPointAndErrOf n1) + (n2Distance, (_,_, n2Err)) = distance2PP intersectionPoint (cPPointAndErrOf n2) -- | get the list of sorted pairs of intersecting nodes. shortestNeighboringPairs :: (Arcable a, Pointable a, Eq a) => [(a,a)] -> [(a, a)] @@ -808,9 +808,9 @@ skeletonOfNodes connectedLoop origSegSets inSegSets iNodes = && hasArc node1 && hasArc node2 && intersectsInPoint node1 node2 = - Just $ distanceBetweenPPointsWithErr (pPointAndErrOf node1) (intersectionOf (outAndErrOf node1) (outAndErrOf node2)) + Just $ distanceBetweenPPointsWithErr (cPPointAndErrOf node1) (intersectionOf (outAndErrOf node1) (outAndErrOf node2)) `max` - distanceBetweenPPointsWithErr (pPointAndErrOf node2) (intersectionOf (outAndErrOf node1) (outAndErrOf node2)) + distanceBetweenPPointsWithErr (cPPointAndErrOf node2) (intersectionOf (outAndErrOf node1) (outAndErrOf node2)) | otherwise = Nothing -- | Check if the intersection of two nodes results in a point or not. intersectsInPoint :: (Arcable a, Pointable a, Arcable b, Pointable b) => a -> b -> Bool @@ -820,5 +820,5 @@ skeletonOfNodes connectedLoop origSegSets inSegSets iNodes = && not (dist2 <= ulpVal dist2Err) | otherwise = error $ "cannot intersect a node with no output:\nNode1: " <> show node1 <> "\nNode2: " <> show node2 <> "\nnodes: " <> show iNodes <> "\n" where - (dist1, (_,_, dist1Err)) = distance2PP (intersectionOf (outAndErrOf node1) (outAndErrOf node2)) (pPointAndErrOf node1) - (dist2, (_,_, dist2Err)) = distance2PP (intersectionOf (outAndErrOf node1) (outAndErrOf node2)) (pPointAndErrOf node2) + (dist1, (_,_, dist1Err)) = distance2PP (intersectionOf (outAndErrOf node1) (outAndErrOf node2)) (cPPointAndErrOf node1) + (dist2, (_,_, dist2Err)) = distance2PP (intersectionOf (outAndErrOf node1) (outAndErrOf node2)) (cPPointAndErrOf node2) diff --git a/Graphics/Slicer/Math/Skeleton/Definitions.hs b/Graphics/Slicer/Math/Skeleton/Definitions.hs index 78a12baa8..a20ccfc33 100644 --- a/Graphics/Slicer/Math/Skeleton/Definitions.hs +++ b/Graphics/Slicer/Math/Skeleton/Definitions.hs @@ -29,7 +29,7 @@ module Graphics.Slicer.Math.Skeleton.Definitions (RemainingContour(RemainingContour), StraightSkeleton(StraightSkeleton), Spine(Spine), ENode(ENode), INode(INode), ENodeSet(ENodeSet), INodeSet(INodeSet), NodeTree(NodeTree), ancestorsOf, Motorcycle(Motorcycle), Cell(Cell), CellDivide(CellDivide), DividingMotorcycles(DividingMotorcycles), MotorcycleIntersection(WithENode, WithMotorcycle, WithLineSeg), concavePLines, getFirstLineSeg, getLastLineSeg, hasNoINodes, getPairs, linePairs, finalPLine, finalINodeOf, finalOutOf, makeINode, sortedPLines, sortedPLinesWithErr, indexPLinesTo, insOf, lastINodeOf, firstInOf, isLoop, lastInOf) where -import Prelude (Eq, Show, Bool(True, False), Ordering(LT,GT), ($), (<$>), (==), (/=), (||), (<>), (<), (*), (&&), any, error, fst, mempty, not, otherwise, show) +import Prelude (Eq, Show, Bool(True, False), Ordering(LT,GT), ($), (<$>), (==), (/=), (||), (<>), (<), (*), (&&), any, error, fst, mempty, not, otherwise, show, snd) import Prelude as PL (head, last) @@ -57,7 +57,7 @@ import Graphics.Slicer.Math.Intersections (intersectionsAtSamePoint, noIntersect import Graphics.Slicer.Math.Lossy (eToPLine2) -import Graphics.Slicer.Math.PGA (Arcable(errOfOut, hasArc, outOf), CPPoint2(CPPoint2), PIntersection(IntersectsIn), PLine2(PLine2), PLine2Err, Pointable(canPoint, pPointOf, ePointOf, errOfPPoint), PPoint2(PPoint2), eToPL, eToPP, flipL, outAndErrOf, plinesIntersectIn, pLineIsLeft, pToEP, vecOfP) +import Graphics.Slicer.Math.PGA (Arcable(errOfOut, hasArc, outOf), CPPoint2, PIntersection(IntersectsIn), PLine2(PLine2), PLine2Err, Pointable(canPoint, cPPointOf, ePointOf, errOfPPoint), PPoint2Err, eToPL, eToPP, flipL, outAndErrOf, plinesIntersectIn, pLineIsLeft, pToEP) -- | A point where two lines segments that are part of a contour intersect, emmiting an arc toward the interior of a contour. -- FIXME: a source should have a different UlpSum for it's point and it's output. @@ -86,8 +86,7 @@ instance Pointable ENode where canPoint _ = True ePointOf (ENode (_,centerPoint,_) _ _) = centerPoint errOfPPoint _ = mempty - -- FIXME: this causes double canonicalization. - pPointOf a = PPoint2 $ vecOfP $ eToPP $ ePointOf a + cPPointOf a = eToPP $ ePointOf a -- | A point in our straight skeleton where arcs intersect, resulting in the creation of another arc. data INode = INode @@ -122,12 +121,14 @@ instance Pointable INode where where hasIntersectingPairs (Slist pLines _) = any (\(pl1, pl2) -> not $ noIntersection pl1 pl2) $ getPairs pLines -- Just convert our resolved point. - ePointOf a = fst $ pToEP $ pPointOf a - -- FIXME: implement this properly. - errOfPPoint _ = mempty - -- Since an INode does not contain a point, we have to attempt to resolve one instead. - -- FIXME: if we have multiple intersecting pairs, is there a preferred pair to use for resolving? maybe a pair that is at as close as possible to a right angle? - pPointOf iNode + ePointOf a = fst $ pToEP $ fst $ cPPointAndErrOfINode a + cPPointOf a = fst $ cPPointAndErrOfINode a + errOfPPoint a = snd $ cPPointAndErrOfINode a + +-- Since an INode does not contain a point, we have to attempt to resolve one instead. +-- FIXME: if we have multiple intersecting pairs, is there a preferred pair to use for resolving? maybe a pair that is at as close as possible to a right angle? +cPPointAndErrOfINode :: INode -> (CPPoint2, PPoint2Err) +cPPointAndErrOfINode iNode | allPointsSame = case results of [] -> error $ "cannot get a PPoint of this iNode: " <> show iNode <> "/n" l -> PL.head l @@ -140,7 +141,7 @@ instance Pointable INode where allPointsSame = intersectionsAtSamePoint ((\(Slist l _) -> l) $ allPLinesOfINode iNode) intersectionsOfPairs (Slist pLines _) = mapMaybe (\(pl1, pl2) -> saneIntersect $ plinesIntersectIn pl1 pl2) $ getPairs pLines where - saneIntersect (IntersectsIn a _) = Just $ (\(CPPoint2 v) -> PPoint2 v) a + saneIntersect (IntersectsIn p (_,_, pErr)) = Just (p, pErr) saneIntersect _ = Nothing -- | Get all of the PLines that come from, or exit an iNode. @@ -184,9 +185,9 @@ instance Arcable Motorcycle where -- | A motorcycle always contains a point. instance Pointable Motorcycle where canPoint _ = True + cPPointOf a = eToPP $ ePointOf a ePointOf (Motorcycle (_, LineSeg point _) _ _) = point errOfPPoint _ = mempty - pPointOf a = (\(CPPoint2 v) -> PPoint2 v) $ eToPP $ ePointOf a -- | The motorcycles that are involved in dividing two cells. data DividingMotorcycles = DividingMotorcycles { firstMotorcycle :: !Motorcycle, moreMotorcycles :: !(Slist Motorcycle) } diff --git a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs index 2e934d606..d19a7e1ee 100644 --- a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs +++ b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs @@ -26,7 +26,7 @@ module Graphics.Slicer.Math.Skeleton.Motorcycles (CollisionType(HeadOn), CrashTree(CrashTree), motorcycleToENode, Collision(Collision), motorcycleIntersectsAt, intersectionSameSide, crashMotorcycles, collisionResult, convexMotorcycles, lastCrashType, motorcyclesAreAntiCollinear, motorcyclesInDivision, motorcycleMightIntersectWith, motorcycleDivisor) where -import Prelude (Bool(True, False), Either(Left,Right), Eq((==)), Show(show), Ordering (EQ, GT, LT), (&&), (<>), ($), (<), (>), compare, error, fst, mempty, notElem, null, otherwise, zip) +import Prelude (Bool(True, False), Either(Left,Right), Eq((==)), Show(show), Ordering (EQ, GT, LT), (&&), (<>), ($), (<), (>), compare, error, fst, notElem, null, otherwise, zip) import Prelude as PL (init, last) @@ -42,21 +42,23 @@ import Slist.Type (Slist(Slist)) import Graphics.Slicer.Definitions (ℝ) +import Graphics.Slicer.Math.Arcs (getInsideArc) + import Graphics.Slicer.Math.Contour (pointsOfContour) import Graphics.Slicer.Math.ContourIntersections (getMotorcycleContourIntersections, getMotorcycleSegSetIntersections) import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, mapWithNeighbors, startPoint, endPoint, makeLineSeg) -import Graphics.Slicer.Math.Intersections (intersectionOf, isAntiCollinear, noIntersection, outputIntersectsLineSeg) +import Graphics.Slicer.Math.Intersections (intersectionOf, isAntiCollinear, noIntersection, outputIntersectsLineSeg, outputIntersectsPLineAt) -import Graphics.Slicer.Math.Lossy (pPointBetweenPPoints, distanceBetweenPPoints, eToPLine2, normalizePLine2, pToEPoint2) +import Graphics.Slicer.Math.Lossy (pPointBetweenPPoints, distanceBetweenPPoints, distanceBetweenPPointsWithErr, eToPLine2, pToEPoint2) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2(NPLine2), PLine2(PLine2), PLine2Err(PLine2Err), PPoint2, PPoint2Err, Arcable(outOf), Pointable(canPoint, ePointOf, pPointOf), eToPL, flipL, pLineIsLeft, pPointsOnSameSideOfPLine, PIntersection(IntersectsIn,PAntiCollinear), ProjectivePoint2, angleBetween2PL, canonicalizeP, distance2PP, eToPP, join2PP, outAndErrOf, plinesIntersectIn, translateL) +import Graphics.Slicer.Math.PGA (CPPoint2, PLine2, PLine2Err, PPoint2, PPoint2Err, Arcable(outOf), Pointable(canPoint, cPPointOf, ePointOf), cPPointAndErrOf, eToPL, flipL, pLineIsLeft, pPointsOnSameSideOfPLine, PIntersection(IntersectsIn,PAntiCollinear), ProjectivePoint2, angleBetween2PL, distance2PP, eToPP, join2EP, outAndErrOf, plinesIntersectIn, translateL) -import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle), ENode(ENode), getFirstLineSeg, linePairs, CellDivide(CellDivide), DividingMotorcycles(DividingMotorcycles), MotorcycleIntersection(WithLineSeg, WithENode, WithMotorcycle)) +import Graphics.Slicer.Math.Skeleton.Definitions (CellDivide(CellDivide), DividingMotorcycles(DividingMotorcycles), ENode(ENode), Motorcycle(Motorcycle), MotorcycleIntersection(WithLineSeg, WithENode, WithMotorcycle), getFirstLineSeg, linePairs) -import Graphics.Slicer.Math.GeometricAlgebra (addVecPairWithErr, ulpVal) +import Graphics.Slicer.Math.GeometricAlgebra (ulpVal) -- | The collision of two motorcycles. one lives, and one doesn't, unless it's a head on collision, in which case both die, and there is no survivor. data Collision = Collision { _inMotorcycles :: !(Motorcycle, Motorcycle, Slist Motorcycle), _survivor :: !(Maybe Motorcycle), collisionResult :: !CollisionType } @@ -81,21 +83,25 @@ motorcycleToENode (Motorcycle (seg1,seg2) mcpath mcErr) = ENode (startPoint seg1 -- | Find the point where the propogation from a motorcycle equals the propogation of what it impacts, taking into account the weight of a motorcycle, and the weight of what it impacts. motorcycleDivisor :: Motorcycle -> MotorcycleIntersection -> PPoint2 -motorcycleDivisor motorcycle target = pPointBetweenPPoints (pPointOf motorcycle) (fst pointOfTarget) (tSpeedOf target) (mSpeedOf motorcycle) +motorcycleDivisor motorcycle target = pPointBetweenPPoints (cPPointOf motorcycle) (fst pointOfTarget) (tSpeedOf target) (mSpeedOf motorcycle) where pointOfTarget = case target of (WithLineSeg lineSeg) -> case outputIntersectsLineSeg motorcycle lineSeg of (Right (IntersectsIn p (_,_, pErr))) -> (p, pErr) v -> error $ "impossible!\n" <> show v <> "\n" <> show lineSeg <> "\n" <> show motorcycle <> "\n" <> show target <> "\n" - (WithENode eNode) -> canonicalizeP $ pPointOf eNode - (WithMotorcycle motorcycle2) -> canonicalizeP $ pPointOf motorcycle2 + (WithENode eNode) -> (cPPointAndErrOf eNode) + (WithMotorcycle motorcycle2) -> (cPPointAndErrOf motorcycle2) tSpeedOf :: MotorcycleIntersection -> ℝ tSpeedOf myTarget = case myTarget of - (WithLineSeg lineSeg) -> distanceBetweenPPoints (justIntersectsIn $ plinesIntersectIn (translateL (eToPLine2 lineSeg) 1) (outAndErrOf motorcycle)) (justIntersectsIn $ plinesIntersectIn (eToPL lineSeg) (outAndErrOf motorcycle)) - (WithENode eNode) -> distanceBetweenPPoints (pPointOf eNode) (justIntersectsIn $ plinesIntersectIn (translateL (eToPLine2 $ getFirstLineSeg eNode) 1) (outAndErrOf eNode)) + (WithLineSeg lineSeg) -> distanceBetweenPPointsWithErr + (fromMaybe (error "no outArc?") $ outputIntersectsPLineAt motorcycle (translateL (eToPLine2 lineSeg) 1)) + (fromMaybe (error "no outArc?") $ outputIntersectsPLineAt motorcycle (eToPL lineSeg)) + (WithENode eNode) -> distanceBetweenPPointsWithErr + (cPPointAndErrOf eNode) + (fromMaybe (error "no outArc?") $ outputIntersectsPLineAt eNode (translateL (eToPLine2 $ getFirstLineSeg eNode) 1)) (WithMotorcycle motorcycle2) -> mSpeedOf motorcycle2 mSpeedOf :: Motorcycle -> ℝ - mSpeedOf myMotorcycle@(Motorcycle (seg1,_) _ _) = distanceBetweenPPoints (pPointOf myMotorcycle) (justIntersectsIn $ plinesIntersectIn (translateL (eToPLine2 seg1) 1) (outAndErrOf myMotorcycle)) + mSpeedOf myMotorcycle@(Motorcycle (seg1,_) _ _) = distanceBetweenPPoints (cPPointOf myMotorcycle) (justIntersectsIn $ plinesIntersectIn (translateL (eToPLine2 seg1) 1) (outAndErrOf myMotorcycle)) justIntersectsIn :: PIntersection -> CPPoint2 justIntersectsIn res = case res of (IntersectsIn p _) -> p @@ -149,7 +155,7 @@ crashMotorcycles contour holes | intersectionIsBehind mot2 = Nothing -- FIXME: this should be providing a distance to intersectionPPoint along the motorcycle to check. | otherwise = case getMotorcycleContourIntersections mot1 contour of - [] -> case fst (distance2PP (pPointOf mot1, mempty) intersectionPPoint) `compare` fst (distance2PP (pPointOf mot2, mempty) intersectionPPoint) of + [] -> case fst (distance2PP (cPPointAndErrOf mot1) intersectionPPoint) `compare` fst (distance2PP (cPPointAndErrOf mot2) intersectionPPoint) of GT -> Just $ Collision (mot1, mot2, slist []) (Just mot2) Normal LT -> Just $ Collision (mot1, mot2, slist []) (Just mot1) Normal EQ -> Just $ Collision (mot1, mot2, slist []) (Just mot1) SideSwipe @@ -182,26 +188,14 @@ convexMotorcycles contour = mapMaybe onlyMotorcycles $ zip (rotateLeft $ linePai pl1 = eToPL $ makeLineSeg p1 p2 pl2 = eToPL $ makeLineSeg p2 p3 --- | generate the un-normalized PLine2 of a motorcycle created by the three points given. +-- | generate the PLine2 of a motorcycle created by the three points given. motorcycleFromPoints :: Point2 -> Point2 -> Point2 -> (PLine2, PLine2Err) -motorcycleFromPoints p1 p2 p3 = getOutsideArc (firstArc, firstArcErr) (secondArc, secondArcErr) +motorcycleFromPoints p1 p2 p3 = (flipL res, resErr) where - (firstArc, (_,_, firstArcErr)) = join2PP (eToPP p1) (eToPP p2) - (secondArc, (_,_, secondArcErr)) = join2PP (eToPP p2) (eToPP p3) - -- | Get a PLine along the angle bisector of the intersection of the two given line segments, pointing in the 'obtuse' direction. - -- Note that we do not normalize our output, or require normalized inputs, but we normalize our values before adding them. - getOutsideArc :: (PLine2, PLine2Err) -> (PLine2, PLine2Err) -> (PLine2, PLine2Err) - getOutsideArc pline1@(pl1, _) pline2@(pl2, _) - | noIntersection pline1 pline2 = error - $ "not collinear, but not intersecting?\n" - <> "PLine1: " <> show pline1 <> "\n" - <> "PLine2: " <> show pline2 <> "\n" - <> "result: " <> show (plinesIntersectIn pline1 pline2) <> "\n" - | otherwise = (flipL $ PLine2 newPLine, PLine2Err newPLineErrVals mempty mempty mempty mempty mempty) + (res, resErr) = getInsideArc firstLine secondLine where - (newPLine, newPLineErrVals) = addVecPairWithErr flippedNPV1 npv2 - (PLine2 flippedNPV1) = flipL $ (\(NPLine2 a) -> PLine2 a) $ normalizePLine2 pl1 - (NPLine2 npv2) = normalizePLine2 pl2 + firstLine = join2EP p1 p2 + secondLine = join2EP p2 p3 -- | Find the non-reflex virtexes of a contour and draw motorcycles from them. -- A reflex virtex is any point where the line in and the line out are convex, when looked at from inside of the contour. @@ -233,7 +227,7 @@ motorcycleMightIntersectWith lineSegs motorcycle results = slist $ sortByDistance $ mapMaybe filterIntersection intersections sortByDistance :: [(LineSeg, Either Point2 CPPoint2)] -> [(LineSeg, Either Point2 CPPoint2)] sortByDistance = sortBy compareDistances - motorcyclePoint = pPointOf motorcycle + motorcyclePoint = cPPointOf motorcycle compareDistances i1 i2 = case i1 of (_, Right intersectionPPoint1) -> case i2 of @@ -307,7 +301,7 @@ motorcycleIntersectsAt contour motorcycle = case intersections of (angleFound, (_,_, angleErr)) = angleBetween2PL (outOf motorcycle) (eToPLine2 $ lineSegToIntersectionP pPoint) lineSegToIntersection myPoint = makeLineSeg (ePointOf motorcycle) myPoint lineSegToIntersectionP myPPoint = makeLineSeg (ePointOf motorcycle) (pToEPoint2 myPPoint) - motorcyclePoint = pPointOf motorcycle + motorcyclePoint = cPPointOf motorcycle intersections = getMotorcycleContourIntersections motorcycle contour -- | Determine if a node is on one side of a motorcycle, or the other. @@ -316,10 +310,10 @@ motorcycleIntersectsAt contour motorcycle = case intersections of intersectionSameSide :: (ProjectivePoint2 a, Pointable b) => (a, PPoint2Err) -> b -> Motorcycle -> Maybe Bool intersectionSameSide point@(pp1, _) node (Motorcycle _ path _) | canPoint node && d < ulpVal dErr = Just True - | canPoint node = pPointsOnSameSideOfPLine (pPointOf node) pp1 path + | canPoint node = pPointsOnSameSideOfPLine (cPPointOf node) pp1 path | otherwise = error $ "cannot resolve provided item to a point: " <> show node <> "\n" where - (d, (_,_, dErr)) = distance2PP (pPointOf node, mempty) point + (d, (_,_, dErr)) = distance2PP (cPPointAndErrOf node) point -- | Check if the output of two motorcycles are anti-collinear with each other. motorcyclesAreAntiCollinear :: Motorcycle -> Motorcycle -> Bool motorcyclesAreAntiCollinear motorcycle1 motorcycle2 = plinesIntersectIn (outAndErrOf motorcycle1) (outAndErrOf motorcycle2) == PAntiCollinear diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index 510752d7f..4d07c521c 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -67,7 +67,7 @@ import Graphics.Slicer.Math.Intersections (outputIntersectsLineSeg) import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenPLines, distancePPointToPLine, eToPLine2, getFirstArc, join2PPoint2, normalizePLine2, pPointOnPerp) -- Our 2D Projective Geometric Algebra library. -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PLine2Err(PLine2Err), canonicalizeP, distance2PP, distancePPToPL, eToPL, eToPP, eToPP, interpolate2PP, intersect2PL, translateL, translateRotatePPoint2WithErr, angleBetween2PL, flipL, join2PP, makePPoint2, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), intersectsWithErr, errOfOut, pPointOnPerpWithErr, outOf, pPointOf) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PLine2Err(PLine2Err), canonicalizeP, distance2PP, distancePPToPL, eToPL, eToPP, eToPP, interpolate2PP, intersect2PL, translateL, translateRotatePPoint2WithErr, angleBetween2PL, flipL, join2PP, makeCPPoint2, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), cPPointAndErrOf, intersectsWithErr, errOfOut, pPointOnPerpWithErr, outOf) -- The primitives of our PGA only library, and error estimation code. @@ -89,6 +89,7 @@ import Graphics.Slicer.Math.Skeleton.Concave (makeENode, makeENodes) import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle), RemainingContour(RemainingContour), Spine(Spine), StraightSkeleton(StraightSkeleton), Cell(Cell), getFirstLineSeg, getLastLineSeg) import Graphics.Slicer.Math.Skeleton.Face (Face(Face), facesOf, orderedFacesOf) import Graphics.Slicer.Math.Skeleton.Line (addInset) + import Graphics.Slicer.Math.Skeleton.Motorcycles (convexMotorcycles, crashMotorcycles, CrashTree(CrashTree)) import Graphics.Slicer.Math.Skeleton.Skeleton (findStraightSkeleton) @@ -401,11 +402,11 @@ proj2DGeomAlgSpec = do prop_AxisProjection :: Positive ℝ -> Bool -> Bool -> Positive ℝ -> Expectation prop_AxisProjection v xAxis whichDirection dv | xAxis = if whichDirection - then canonicalizePPoint2 (pPointOnPerp (eToPLine2 $ randomLineSeg 0 0 (coerce v) 0) (makePPoint2 0 0) (coerce dv)) --> makePPoint2 0 (coerce dv) - else canonicalizePPoint2 (pPointOnPerp (eToPLine2 $ randomLineSeg 0 0 (-(coerce v)) 0) (makePPoint2 0 0) (coerce dv)) --> makePPoint2 0 (-coerce dv) + then canonicalizePPoint2 (pPointOnPerp (eToPLine2 $ randomLineSeg 0 0 (coerce v) 0) (makeCPPoint2 0 0) (coerce dv)) --> makeCPPoint2 0 (coerce dv) + else canonicalizePPoint2 (pPointOnPerp (eToPLine2 $ randomLineSeg 0 0 (-(coerce v)) 0) (makeCPPoint2 0 0) (coerce dv)) --> makeCPPoint2 0 (-coerce dv) | otherwise = if whichDirection - then canonicalizePPoint2 (pPointOnPerp (eToPLine2 $ randomLineSeg 0 0 0 (coerce v)) (makePPoint2 0 0) (coerce dv)) --> makePPoint2 (-coerce dv) 0 - else canonicalizePPoint2 (pPointOnPerp (eToPLine2 $ randomLineSeg 0 0 0 (-(coerce v))) (makePPoint2 0 0) (coerce dv)) --> makePPoint2 (coerce dv) 0 + then canonicalizePPoint2 (pPointOnPerp (eToPLine2 $ randomLineSeg 0 0 0 (coerce v)) (makeCPPoint2 0 0) (coerce dv)) --> makeCPPoint2 (-coerce dv) 0 + else canonicalizePPoint2 (pPointOnPerp (eToPLine2 $ randomLineSeg 0 0 0 (-(coerce v))) (makeCPPoint2 0 0) (coerce dv)) --> makeCPPoint2 (coerce dv) 0 -- A property test making sure than for any LineSeg, a pointOnPerp is in fact on a 90 degree perpendicular line. prop_perpAt90Degrees :: ℝ -> ℝ -> Positive ℝ -> ℝ -> NonZero ℝ -> Bool @@ -430,8 +431,8 @@ prop_perpAt90Degrees x y rawX2 y2 rawD (bisectorEnd, _) = canonicalizeP bisectorEndRaw (pline3, pline3Err) = join2PP (CPPoint2 rawBisectorStart) bisectorEnd (normedPLine3, norm3Err) = normalizeL pline3 - sourceStart = makePPoint2 x y - sourceEnd = makePPoint2 x2 y2 + sourceStart = makeCPPoint2 x y + sourceEnd = makeCPPoint2 x2 y2 (pline4, pline4Err) = join2PP sourceStart sourceEnd (normedPLine4, norm4Err) = normalizeL pline4 errTotal3 = ulpVal $ angle2Err -- <> pline3Err <> pline4Err -- <> bisectorStartErr <> bisectorEndRawErr <> bisectorEndErr @@ -645,8 +646,8 @@ prop_LineSegIntersectionStableAtOrigin d1 x1 y1 rawX2 rawY2 res1 = intersectsWithErr (Right (pLineThroughOriginNotX1Y1NotOther,mempty)) (Left x1y1LineSegToOrigin :: Either LineSeg (PLine2, PLine2Err)) res2 = intersectsWithErr (Right (pLineThroughOriginNotX1Y1NotOther,mempty)) (Left lineSegFromOrigin :: Either LineSeg (PLine2, PLine2Err)) distanceStart = case res2 of - (Left (NoIntersection iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP (iPoint,mempty) (makePPoint2 0 0, mempty)) <> "\nUlpSum:" <> show ulpSum <> "\n" - (Right (IntersectsIn iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP (iPoint,mempty) (makePPoint2 0 0, mempty)) <> "\nUlpSum:" <> show ulpSum <> "\n" + (Left (NoIntersection iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP (iPoint,mempty) (makeCPPoint2 0 0, mempty)) <> "\nUlpSum:" <> show ulpSum <> "\n" + (Right (IntersectsIn iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP (iPoint,mempty) (makeCPPoint2 0 0, mempty)) <> "\nUlpSum:" <> show ulpSum <> "\n" _ -> "" (pLineThroughOriginNotX1Y1NotOther,_) = randomPLineThroughOrigin x2 y2 x1y1LineSegToOrigin = randomX1Y1LineSegToOrigin d1 @@ -691,12 +692,12 @@ prop_LineSegIntersectionStableAtX1Y1Point pointD rawD1 x1 y1 rawX2 rawY2 res1 = intersectsWithErr (Right (pLineThroughPointNotX1Y1NotOther,mempty)) (Left x1y1LineSegToPoint :: Either LineSeg (PLine2, PLine2Err)) res2 = intersectsWithErr (Right (pLineThroughPointNotX1Y1NotOther,mempty)) (Left lineSegFromPointNotX1Y1 :: Either LineSeg (PLine2, PLine2Err)) distanceStart = case res2 of - (Left (NoIntersection iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP (iPoint, mempty) (makePPoint2 d2 d2, mempty)) <> "\nUlpSum:" <> show ulpSum <> "\n" - (Right (IntersectsIn iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP (iPoint, mempty) (makePPoint2 d2 d2, mempty)) <> "\nUlpSum:" <> show ulpSum <> "\n" + (Left (NoIntersection iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP (iPoint, mempty) (makeCPPoint2 d2 d2, mempty)) <> "\nUlpSum:" <> show ulpSum <> "\n" + (Right (IntersectsIn iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP (iPoint, mempty) (makeCPPoint2 d2 d2, mempty)) <> "\nUlpSum:" <> show ulpSum <> "\n" _ -> "" distanceEnd = case res1 of - (Left (NoIntersection iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP (iPoint, mempty) (makePPoint2 d2 d2, mempty)) <> "\nUlpSum:" <> show ulpSum <> "\n" - (Right (IntersectsIn iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP (iPoint, mempty) (makePPoint2 d2 d2, mempty)) <> "\nUlpSum:" <> show ulpSum <> "\n" + (Left (NoIntersection iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP (iPoint, mempty) (makeCPPoint2 d2 d2, mempty)) <> "\nUlpSum:" <> show ulpSum <> "\n" + (Right (IntersectsIn iPoint ulpSum)) -> show iPoint <> "\nDistance: " <> show (distance2PP (iPoint, mempty) (makeCPPoint2 d2 d2, mempty)) <> "\nUlpSum:" <> show ulpSum <> "\n" _ -> "" (pLineThroughPointNotX1Y1NotOther,_) = randomPLineThroughPoint x2 y2 d2 x1y1LineSegToPoint = randomX1Y1LineSegToPoint d1 d2 @@ -1209,8 +1210,8 @@ prop_PPointWithinErrRange x y | otherwise = (p1 /= p2) || (res == 0 || error "the same, but distance?") where (res, (_,_,UlpSum resErr)) = distance2PP (p1,mempty) (p2,mempty) - p1 = makePPoint2 x y - p2 = makePPoint2 x y + p1 = makeCPPoint2 x y + p2 = makeCPPoint2 x y prop_LineSegWithinErrRange :: ℝ -> ℝ -> ℝ -> ℝ -> Bool prop_LineSegWithinErrRange x1 y1 rawX2 rawY2 @@ -1249,8 +1250,8 @@ prop_PLineWithinErrRange1 x1 y1 rawX2 rawY2 -- distance1 and distance2 should be 0, in an ideal world. (distance1, (_,_,_,_,_,UlpSum distance1Err)) = distancePPToPL (pPoint1, mempty) (nPLine, nPLineErr) (distance2, (_,_,_,_,_,UlpSum distance2Err)) = distancePPToPL (pPoint2, mempty) (nPLine, nPLineErr) - pPoint1 = makePPoint2 x1 y1 - pPoint2 = makePPoint2 x2 y2 + pPoint1 = makeCPPoint2 x1 y1 + pPoint2 = makeCPPoint2 x2 y2 (nPLine, nPLineErr) = normalizeL pLine (pLine, pLineErr) = eToPL $ makeLineSeg (Point2 (x1,y1)) (Point2 (x2,y2)) ulpTotal1 = distance1Err @@ -1283,8 +1284,8 @@ prop_PLineWithinErrRange2 x1 y1 rawX2 rawY2 -- distance1 and distance2 should be 0, in an ideal world. (distance1, (_,_,_,_,_,distance1Err)) = distancePPToPL (pPoint1, mempty) (pLine1, pLine1Err) (distance2, (_,_,_,_,_,distance2Err)) = distancePPToPL (pPoint2, mempty) (pLine1, pLine1Err) - pPoint1 = makePPoint2 x1 y1 - pPoint2 = makePPoint2 x2 y2 + pPoint1 = makeCPPoint2 x1 y1 + pPoint2 = makeCPPoint2 x2 y2 (pLine1, (_,_,pLine1Err)) = join2PP pPoint1 pPoint2 ulpTotal1 = distance1Err <> pLineErrAtPPoint (pLine1, pLine1Err) pPoint1 ulpTotal2 = distance2Err <> pLineErrAtPPoint (pLine1, pLine1Err) pPoint2 @@ -1313,8 +1314,8 @@ prop_PPointOnPerpWithinErrRange x1 y1 rawX2 rawY2 rawD (res2,(_,_,_,_,_, UlpSum res2Err)) = distancePPToPL (perp2, mempty) (pLine, mempty) (perp1, (_,_,_, UlpSum ulpSumPerp1)) = pPointOnPerpWithErr pLine pPoint1 d (perp2, (_,_,_, UlpSum ulpSumPerp2)) = pPointOnPerpWithErr pLine pPoint2 d - pPoint1 = makePPoint2 x1 y1 - pPoint2 = makePPoint2 x2 y2 + pPoint1 = makeCPPoint2 x1 y1 + pPoint2 = makeCPPoint2 x2 y2 (pLine, _) = join2PP pPoint1 pPoint2 ulpTotal1 = res1Err + ulpSumPerp1 ulpTotal2 = res2Err + ulpSumPerp2 @@ -1350,7 +1351,7 @@ prop_eNodeTowardIntersection1 :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> Pos prop_eNodeTowardIntersection1 x y d1 rawR1 d2 rawR2 = l1TowardIntersection --> True where l1TowardIntersection = towardIntersection (eToPP $ startPoint l1, mempty) pl1 eNodePoint - eNodePoint = canonicalizeP $ pPointOf eNode + eNodePoint = cPPointAndErrOf eNode l1 = getFirstLineSeg eNode pl1 = eToPL l1 eNode = randomENode x y d1 rawR1 d2 rawR2 @@ -1359,7 +1360,7 @@ prop_eNodeAwayFromIntersection2 :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> P prop_eNodeAwayFromIntersection2 x y d1 rawR1 d2 rawR2 = l2TowardIntersection --> False where l2TowardIntersection = towardIntersection (eToPP $ endPoint l2, mempty) pl2 eNodePoint - eNodePoint = canonicalizeP $ pPointOf eNode + eNodePoint = cPPointAndErrOf eNode l2 = getLastLineSeg eNode pl2 = eToPL l2 eNode = randomENode x y d1 rawR1 d2 rawR2 @@ -1368,7 +1369,7 @@ prop_translateRotateMoves :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> Expecta prop_translateRotateMoves x y rawD rawR = distanceBetweenPPoints (fst $ translateRotatePPoint2WithErr pPoint d r) cPPoint /= 0 --> True where pPoint = eToPP $ Point2 (x,y) - cPPoint = makePPoint2 x y + cPPoint = makeCPPoint2 x y r,d::ℝ r = coerce rawR d = coerce rawD @@ -1385,7 +1386,7 @@ prop_PLinesIntersectAtOrigin rawX y rawX2 rawY2 | otherwise = error $ "wtf" <> show intersectionErr <> "\n" where - originPPoint2 = makePPoint2 0 0 + originPPoint2 = makeCPPoint2 0 0 (foundDistance, (_,_,UlpSum distanceErr)) = distance2PP (originPPoint2, mempty) (intersectionPPoint2, intersectionErr) (intersectionPPoint2, (_,_,intersectionErr)) = intersect2PL randomPLine1 randomPLine2 (randomPLine1, _) = randomPLineThroughOrigin x y @@ -1412,7 +1413,7 @@ prop_PLinesIntersectAtPoint rawX y rawX2 rawY2 targetX targetY <> show distanceErr <> "\n" <> show intersectionErr <> "\n" where - (targetPPoint2) = makePPoint2 (coerce targetX) (coerce targetY) + (targetPPoint2) = makeCPPoint2 (coerce targetX) (coerce targetY) (foundDistance, (_,_,UlpSum distanceErr)) = distance2PP (targetPPoint2, mempty) (intersectionPPoint2, intersectionErr) (intersectionPPoint2, (_,_, intersectionErr)) = intersect2PL randomPLine1 randomPLine2 (randomPLine1, _) = randomPLineWithErr x y targetX targetY From 64a774bb5b3f15003b37559d2b7184929eae108c Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Wed, 28 Dec 2022 13:54:29 +0000 Subject: [PATCH 176/206] eliminate distanceBetweenPLines, and use the resErr from distance2PL instead of constructing it ourselves. --- Graphics/Slicer/Math/Lossy.hs | 6 +----- tests/Math/PGA.hs | 17 ++++++++--------- 2 files changed, 9 insertions(+), 14 deletions(-) diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index 47b95a42b..7cd8b0db2 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -22,7 +22,6 @@ module Graphics.Slicer.Math.Lossy ( canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenPPointsWithErr, - distanceBetweenPLines, distancePPointToPLine, distancePPointToPLineWithErr, eToPLine2, @@ -48,7 +47,7 @@ import Graphics.Slicer.Math.Definitions (LineSeg, Point2, makeLineSeg) import qualified Graphics.Slicer.Math.Arcs as Arcs (getFirstArc, getInsideArc) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PLine2Err, PPoint2, PPoint2Err, ProjectiveLine2, ProjectivePoint2, canonicalizeP, distance2PP, distance2PL, distancePPToPL, eToPL, interpolate2PP, join2PP, normalizeL, pPointOnPerpWithErr, pToEP, translateL, translateRotatePPoint2WithErr) +import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PLine2Err, PPoint2, PPoint2Err, ProjectiveLine2, ProjectivePoint2, canonicalizeP, distance2PP, distancePPToPL, eToPL, interpolate2PP, join2PP, normalizeL, pPointOnPerpWithErr, pToEP, translateL, translateRotatePPoint2WithErr) -- | canonicalize a euclidian point. canonicalizePPoint2 :: PPoint2 -> CPPoint2 @@ -62,9 +61,6 @@ distanceBetweenPPoints point1 point2 = fst $ distance2PP (point1, mempty) (point distanceBetweenPPointsWithErr :: (ProjectivePoint2 a, ProjectivePoint2 b) => (a, PPoint2Err) -> (b, PPoint2Err) -> ℝ distanceBetweenPPointsWithErr point1 point2 = fst $ distance2PP point1 point2 -distanceBetweenPLines :: (ProjectiveLine2 a) => a -> a -> ℝ -distanceBetweenPLines nPLine1 nPLine2 = fst $ distance2PL nPLine1 nPLine2 - -- | Find the distance between a point and a line. distancePPointToPLine :: (ProjectivePoint2 a, ProjectiveLine2 b) => a -> b -> ℝ distancePPointToPLine point line = fst $ distancePPToPL (point, mempty) (line, mempty) diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index 4d07c521c..702475dff 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -64,14 +64,14 @@ import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(GEZero, GEPlu import Graphics.Slicer.Math.Intersections (outputIntersectsLineSeg) -import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenPLines, distancePPointToPLine, eToPLine2, getFirstArc, join2PPoint2, normalizePLine2, pPointOnPerp) +import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, distancePPointToPLine, eToPLine2, getFirstArc, join2PPoint2, normalizePLine2, pPointOnPerp) -- Our 2D Projective Geometric Algebra library. -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PLine2Err(PLine2Err), canonicalizeP, distance2PP, distancePPToPL, eToPL, eToPP, eToPP, interpolate2PP, intersect2PL, translateL, translateRotatePPoint2WithErr, angleBetween2PL, flipL, join2PP, makeCPPoint2, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), cPPointAndErrOf, intersectsWithErr, errOfOut, pPointOnPerpWithErr, outOf) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PLine2Err(PLine2Err), canonicalizeP, distance2PP, distancePPToPL, eToPL, eToPP, eToPP, interpolate2PP, intersect2PL, translateL, translateRotatePPoint2WithErr, angleBetween2PL, flipL, join2PP, makeCPPoint2, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), cPPointAndErrOf, distance2PL, intersectsWithErr, errOfOut, pPointOnPerpWithErr, outOf) -- The primitives of our PGA only library, and error estimation code. -import Graphics.Slicer.Math.PGAPrimitives (fuzzinessOfL, pLineErrAtPPoint, xIntercept, yIntercept) +import Graphics.Slicer.Math.PGAPrimitives (pLineErrAtPPoint, xIntercept, yIntercept) -- Our Contour library. import Graphics.Slicer.Math.Contour (contourContainsContour, getContours, pointsOfContour, numPointsOfContour, justOneContourFrom, lineSegsOfContour, makeLineSegContour, makePointContour, insideIsLeft, innerContourPoint, firstPointPairOfContour, firstLineSegOfContour) @@ -478,7 +478,7 @@ prop_OtherSideOfAxis v1 v2 p1 p2 xAxis positive -- | Ensure that a PLine translated, then translated back is approximately the same PLine. prop_PerpTranslateID :: ℝ -> ℝ -> NonZero ℝ -> NonZero ℝ -> NonZero ℝ -> Bool prop_PerpTranslateID x y dx dy rawT - | res <= resErr = res <= resErr + | res <= ulpVal resErr = res <= ulpVal resErr | otherwise = error $ "failed:\n" <> "origPLine: " <> show origPLine <> "\n" @@ -486,12 +486,11 @@ prop_PerpTranslateID x y dx dy rawT <> "res: " <> show res <> "\n" <> "resErr: " <> show resErr <> "\n" where - res = distanceBetweenPLines resPLine origPLine - (resPLine, resPLineErr) = translateL translatedPLine (-t) - (translatedPLine, translatedPLineErr) = translateL origPLine t + (res, (_,_, resErr)) = distance2PL resPLine origPLine + (resPLine, _) = translateL translatedPLine (-t) + (translatedPLine, _) = translateL origPLine t (origPLine, _) = randomPLineWithErr x y dx dy - resErr, t :: ℝ - resErr = ulpVal $ fuzzinessOfL (resPLine, resPLineErr) <> fuzzinessOfL (translatedPLine, translatedPLineErr) + t :: ℝ t = coerce rawT pgaSpec :: Spec From 0a819c281455f5cb37fe158e33448c29330d06ea Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Wed, 28 Dec 2022 13:59:59 +0000 Subject: [PATCH 177/206] remove unused lossy version of getInsideArc. --- Graphics/Slicer/Math/Lossy.hs | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index 7cd8b0db2..eec424404 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -26,7 +26,6 @@ module Graphics.Slicer.Math.Lossy ( distancePPointToPLineWithErr, eToPLine2, getFirstArc, - getInsideArc, join2CPPoint2, join2PPoint2, normalizePLine2, @@ -45,7 +44,7 @@ import Graphics.Slicer.Definitions (ℝ) import Graphics.Slicer.Math.Definitions (LineSeg, Point2, makeLineSeg) -import qualified Graphics.Slicer.Math.Arcs as Arcs (getFirstArc, getInsideArc) +import qualified Graphics.Slicer.Math.Arcs as Arcs (getFirstArc) import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PLine2Err, PPoint2, PPoint2Err, ProjectiveLine2, ProjectivePoint2, canonicalizeP, distance2PP, distancePPToPL, eToPL, interpolate2PP, join2PP, normalizeL, pPointOnPerpWithErr, pToEP, translateL, translateRotatePPoint2WithErr) @@ -78,9 +77,6 @@ eToPLine2 l1 = fst $ eToPL l1 getFirstArc :: Point2 -> Point2 -> Point2 -> PLine2 getFirstArc p1 p2 p3 = fst $ Arcs.getFirstArc p1 p2 p3 -getInsideArc :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> PLine2 -getInsideArc pl1 pl2 = fst $ Arcs.getInsideArc (pl1, mempty) (pl2, mempty) - -- | a typed join function. join two points, returning a line. join2PPoint2 :: (ProjectivePoint2 a) => a -> a -> PLine2 join2PPoint2 pp1 pp2 = fst $ join2PP pp1 pp2 From 68b60011154a3427edec8dcd8e96affecfcd5fa6 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Wed, 28 Dec 2022 14:06:06 +0000 Subject: [PATCH 178/206] remove unused join2CPPoint2 --- Graphics/Slicer/Math/Lossy.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index eec424404..be6160560 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -26,7 +26,6 @@ module Graphics.Slicer.Math.Lossy ( distancePPointToPLineWithErr, eToPLine2, getFirstArc, - join2CPPoint2, join2PPoint2, normalizePLine2, pLineFromEndpoints, @@ -81,10 +80,6 @@ getFirstArc p1 p2 p3 = fst $ Arcs.getFirstArc p1 p2 p3 join2PPoint2 :: (ProjectivePoint2 a) => a -> a -> PLine2 join2PPoint2 pp1 pp2 = fst $ join2PP pp1 pp2 --- | a typed join function. join two points, returning a line. -join2CPPoint2 :: (ProjectivePoint2 a) => a -> a -> PLine2 -join2CPPoint2 pp1 pp2 = fst $ join2PP pp1 pp2 - -- | Normalize a PLine2. normalizePLine2 :: (ProjectiveLine2 a) => a -> NPLine2 normalizePLine2 pl = fst $ normalizeL pl From 4f43afb01ef9936f3622b6b4a0980a14936db043 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Wed, 28 Dec 2022 14:15:40 +0000 Subject: [PATCH 179/206] remove unnecessary type casting. --- Graphics/Slicer/Math/Lossy.hs | 2 +- tests/Math/PGA.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index be6160560..26a9bf9c5 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -77,7 +77,7 @@ getFirstArc :: Point2 -> Point2 -> Point2 -> PLine2 getFirstArc p1 p2 p3 = fst $ Arcs.getFirstArc p1 p2 p3 -- | a typed join function. join two points, returning a line. -join2PPoint2 :: (ProjectivePoint2 a) => a -> a -> PLine2 +join2PPoint2 :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> PLine2 join2PPoint2 pp1 pp2 = fst $ join2PP pp1 pp2 -- | Normalize a PLine2. diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index 702475dff..37b85ea0b 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -945,7 +945,7 @@ prop_TriangleNoDivides centerX centerY rawRadians rawDists = findDivisions trian (myMidPoint,_) = interpolate2PP (eToPP p1) (eToPP p2) 0.5 0.5 -- we normalize this for Ganja.js. (NPLine2 pLineToInside) = normalizePLine2 $ join2PPoint2 myMidPoint innerPoint - (NPLine2 pLineToOutside) = normalizePLine2 $ join2PPoint2 innerPoint $ (\(CPPoint2 a) -> PPoint2 a) $ eToPP outsidePoint + (NPLine2 pLineToOutside) = normalizePLine2 $ join2PPoint2 innerPoint $ eToPP outsidePoint innerPoint = fromMaybe (dumpError2) maybeInnerPoint minPoint = fst $ minMaxPoints triangle outsidePoint = Point2 (xOf minPoint - 0.00000001 , yOf minPoint - 0.00000001) From 3c69e79264ce2cca54abf097d04653d673b5b4f1 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Wed, 28 Dec 2022 14:47:48 +0000 Subject: [PATCH 180/206] remove unnecessary normalization. --- tests/Math/PGA.hs | 71 +++++++++++++++++++++++------------------------ 1 file changed, 35 insertions(+), 36 deletions(-) diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index 37b85ea0b..88674399d 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -67,7 +67,7 @@ import Graphics.Slicer.Math.Intersections (outputIntersectsLineSeg) import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, distancePPointToPLine, eToPLine2, getFirstArc, join2PPoint2, normalizePLine2, pPointOnPerp) -- Our 2D Projective Geometric Algebra library. -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PLine2Err(PLine2Err), canonicalizeP, distance2PP, distancePPToPL, eToPL, eToPP, eToPP, interpolate2PP, intersect2PL, translateL, translateRotatePPoint2WithErr, angleBetween2PL, flipL, join2PP, makeCPPoint2, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), cPPointAndErrOf, distance2PL, intersectsWithErr, errOfOut, pPointOnPerpWithErr, outOf) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PLine2Err(PLine2Err), ProjectiveLine2, canonicalizeP, distance2PP, distancePPToPL, eToPL, eToPP, eToPP, interpolate2PP, intersect2PL, translateL, translateRotatePPoint2WithErr, angleBetween2PL, flipL, join2PP, makeCPPoint2, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), cPPointAndErrOf, distance2PL, intersectsWithErr, errOfOut, pPointOnPerpWithErr, outOf, vecOfL) -- The primitives of our PGA only library, and error estimation code. @@ -577,7 +577,7 @@ prop_QuadBisectorCrossesMultiple rawX1 rawY1 rawX2 rawY2 rawTimes <> show lineSeg2 <> "\n" <> show bisector1 <> "\n" <> show eNode <> "\n" - <> show (angleBetween2PL (normalizePLine2 $ outOf eNode) bisector1) <> "\n" + <> show (angleBetween2PL (outOf eNode) bisector1) <> "\n" <> "(" <> show x3 <> "," <> show y3 <> ")\n" <> "(" <> show x4 <> "," <> show y4 <> ")\n" where @@ -726,7 +726,7 @@ prop_LineSegIntersectionStableAtX1Y1Point pointD rawD1 x1 y1 rawX2 rawY2 | otherwise = (rawX2,rawY2) -- | A checker, to ensure an angle is what is expected. -myAngleBetween :: NPLine2 -> NPLine2 -> Bool +myAngleBetween :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Bool myAngleBetween a b | realToFrac res + (ulpRaw resErr) >= 1.0-(ulpRaw resErr) = True | otherwise = error @@ -764,16 +764,16 @@ prop_AxisAlignedRightAngles xPos yPos offset rawMagnitude1 rawMagnitude2 -- NOTE: hack, using angleBetween and >= to filter out minor numerical imprecision. prop_AxisAligned135DegreeAngles :: Bool -> Bool -> ℝ -> Positive ℝ -> Positive ℝ -> Bool prop_AxisAligned135DegreeAngles xPos yPos offset rawMagnitude1 rawMagnitude2 - | xPos && yPos = normalizePLine2 (getFirstArc (Point2 (offset,offset+mag1)) (Point2 (offset,offset)) (Point2 (offset+mag2,offset-mag2))) + | xPos && yPos = getFirstArc (Point2 (offset,offset+mag1)) (Point2 (offset,offset)) (Point2 (offset+mag2,offset-mag2)) `myAngleBetween` NPLine2 (GVec [GVal 0.3826834323650899 (singleton (GEPlus 1)), GVal (-0.9238795325112867) (singleton (GEPlus 2))]) - | xPos = normalizePLine2 (getFirstArc (Point2 (offset,-offset-mag1)) (Point2 (offset,-offset)) (Point2 (offset+mag2,mag2-offset))) + | xPos = getFirstArc (Point2 (offset,-offset-mag1)) (Point2 (offset,-offset)) (Point2 (offset+mag2,mag2-offset)) `myAngleBetween` NPLine2 (GVec [GVal (-0.3826834323650899) (singleton (GEPlus 1)), GVal (-0.9238795325112867) (singleton (GEPlus 2))]) - | not xPos && yPos = normalizePLine2 (getFirstArc (Point2 (-offset,offset+mag1)) (Point2 (-offset,offset)) (Point2 (-offset-mag2,offset-mag2))) + | not xPos && yPos = getFirstArc (Point2 (-offset,offset+mag1)) (Point2 (-offset,offset)) (Point2 (-offset-mag2,offset-mag2)) `myAngleBetween` NPLine2 (GVec [GVal 0.3826834323650899 (singleton (GEPlus 1)), GVal 0.9238795325112867 (singleton (GEPlus 2))]) - | otherwise = normalizePLine2 (getFirstArc (Point2 (-offset,-offset-mag1)) (Point2 (-offset,-offset)) (Point2 (-offset-mag2,mag2-offset))) + | otherwise = getFirstArc (Point2 (-offset,-offset-mag1)) (Point2 (-offset,-offset)) (Point2 (-offset-mag2,mag2-offset)) `myAngleBetween` NPLine2 (GVec [GVal (-0.3826834323650899) (singleton (GEPlus 1)), GVal 0.9238795325112867 (singleton (GEPlus 2))]) where @@ -785,16 +785,16 @@ prop_AxisAligned135DegreeAngles xPos yPos offset rawMagnitude1 rawMagnitude2 -- NOTE: hack, using angleBetween to filter out minor numerical imprecision. prop_AxisAligned45DegreeAngles :: Bool -> Bool -> ℝ -> Positive ℝ -> Positive ℝ -> Bool prop_AxisAligned45DegreeAngles xPos yPos offset rawMagnitude1 rawMagnitude2 - | xPos && yPos = normalizePLine2 (getFirstArc (Point2 (offset+mag1,offset+mag1)) (Point2 (offset,offset)) (Point2 (offset+mag2,offset))) + | xPos && yPos = getFirstArc (Point2 (offset+mag1,offset+mag1)) (Point2 (offset,offset)) (Point2 (offset+mag2,offset)) `myAngleBetween` NPLine2 (GVec [GVal 0.3826834323650899 (singleton (GEPlus 1)), GVal (-0.9238795325112867) (singleton (GEPlus 2))]) - | xPos = normalizePLine2 (getFirstArc (Point2 (offset+mag1,-offset-mag1)) (Point2 (offset,-offset)) (Point2 (offset+mag2,-offset))) + | xPos = getFirstArc (Point2 (offset+mag1,-offset-mag1)) (Point2 (offset,-offset)) (Point2 (offset+mag2,-offset)) `myAngleBetween` NPLine2 (GVec [GVal (-0.3826834323650899) (singleton (GEPlus 1)), GVal (-0.9238795325112867) (singleton (GEPlus 2))]) - | not xPos && yPos = normalizePLine2 (getFirstArc (Point2 (-offset-mag1,offset+mag1)) (Point2 (-offset,offset)) (Point2 (-offset-mag2,offset))) + | not xPos && yPos = getFirstArc (Point2 (-offset-mag1,offset+mag1)) (Point2 (-offset,offset)) (Point2 (-offset-mag2,offset)) `myAngleBetween` NPLine2 (GVec [GVal 0.3826834323650899 (singleton (GEPlus 1)), GVal 0.9238795325112867 (singleton (GEPlus 2))]) - | otherwise = normalizePLine2 (getFirstArc (Point2 (-offset-mag1,-offset-mag1)) (Point2 (-offset,-offset)) (Point2 (-offset-mag2,-offset))) + | otherwise = getFirstArc (Point2 (-offset-mag1,-offset-mag1)) (Point2 (-offset,-offset)) (Point2 (-offset-mag2,-offset)) `myAngleBetween` NPLine2 (GVec [GVal (-0.3826834323650899) (singleton (GEPlus 1)), GVal 0.9238795325112867 (singleton (GEPlus 2))]) where @@ -807,22 +807,22 @@ prop_AxisAligned45DegreeAngles xPos yPos offset rawMagnitude1 rawMagnitude2 -- NOTE: we use only one magnitude, because getOutsideArc requires normalized inputs. prop_AxisAlignedRightAnglesOutside :: Bool -> Bool -> ℝ -> Positive ℝ -> Bool prop_AxisAlignedRightAnglesOutside xPos yPos offset rawMagnitude - | xPos && yPos = normalizePLine2 (fst $ + | xPos && yPos = fst ( getOutsideArc (eToPP $ Point2 (offset,offset+mag), mempty) (eToPL $ LineSeg (Point2 (offset,offset+mag)) (Point2 (offset,offset))) (eToPP $ Point2 (offset+mag,offset), mempty) (eToPL $ LineSeg (Point2 (offset+mag,offset)) (Point2 (offset,offset)))) `myAngleBetween` NPLine2 (GVec [GVal (-0.7071067811865475) (singleton (GEPlus 1)), GVal 0.7071067811865475 (singleton (GEPlus 2))]) - | xPos = normalizePLine2 (fst $ + | xPos = fst ( getOutsideArc (eToPP $ Point2 (offset,-(offset+mag)), mempty) (eToPL $ LineSeg (Point2 (offset,-(offset+mag))) (Point2 (offset,-offset))) (eToPP $ Point2 (offset+mag,-offset), mempty) (eToPL $ LineSeg (Point2 (offset+mag,-offset)) (Point2 (offset,-offset)))) `myAngleBetween` NPLine2 (GVec [GVal 0.7071067811865475 (singleton (GEPlus 1)), GVal 0.7071067811865475 (singleton (GEPlus 2))]) - | not xPos && yPos = normalizePLine2 ( fst $ + | not xPos && yPos = fst ( getOutsideArc (eToPP $ Point2 (-offset,offset+mag), mempty) (eToPL $ LineSeg (Point2 (-offset,offset+mag)) (Point2 (-offset,offset))) (eToPP $ Point2 (-(offset+mag),offset), mempty) (eToPL $ LineSeg (Point2 (-(offset+mag),offset)) (Point2 (-offset,offset)))) `myAngleBetween` NPLine2 (GVec [GVal (-0.7071067811865475) (singleton (GEPlus 1)), GVal (-0.7071067811865475) (singleton (GEPlus 2))]) - | otherwise = normalizePLine2 ( fst $ + | otherwise = fst ( getOutsideArc (eToPP $ Point2 (-offset,-(offset+mag)), mempty) (eToPL $ LineSeg (Point2 (-offset,-(offset+mag))) (Point2 (-offset,-offset))) (eToPP $ Point2 (-(offset+mag),-offset), mempty) (eToPL $ LineSeg (Point2 (-(offset+mag),-offset)) (Point2 (-offset,-offset)))) `myAngleBetween` @@ -838,22 +838,22 @@ prop_AxisAlignedRightAnglesOutside xPos yPos offset rawMagnitude -- FIXME: expressing this with the second line in each of these pairs the other direction (head->tail vs tail->head) results in falsification? prop_AxisAligned135DegreeAnglesOutside :: Bool -> Bool -> Positive ℝ -> Positive ℝ -> Bool prop_AxisAligned135DegreeAnglesOutside xPos yPos rawOffset rawMagnitude - | xPos && yPos = normalizePLine2 ( fst $ + | xPos && yPos = fst ( getOutsideArc (eToPP $ Point2 (offset+mag,offset), mempty) (eToPL $ LineSeg (Point2 (offset+mag,offset)) (Point2 (offset,offset))) (eToPP $ Point2 (offset+mag,offset+mag), mempty) (eToPL $ LineSeg (Point2 (offset+mag,offset+mag)) (Point2 (offset,offset)))) `myAngleBetween` NPLine2 (GVec [GVal (-0.3826834323650899) (singleton (GEPlus 1)), GVal 0.9238795325112867 (singleton (GEPlus 2))]) - | xPos = normalizePLine2 ( fst $ + | xPos = fst ( getOutsideArc (eToPP $ Point2 (offset+mag,-offset), mempty) (eToPL $ LineSeg (Point2 (offset+mag,-offset)) (Point2 (offset,-offset))) (eToPP $ Point2 (offset+mag,-(offset+mag)), mempty) (eToPL $ LineSeg (Point2 (offset+mag,-(offset+mag))) (Point2 (offset,-offset)))) `myAngleBetween` NPLine2 (GVec [GVal 0.3826834323650899 (singleton (GEPlus 1)), GVal 0.9238795325112867 (singleton (GEPlus 2))]) - | not xPos && yPos = normalizePLine2 ( fst $ + | not xPos && yPos = fst ( getOutsideArc (eToPP $ Point2 (-(offset+mag),offset), mempty) (eToPL $ LineSeg (Point2 (-(offset+mag),offset)) (Point2 (-offset,offset))) (eToPP $ Point2 (-(offset+mag),offset+mag), mempty) (eToPL $ LineSeg (Point2 (-(offset+mag),offset+mag)) (Point2 (-offset,offset)))) `myAngleBetween` NPLine2 (GVec [GVal (-0.3826834323650899) (singleton (GEPlus 1)), GVal (-0.9238795325112867) (singleton (GEPlus 2))]) - | otherwise = normalizePLine2 ( fst $ + | otherwise = fst ( getOutsideArc (eToPP $ Point2 (-(offset+mag),-offset), mempty) (eToPL $ LineSeg (Point2 (-(offset+mag),-offset)) (Point2 (-offset,-offset))) (eToPP $ Point2 (-(offset+mag),-(offset+mag)), mempty) (eToPL $ LineSeg (Point2 (-(offset+mag),-(offset+mag))) (Point2 (-offset,-offset)))) `myAngleBetween` @@ -867,16 +867,16 @@ prop_AxisAligned135DegreeAnglesOutside xPos yPos rawOffset rawMagnitude -- NOTE: hack, using angleBetween to filter out minor numerical imprecision. prop_AxisAlignedRightAnglesInENode :: Bool -> Bool -> ℝ -> Positive ℝ -> Positive ℝ -> Bool prop_AxisAlignedRightAnglesInENode xPos yPos offset rawMagnitude1 rawMagnitude2 - | xPos && yPos = normalizePLine2 (outOf (onlyOne $ makeENodes [LineSeg (Point2 (offset,offset+mag1)) (Point2 (offset,offset)),LineSeg (Point2 (offset,offset)) (Point2 (offset+mag2,offset))])) + | xPos && yPos = outOf (onlyOne $ makeENodes [LineSeg (Point2 (offset,offset+mag1)) (Point2 (offset,offset)),LineSeg (Point2 (offset,offset)) (Point2 (offset+mag2,offset))]) `myAngleBetween` NPLine2 (GVec [GVal 0.7071067811865475 (singleton (GEPlus 1)), GVal (-0.7071067811865475) (singleton (GEPlus 2))]) - | xPos = normalizePLine2 (outOf (onlyOne $ makeENodes [LineSeg (Point2 (offset,-(offset+mag1))) (Point2 (offset,-offset)),LineSeg (Point2 (offset,-offset)) (Point2 (offset+mag2,-offset))])) + | xPos = outOf (onlyOne $ makeENodes [LineSeg (Point2 (offset,-(offset+mag1))) (Point2 (offset,-offset)),LineSeg (Point2 (offset,-offset)) (Point2 (offset+mag2,-offset))]) `myAngleBetween` NPLine2 (GVec [GVal (-0.7071067811865475) (singleton (GEPlus 1)), GVal (-0.7071067811865475) (singleton (GEPlus 2))]) - | not xPos && yPos = normalizePLine2 (outOf (onlyOne $ makeENodes [LineSeg (Point2 (-offset,offset+mag1)) (Point2 (-offset,offset)),LineSeg (Point2 (-offset,offset)) (Point2 (-(offset+mag2),offset))])) + | not xPos && yPos = outOf (onlyOne $ makeENodes [LineSeg (Point2 (-offset,offset+mag1)) (Point2 (-offset,offset)),LineSeg (Point2 (-offset,offset)) (Point2 (-(offset+mag2),offset))]) `myAngleBetween` NPLine2 (GVec [GVal 0.7071067811865475 (singleton (GEPlus 1)), GVal 0.7071067811865475 (singleton (GEPlus 2))]) - | otherwise = normalizePLine2 (outOf (onlyOne $ makeENodes [LineSeg (Point2 (-offset,-(offset+mag1))) (Point2 (-offset,-offset)),LineSeg (Point2 (-offset,-offset)) (Point2 (-(offset+mag2),-offset))])) + | otherwise = outOf (onlyOne $ makeENodes [LineSeg (Point2 (-offset,-(offset+mag1))) (Point2 (-offset,-offset)),LineSeg (Point2 (-offset,-offset)) (Point2 (-(offset+mag2),-offset))]) `myAngleBetween` NPLine2 (GVec [GVal (-0.7071067811865475) (singleton (GEPlus 1)), GVal 0.7071067811865475 (singleton (GEPlus 2))]) where @@ -888,16 +888,16 @@ prop_AxisAlignedRightAnglesInENode xPos yPos offset rawMagnitude1 rawMagnitude2 -- NOTE: hack, using angleBetween and >= to filter out minor numerical imprecision. prop_AxisAligned135DegreeAnglesInENode :: Bool -> Bool -> ℝ -> Positive ℝ -> Positive ℝ -> Bool prop_AxisAligned135DegreeAnglesInENode xPos yPos offset rawMagnitude1 rawMagnitude2 - | xPos && yPos = normalizePLine2 (outOf (onlyOne $ makeENodes [LineSeg (Point2 (offset,offset+mag1)) (Point2 (offset,offset)),LineSeg (Point2 (offset,offset)) (Point2 (offset+mag2,offset-mag2))])) + | xPos && yPos = outOf (onlyOne $ makeENodes [LineSeg (Point2 (offset,offset+mag1)) (Point2 (offset,offset)),LineSeg (Point2 (offset,offset)) (Point2 (offset+mag2,offset-mag2))]) `myAngleBetween` NPLine2 (GVec [GVal 0.3826834323650899 (singleton (GEPlus 1)), GVal (-0.9238795325112867) (singleton (GEPlus 2))]) - | xPos = normalizePLine2 (outOf (onlyOne $ makeENodes [LineSeg (Point2 (offset,-(offset+mag1))) (Point2 (offset,-offset)),LineSeg (Point2 (offset,-offset)) (Point2 (offset+mag2,-(offset-mag2)))])) + | xPos = outOf (onlyOne $ makeENodes [LineSeg (Point2 (offset,-(offset+mag1))) (Point2 (offset,-offset)),LineSeg (Point2 (offset,-offset)) (Point2 (offset+mag2,-(offset-mag2)))]) `myAngleBetween` NPLine2 (GVec [GVal (-0.3826834323650899) (singleton (GEPlus 1)), GVal (-0.9238795325112867) (singleton (GEPlus 2))]) - | not xPos && yPos = normalizePLine2 (outOf (onlyOne $ makeENodes [LineSeg (Point2 (-offset,offset+mag1)) (Point2 (-offset,offset)),LineSeg (Point2 (-offset,offset)) (Point2 (-(offset+mag2),offset-mag2))])) + | not xPos && yPos = outOf (onlyOne $ makeENodes [LineSeg (Point2 (-offset,offset+mag1)) (Point2 (-offset,offset)),LineSeg (Point2 (-offset,offset)) (Point2 (-(offset+mag2),offset-mag2))]) `myAngleBetween` NPLine2 (GVec [GVal 0.3826834323650899 (singleton (GEPlus 1)), GVal 0.9238795325112867 (singleton (GEPlus 2))]) - | otherwise = normalizePLine2 (outOf (onlyOne $ makeENodes [LineSeg (Point2 (-offset,-(offset+mag1))) (Point2 (-offset,-offset)),LineSeg (Point2 (-offset,-offset)) (Point2 (-(offset+mag2),-(offset-mag2)))])) + | otherwise = outOf (onlyOne $ makeENodes [LineSeg (Point2 (-offset,-(offset+mag1))) (Point2 (-offset,-offset)),LineSeg (Point2 (-offset,-offset)) (Point2 (-(offset+mag2),-(offset-mag2)))]) `myAngleBetween` NPLine2 (GVec [GVal (-0.3826834323650899) (singleton (GEPlus 1)), GVal 0.9238795325112867 (singleton (GEPlus 2))]) where @@ -909,16 +909,16 @@ prop_AxisAligned135DegreeAnglesInENode xPos yPos offset rawMagnitude1 rawMagnitu -- NOTE: hack, using angleBetween to filter out minor numerical imprecision. prop_AxisAligned45DegreeAnglesInENode :: Bool -> Bool -> ℝ -> Positive ℝ -> Positive ℝ -> Bool prop_AxisAligned45DegreeAnglesInENode xPos yPos offset rawMagnitude1 rawMagnitude2 - | xPos && yPos = normalizePLine2 (outOf (makeENode (Point2 (offset+mag1,offset+mag1)) (Point2 (offset,offset)) (Point2 (offset+mag2,offset)))) + | xPos && yPos = outOf (makeENode (Point2 (offset+mag1,offset+mag1)) (Point2 (offset,offset)) (Point2 (offset+mag2,offset))) `myAngleBetween` NPLine2 (GVec [GVal 0.3826834323650899 (singleton (GEPlus 1)), GVal (-0.9238795325112867) (singleton (GEPlus 2))]) - | xPos = normalizePLine2 (outOf (makeENode (Point2 (offset+mag1,-offset-mag1)) (Point2 (offset,-offset)) (Point2 (offset+mag2,-offset)))) + | xPos = outOf (makeENode (Point2 (offset+mag1,-offset-mag1)) (Point2 (offset,-offset)) (Point2 (offset+mag2,-offset))) `myAngleBetween` NPLine2 (GVec [GVal (-0.3826834323650899) (singleton (GEPlus 1)), GVal (-0.9238795325112867) (singleton (GEPlus 2))]) - | not xPos && yPos = normalizePLine2 (outOf (makeENode (Point2 (-offset-mag1,offset+mag1)) (Point2 (-offset,offset)) (Point2 (-offset-mag2,offset)))) + | not xPos && yPos = outOf (makeENode (Point2 (-offset-mag1,offset+mag1)) (Point2 (-offset,offset)) (Point2 (-offset-mag2,offset))) `myAngleBetween` NPLine2 (GVec [GVal 0.3826834323650899 (singleton (GEPlus 1)), GVal 0.9238795325112867 (singleton (GEPlus 2))]) - | otherwise = normalizePLine2 (outOf (makeENode (Point2 (-offset-mag1,-offset-mag1)) (Point2 (-offset,-offset)) (Point2 (-offset-mag2,-offset)))) + | otherwise = outOf (makeENode (Point2 (-offset-mag1,-offset-mag1)) (Point2 (-offset,-offset)) (Point2 (-offset-mag2,-offset))) `myAngleBetween` NPLine2 (GVec [GVal (-0.3826834323650899) (singleton (GEPlus 1)), GVal 0.9238795325112867 (singleton (GEPlus 2))]) where @@ -943,9 +943,8 @@ prop_TriangleNoDivides centerX centerY rawRadians rawDists = findDivisions trian firstPoints = firstPointPairOfContour triangle (p1, p2) = firstPointPairOfContour triangle (myMidPoint,_) = interpolate2PP (eToPP p1) (eToPP p2) 0.5 0.5 - -- we normalize this for Ganja.js. - (NPLine2 pLineToInside) = normalizePLine2 $ join2PPoint2 myMidPoint innerPoint - (NPLine2 pLineToOutside) = normalizePLine2 $ join2PPoint2 innerPoint $ eToPP outsidePoint + pLineToInside = vecOfL $ join2PPoint2 myMidPoint innerPoint + pLineToOutside = vecOfL $ join2PPoint2 innerPoint $ eToPP outsidePoint innerPoint = fromMaybe (dumpError2) maybeInnerPoint minPoint = fst $ minMaxPoints triangle outsidePoint = Point2 (xOf minPoint - 0.00000001 , yOf minPoint - 0.00000001) @@ -1375,9 +1374,9 @@ prop_translateRotateMoves x y rawD rawR = distanceBetweenPPoints (fst $ translat -- |ensure that a random PLine, when normed, is approximately equal to what went in. prop_NormPLineIsPLine :: ℝ -> ℝ -> NonZero ℝ -> NonZero ℝ -> Bool -prop_NormPLineIsPLine x y dx dy = normalizePLine2 (randomPLine x y dx dy) +prop_NormPLineIsPLine x y dx dy = randomPLine x y dx dy `myAngleBetween` - normalizePLine2 ((\(NPLine2 a) -> PLine2 a) $ normalizePLine2 $ randomPLine x y dx dy) + ((\(NPLine2 a) -> PLine2 a) $ normalizePLine2 $ randomPLine x y dx dy) prop_PLinesIntersectAtOrigin :: NonZero ℝ -> ℝ -> NonZero ℝ -> ℝ -> Bool prop_PLinesIntersectAtOrigin rawX y rawX2 rawY2 From d5427cae2357e8668ce2f074b25f59fb2d735775 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Wed, 28 Dec 2022 15:08:09 +0000 Subject: [PATCH 181/206] remove lossy normalizePLine2. --- Graphics/Slicer/Math/Lossy.hs | 7 +------ tests/Math/PGA.hs | 4 ++-- 2 files changed, 3 insertions(+), 8 deletions(-) diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index 26a9bf9c5..894031750 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -27,7 +27,6 @@ module Graphics.Slicer.Math.Lossy ( eToPLine2, getFirstArc, join2PPoint2, - normalizePLine2, pLineFromEndpoints, pPointBetweenPPoints, pPointOnPerp, @@ -45,7 +44,7 @@ import Graphics.Slicer.Math.Definitions (LineSeg, Point2, makeLineSeg) import qualified Graphics.Slicer.Math.Arcs as Arcs (getFirstArc) -import Graphics.Slicer.Math.PGA (CPPoint2, NPLine2, PLine2, PLine2Err, PPoint2, PPoint2Err, ProjectiveLine2, ProjectivePoint2, canonicalizeP, distance2PP, distancePPToPL, eToPL, interpolate2PP, join2PP, normalizeL, pPointOnPerpWithErr, pToEP, translateL, translateRotatePPoint2WithErr) +import Graphics.Slicer.Math.PGA (CPPoint2, PLine2, PLine2Err, PPoint2, PPoint2Err, ProjectiveLine2, ProjectivePoint2, canonicalizeP, distance2PP, distancePPToPL, eToPL, interpolate2PP, join2PP, pPointOnPerpWithErr, pToEP, translateL, translateRotatePPoint2WithErr) -- | canonicalize a euclidian point. canonicalizePPoint2 :: PPoint2 -> CPPoint2 @@ -80,10 +79,6 @@ getFirstArc p1 p2 p3 = fst $ Arcs.getFirstArc p1 p2 p3 join2PPoint2 :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> PLine2 join2PPoint2 pp1 pp2 = fst $ join2PP pp1 pp2 --- | Normalize a PLine2. -normalizePLine2 :: (ProjectiveLine2 a) => a -> NPLine2 -normalizePLine2 pl = fst $ normalizeL pl - -- | Create a projective line from a pair of euclidian points. pLineFromEndpoints :: Point2 -> Point2 -> PLine2 pLineFromEndpoints point1 point2 = fst $ eToPL $ makeLineSeg point1 point2 diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index 88674399d..ebf4e6a54 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -64,7 +64,7 @@ import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(GEZero, GEPlu import Graphics.Slicer.Math.Intersections (outputIntersectsLineSeg) -import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, distancePPointToPLine, eToPLine2, getFirstArc, join2PPoint2, normalizePLine2, pPointOnPerp) +import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, distancePPointToPLine, eToPLine2, getFirstArc, join2PPoint2, pPointOnPerp) -- Our 2D Projective Geometric Algebra library. import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PLine2Err(PLine2Err), ProjectiveLine2, canonicalizeP, distance2PP, distancePPToPL, eToPL, eToPP, eToPP, interpolate2PP, intersect2PL, translateL, translateRotatePPoint2WithErr, angleBetween2PL, flipL, join2PP, makeCPPoint2, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), cPPointAndErrOf, distance2PL, intersectsWithErr, errOfOut, pPointOnPerpWithErr, outOf, vecOfL) @@ -1376,7 +1376,7 @@ prop_translateRotateMoves x y rawD rawR = distanceBetweenPPoints (fst $ translat prop_NormPLineIsPLine :: ℝ -> ℝ -> NonZero ℝ -> NonZero ℝ -> Bool prop_NormPLineIsPLine x y dx dy = randomPLine x y dx dy `myAngleBetween` - ((\(NPLine2 a) -> PLine2 a) $ normalizePLine2 $ randomPLine x y dx dy) + fst ( normalizeL $ randomPLine x y dx dy) prop_PLinesIntersectAtOrigin :: NonZero ℝ -> ℝ -> NonZero ℝ -> ℝ -> Bool prop_PLinesIntersectAtOrigin rawX y rawX2 rawY2 From 11dabe528cc05151ac78058762e656ff3cf062f1 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Wed, 28 Dec 2022 15:24:53 +0000 Subject: [PATCH 182/206] remove unused pLineFromEndpoints. --- Graphics/Slicer/Math/Lossy.hs | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index 894031750..ee3db5aed 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -27,7 +27,6 @@ module Graphics.Slicer.Math.Lossy ( eToPLine2, getFirstArc, join2PPoint2, - pLineFromEndpoints, pPointBetweenPPoints, pPointOnPerp, pToEPoint2, @@ -40,7 +39,7 @@ import Prelude (($), fst, mempty) -- The numeric type in HSlice. import Graphics.Slicer.Definitions (ℝ) -import Graphics.Slicer.Math.Definitions (LineSeg, Point2, makeLineSeg) +import Graphics.Slicer.Math.Definitions (LineSeg, Point2) import qualified Graphics.Slicer.Math.Arcs as Arcs (getFirstArc) @@ -75,19 +74,16 @@ eToPLine2 l1 = fst $ eToPL l1 getFirstArc :: Point2 -> Point2 -> Point2 -> PLine2 getFirstArc p1 p2 p3 = fst $ Arcs.getFirstArc p1 p2 p3 --- | a typed join function. join two points, returning a line. +-- | A typed join function. join two points, returning a line. join2PPoint2 :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> PLine2 join2PPoint2 pp1 pp2 = fst $ join2PP pp1 pp2 --- | Create a projective line from a pair of euclidian points. -pLineFromEndpoints :: Point2 -> Point2 -> PLine2 -pLineFromEndpoints point1 point2 = fst $ eToPL $ makeLineSeg point1 point2 - +-- | Convert a projective endpoint to a euclidian endpoint. pToEPoint2 :: (ProjectivePoint2 a) => a -> Point2 pToEPoint2 pp = fst $ pToEP pp -- | Find a point somewhere along the line between the two points given. --- requires two weights. the ratio of these weights determines the position of the found points, E.G: (2/3,1/3) is 1/3 the way FROM the stopPoint, and 2/3 the way FROM the startPoint. weights can sum to anything. +-- Requires two weights. the ratio of these weights determines the position of the found points, E.G: (2/3,1/3) is 1/3 the way FROM the stopPoint, and 2/3 the way FROM the startPoint. weights can sum to anything. pPointBetweenPPoints :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> ℝ -> ℝ -> PPoint2 pPointBetweenPPoints startOfSeg stopOfSeg weight1 weight2 = fst $ interpolate2PP startOfSeg stopOfSeg weight1 weight2 From 88ecb6b4adffb3b5cc1fb17d327ff461788a45d3 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Thu, 29 Dec 2022 15:25:27 +0000 Subject: [PATCH 183/206] comment cleanups. --- Graphics/Slicer/Math/Lossy.hs | 2 +- Graphics/Slicer/Math/PGA.hs | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index ee3db5aed..979de4c05 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -91,7 +91,7 @@ pPointBetweenPPoints startOfSeg stopOfSeg weight1 weight2 = fst $ interpolate2PP pPointOnPerp :: (ProjectiveLine2 a, ProjectivePoint2 b) => a -> b -> ℝ -> PPoint2 pPointOnPerp pline ppoint d = fst $ pPointOnPerpWithErr pline ppoint d --- | translate a PLine2 along it's perpendicular bisector. +-- | translate a projective line along it's perpendicular bisector. translatePLine2 :: (ProjectiveLine2 a) => a -> ℝ -> PLine2 translatePLine2 pline distance = fst $ translateL pline distance diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index a48160e96..3ea4b2ebc 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -16,10 +16,10 @@ - along with this program. If not, see . -} --- for adding Generic and NFData to our types. +-- For adding Generic and NFData to our types. {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} --- for using Rounded flexibly. +-- For using Rounded flexibly. {-# LANGUAGE DataKinds #-} -- | The purpose of this file is to hold projective geometric algebraic arithmatic. It defines a 2D PGA with mixed linear components. From c3964c60a3a27afdd5e8a0cb1a586fb878524fb1 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Thu, 29 Dec 2022 20:59:20 +0000 Subject: [PATCH 184/206] rename errOfPPoint to errOfCPPoint. --- Graphics/Slicer/Math/PGA.hs | 12 ++++++------ Graphics/Slicer/Math/Skeleton/Definitions.hs | 8 ++++---- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 3ea4b2ebc..27d4710b5 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -40,7 +40,7 @@ module Graphics.Slicer.Math.PGA( canPoint, cPPointOf, ePointOf, - errOfPPoint + errOfCPPoint ), PPoint2(PPoint2), PPoint2Err, @@ -49,7 +49,8 @@ module Graphics.Slicer.Math.PGA( vecOfL ), ProjectivePoint2( - canonicalizeP + canonicalizeP, + vecOfP ), angleBetween2PL, canonicalizedIntersectionOf2PL, @@ -78,8 +79,7 @@ module Graphics.Slicer.Math.PGA( pPointsOnSameSideOfPLine, pToEP, translateL, - translateRotatePPoint2WithErr, - vecOfP + translateRotatePPoint2WithErr ) where import Prelude (Bool, Eq((==)), Monoid(mempty), Semigroup((<>)), Show(show), ($), (-), (>=), (&&), (<$>), (>), (<=), (+), (/), (||), (<), abs, cos, error, negate, otherwise, realToFrac, signum, sin) @@ -305,14 +305,14 @@ class (Show a) => Pointable a where -- | Get a euclidian representation of this point. ePointOf :: a -> Point2 -- | If the point is not a native euclidian point, the error generated while converting from a projective form. otherwise mempty. - errOfPPoint :: a -> PPoint2Err + errOfCPPoint :: a -> PPoint2Err -- | Get a canonicalized projective representation of this point. cPPointOf :: a -> CPPoint2 -- | If the given node can be resolved to a point, return it, along with it's error quotent. cPPointAndErrOf :: (Pointable a) => a -> (CPPoint2, PPoint2Err) cPPointAndErrOf node - | canPoint node = (cPPointOf node, errOfPPoint node) + | canPoint node = (cPPointOf node, errOfCPPoint node) | otherwise = error "not able to resolve node to a point." ---------------------------------------------------------- diff --git a/Graphics/Slicer/Math/Skeleton/Definitions.hs b/Graphics/Slicer/Math/Skeleton/Definitions.hs index a20ccfc33..29544fe85 100644 --- a/Graphics/Slicer/Math/Skeleton/Definitions.hs +++ b/Graphics/Slicer/Math/Skeleton/Definitions.hs @@ -57,7 +57,7 @@ import Graphics.Slicer.Math.Intersections (intersectionsAtSamePoint, noIntersect import Graphics.Slicer.Math.Lossy (eToPLine2) -import Graphics.Slicer.Math.PGA (Arcable(errOfOut, hasArc, outOf), CPPoint2, PIntersection(IntersectsIn), PLine2(PLine2), PLine2Err, Pointable(canPoint, cPPointOf, ePointOf, errOfPPoint), PPoint2Err, eToPL, eToPP, flipL, outAndErrOf, plinesIntersectIn, pLineIsLeft, pToEP) +import Graphics.Slicer.Math.PGA (Arcable(errOfOut, hasArc, outOf), CPPoint2, PIntersection(IntersectsIn), PLine2(PLine2), PLine2Err, Pointable(canPoint, cPPointOf, ePointOf, errOfCPPoint), PPoint2Err, eToPL, eToPP, flipL, outAndErrOf, plinesIntersectIn, pLineIsLeft, pToEP) -- | A point where two lines segments that are part of a contour intersect, emmiting an arc toward the interior of a contour. -- FIXME: a source should have a different UlpSum for it's point and it's output. @@ -85,7 +85,7 @@ instance Arcable ENode where instance Pointable ENode where canPoint _ = True ePointOf (ENode (_,centerPoint,_) _ _) = centerPoint - errOfPPoint _ = mempty + errOfCPPoint _ = mempty cPPointOf a = eToPP $ ePointOf a -- | A point in our straight skeleton where arcs intersect, resulting in the creation of another arc. @@ -123,7 +123,7 @@ instance Pointable INode where -- Just convert our resolved point. ePointOf a = fst $ pToEP $ fst $ cPPointAndErrOfINode a cPPointOf a = fst $ cPPointAndErrOfINode a - errOfPPoint a = snd $ cPPointAndErrOfINode a + errOfCPPoint a = snd $ cPPointAndErrOfINode a -- Since an INode does not contain a point, we have to attempt to resolve one instead. -- FIXME: if we have multiple intersecting pairs, is there a preferred pair to use for resolving? maybe a pair that is at as close as possible to a right angle? @@ -187,7 +187,7 @@ instance Pointable Motorcycle where canPoint _ = True cPPointOf a = eToPP $ ePointOf a ePointOf (Motorcycle (_, LineSeg point _) _ _) = point - errOfPPoint _ = mempty + errOfCPPoint _ = mempty -- | The motorcycles that are involved in dividing two cells. data DividingMotorcycles = DividingMotorcycles { firstMotorcycle :: !Motorcycle, moreMotorcycles :: !(Slist Motorcycle) } From 3bcb76e2f5a2311882d5e8417a05e6a55322dcc8 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Fri, 30 Dec 2022 00:10:13 +0000 Subject: [PATCH 185/206] formatting changes. --- Graphics/Slicer/Math/PGA.hs | 4 +-- Graphics/Slicer/Math/Skeleton/Definitions.hs | 32 ++++++++++---------- 2 files changed, 18 insertions(+), 18 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 27d4710b5..1e565bad5 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -302,12 +302,12 @@ outAndErrOf a class (Show a) => Pointable a where -- | Can this node be resolved into a point in 2d space? canPoint :: a -> Bool + -- | Get a canonicalized projective representation of this point. + cPPointOf :: a -> CPPoint2 -- | Get a euclidian representation of this point. ePointOf :: a -> Point2 -- | If the point is not a native euclidian point, the error generated while converting from a projective form. otherwise mempty. errOfCPPoint :: a -> PPoint2Err - -- | Get a canonicalized projective representation of this point. - cPPointOf :: a -> CPPoint2 -- | If the given node can be resolved to a point, return it, along with it's error quotent. cPPointAndErrOf :: (Pointable a) => a -> (CPPoint2, PPoint2Err) diff --git a/Graphics/Slicer/Math/Skeleton/Definitions.hs b/Graphics/Slicer/Math/Skeleton/Definitions.hs index 29544fe85..4e10d5a1b 100644 --- a/Graphics/Slicer/Math/Skeleton/Definitions.hs +++ b/Graphics/Slicer/Math/Skeleton/Definitions.hs @@ -84,9 +84,9 @@ instance Arcable ENode where -- | An ENode is always resolvable to a point. instance Pointable ENode where canPoint _ = True + cPPointOf a = eToPP $ ePointOf a ePointOf (ENode (_,centerPoint,_) _ _) = centerPoint errOfCPPoint _ = mempty - cPPointOf a = eToPP $ ePointOf a -- | A point in our straight skeleton where arcs intersect, resulting in the creation of another arc. data INode = INode @@ -120,29 +120,29 @@ instance Pointable INode where canPoint iNode = hasIntersectingPairs (allPLinesOfINode iNode) where hasIntersectingPairs (Slist pLines _) = any (\(pl1, pl2) -> not $ noIntersection pl1 pl2) $ getPairs pLines + cPPointOf a = fst $ cPPointAndErrOfINode a -- Just convert our resolved point. ePointOf a = fst $ pToEP $ fst $ cPPointAndErrOfINode a - cPPointOf a = fst $ cPPointAndErrOfINode a errOfCPPoint a = snd $ cPPointAndErrOfINode a -- Since an INode does not contain a point, we have to attempt to resolve one instead. -- FIXME: if we have multiple intersecting pairs, is there a preferred pair to use for resolving? maybe a pair that is at as close as possible to a right angle? cPPointAndErrOfINode :: INode -> (CPPoint2, PPoint2Err) cPPointAndErrOfINode iNode - | allPointsSame = case results of - [] -> error $ "cannot get a PPoint of this iNode: " <> show iNode <> "/n" - l -> PL.head l - -- Allow the pebbles to vote. - | otherwise = case safeLast (slist $ count_ results) of - Nothing -> error $ "cannot get a PPoint of this iNode: " <> show iNode <> "/n" - (Just a) -> fst a - where - results = intersectionsOfPairs $ allPLinesOfINode iNode - allPointsSame = intersectionsAtSamePoint ((\(Slist l _) -> l) $ allPLinesOfINode iNode) - intersectionsOfPairs (Slist pLines _) = mapMaybe (\(pl1, pl2) -> saneIntersect $ plinesIntersectIn pl1 pl2) $ getPairs pLines - where - saneIntersect (IntersectsIn p (_,_, pErr)) = Just (p, pErr) - saneIntersect _ = Nothing + | allPointsSame = case results of + [] -> error $ "cannot get a PPoint of this iNode: " <> show iNode <> "/n" + l -> PL.head l + -- Allow the pebbles to vote. + | otherwise = case safeLast (slist $ count_ results) of + Nothing -> error $ "cannot get a PPoint of this iNode: " <> show iNode <> "/n" + (Just a) -> fst a + where + results = intersectionsOfPairs $ allPLinesOfINode iNode + allPointsSame = intersectionsAtSamePoint ((\(Slist l _) -> l) $ allPLinesOfINode iNode) + intersectionsOfPairs (Slist pLines _) = mapMaybe (\(pl1, pl2) -> saneIntersect $ plinesIntersectIn pl1 pl2) $ getPairs pLines + where + saneIntersect (IntersectsIn p (_,_, pErr)) = Just (p, pErr) + saneIntersect _ = Nothing -- | Get all of the PLines that come from, or exit an iNode. allPLinesOfINode :: INode -> Slist (PLine2, PLine2Err) From a851060795efeb0c58d190b1bd7014853658e28d Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 1 Jan 2023 14:58:58 +0000 Subject: [PATCH 186/206] raise the err amount of angle comparison, so that isCollinear operates properly. --- Graphics/Slicer/Math/PGAPrimitives.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index dfed0e946..a49e5c969 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -205,6 +205,8 @@ angleBetweenProjectiveLines line1 line2 = (scalarPart likeRes, resErr) resErr = (npl1Err, npl2Err, (likeMulErr,likeAddErr), ulpSum) -- FIXME: this returned ULPsum is wrong. actually try to interpret it. ulpSum = sumErrVals likeMulErr <> sumErrVals likeAddErr + <> sumErrVals likeMulErr <> sumErrVals likeAddErr + <> sumErrVals likeMulErr <> sumErrVals likeAddErr (likeRes, (likeMulErr, likeAddErr)) = lv1 ⎣+ lv2 lv1 = vecOfL $ forceBasisOfL npl1 lv2 = vecOfL $ forceBasisOfL npl2 From ca2852dc371f1c4a2fe25031d0c80e587103d0de Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 1 Jan 2023 15:00:23 +0000 Subject: [PATCH 187/206] remove warnings. --- Graphics/Slicer/Machine/GCode.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/Graphics/Slicer/Machine/GCode.hs b/Graphics/Slicer/Machine/GCode.hs index 990b01558..b60650b6c 100644 --- a/Graphics/Slicer/Machine/GCode.hs +++ b/Graphics/Slicer/Machine/GCode.hs @@ -28,7 +28,7 @@ module Graphics.Slicer.Machine.GCode (GCode(GCMarkOuterWallStart, GCMarkInnerWal import GHC.Generics (Generic) -import Prelude (Eq, Int, Rational, Show, ($), zipWith, concat, (<>), show, error, otherwise, (==), length, fst, pi, (/), (*), pure, toRational, fromRational, (+), div, Bool, snd) +import Prelude (Bool, Eq, Int, Rational, Show, ($), (<>), (==), (/), (*), (+), concat, div, error, fromRational, fst, head, length, otherwise, pi, pure, show, snd, tail, toRational, zipWith) import Data.ByteString (ByteString) @@ -205,10 +205,12 @@ gcodeForContour lh pathWidth feedRate contour = addFeedRate feedRate headRes : t -- | For each group of lines, generate gcode for the segments, with move commands between them. gcodeForInfill :: ℝ -> ℝ -> ℝ -> ℝ -> [[LineSeg]] -> [GCode] gcodeForInfill _ _ _ _ [] = [] -gcodeForInfill lh pathWidth infillFeedRate travelFeedRate lineGroups = - case lineGroups of - (headGroup:tailGroups) -> concat $ renderLineSegGroup headGroup : zipWith (\group1 group2 -> moveBetweenLineSegGroups group1 group2 <> renderLineSegGroup group2) lineGroups tailGroups +gcodeForInfill lh pathWidth infillFeedRate travelFeedRate lineGroups + | lineGroups == [] = [] + | lineGroups == [[]] = [] + | otherwise = concat $ renderLineSegGroup headGroup : zipWith (\group1 group2 -> moveBetweenLineSegGroups group1 group2 <> renderLineSegGroup group2) lineGroups tailGroups where + (headGroup, tailGroups) = (head lineGroups, tail lineGroups) -- FIXME: this should be a single gcode. why are we getting empty line groups given to us? moveBetweenLineSegGroups :: [LineSeg] -> [LineSeg] -> [GCode] moveBetweenLineSegGroups g1 g2 = case unsnoc g1 of @@ -219,7 +221,7 @@ gcodeForInfill lh pathWidth infillFeedRate travelFeedRate lineGroups = renderLineSegGroup :: [LineSeg] -> [GCode] renderLineSegGroup lineSegSet = case lineSegSet of [] -> [] - (headGroup:tailGroups) -> renderSegment headGroup : concat (zipWith (\ l1 l2 -> moveBetween l1 l2 : [renderSegment l2]) lineSegSet tailGroups) + (myHeadGroup:myTailGroups) -> renderSegment myHeadGroup : concat (zipWith (\ l1 l2 -> moveBetween l1 l2 : [renderSegment l2]) lineSegSet myTailGroups) moveBetween :: LineSeg -> LineSeg -> GCode moveBetween l1 (LineSeg startPointl2 _) = addFeedRate travelFeedRate $ make2DTravelGCode (endPoint l1) startPointl2 renderSegment :: LineSeg -> GCode From 8d74dfc188c8441efdb7cd7ed77b62107efe3e6d Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 1 Jan 2023 15:04:13 +0000 Subject: [PATCH 188/206] fix intersect at origin test. --- tests/Math/PGA.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index ebf4e6a54..45fded330 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -1380,16 +1380,15 @@ prop_NormPLineIsPLine x y dx dy = randomPLine x y dx dy prop_PLinesIntersectAtOrigin :: NonZero ℝ -> ℝ -> NonZero ℝ -> ℝ -> Bool prop_PLinesIntersectAtOrigin rawX y rawX2 rawY2 - | foundDistance < realToFrac errSum = True + | foundDistance <= ulpVal distanceErr = True | otherwise = error $ "wtf" <> show intersectionErr <> "\n" where originPPoint2 = makeCPPoint2 0 0 - (foundDistance, (_,_,UlpSum distanceErr)) = distance2PP (originPPoint2, mempty) (intersectionPPoint2, intersectionErr) + (foundDistance, (_,_,distanceErr)) = distance2PP (originPPoint2, mempty) (intersectionPPoint2, intersectionErr) (intersectionPPoint2, (_,_,intersectionErr)) = intersect2PL randomPLine1 randomPLine2 (randomPLine1, _) = randomPLineThroughOrigin x y (randomPLine2, _) = randomPLineThroughOrigin x2 y2 - errSum = distanceErr -- + canonicalizationErr x,x2,y2 :: ℝ x = coerce rawX x2 From f08ddef97eea41378934d1d5764bc95954cd7a8f Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 1 Jan 2023 15:05:04 +0000 Subject: [PATCH 189/206] make the whole node tree traversal system aware of error quotents, but do not (yet) place these quotents on faces. --- Graphics/Slicer/Math/Skeleton/Concave.hs | 26 ++++---- Graphics/Slicer/Math/Skeleton/Definitions.hs | 18 +++--- Graphics/Slicer/Math/Skeleton/Face.hs | 68 ++++++++++---------- Graphics/Slicer/Math/Skeleton/NodeTrees.hs | 36 ++++++----- 4 files changed, 75 insertions(+), 73 deletions(-) diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index 0e1ad3c73..bd08419e7 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -28,7 +28,7 @@ module Graphics.Slicer.Math.Skeleton.Concave (skeletonOfConcaveRegion, findINodes, makeENode, makeENodes, averageNodes, eNodesOfOutsideContour) where -import Prelude (Eq, Show, Bool(True, False), Either(Left, Right), String, Ord, Ordering(GT,LT), all, notElem, otherwise, ($), (>), (<=), (<$>), (==), (/=), error, (&&), fst, (<>), show, not, max, compare, uncurry, null, (||), min, snd, filter, zip, any, (*), (+), Int, (.), (-), concatMap, mempty) +import Prelude (Eq, Show, Bool(True, False), Either(Left, Right), String, Ord, Ordering(GT,LT), all, notElem, otherwise, ($), (>), (<=), (<$>), (==), (/=), error, (&&), fst, (<>), show, not, max, compare, uncurry, null, (||), min, snd, filter, zip, any, (*), (+), Int, (.), (-), concatMap) import Prelude as PL (head, last, tail, init) @@ -238,7 +238,7 @@ findENodesInOrder eNodeSet@(ENodeSet (Slist [(_,_)] _)) generations = findENodes onlyINodeIn a = error $ "more than one inode: " <> show a <> "\n" findENodesOfInRecursive :: (PLine2,PLine2Err) -> [ENode] findENodesOfInRecursive myPLine - | isENode (fst myPLine) = [myENode] + | isENode myPLine = [myENode] | otherwise = -- must be an INode. recurse. case unsnoc ancestorGens of Nothing -> [] @@ -255,9 +255,9 @@ findENodesInOrder eNodeSet@(ENodeSet (Slist [(_,_)] _)) generations = findENodes first [] = error "found no INode?" first (v:_) = v where - myENode = fromMaybe (error "could not find ENode?") $ findENodeByOutput eNodeSet (fst myPLine) + myENode = fromMaybe (error "could not find ENode?") $ findENodeByOutput eNodeSet myPLine -- Determine if a PLine matches the output of an ENode. - isENode :: PLine2 -> Bool + isENode :: (PLine2, PLine2Err) -> Bool isENode myPLine2 = isJust $ findENodeByOutput eNodeSet myPLine2 findENodesInOrder a b = error $ "cannot find ENodes for :" <> show a <> "\n" <> show b <> "\n" @@ -372,9 +372,9 @@ sortINodesByENodes loop inSegSets inGens@(INodeSet rawGenerations) indexTo iNodes = iNodesBeforePLine iNodes <> iNodesAfterPLine iNodes where iNodesBeforePLine :: [INode] -> [INode] - iNodesBeforePLine = filter (\a -> (firstPLine, mempty) `pLineIsLeft` (firstInOf a, mempty) /= Just False) + iNodesBeforePLine = filter (\a -> firstPLine `pLineIsLeft` (firstInOf a) /= Just False) -- nodes in the right order, after the divide. - iNodesAfterPLine myINodes = withoutFlippedINodes $ filter (\a -> (firstPLine, mempty) `pLineIsLeft` (firstInOf a, mempty) == Just False) myINodes + iNodesAfterPLine myINodes = withoutFlippedINodes $ filter (\a -> firstPLine `pLineIsLeft` (firstInOf a) == Just False) myINodes withoutFlippedINodes maybeFlippedINodes = case flippedINodeOf maybeFlippedINodes of Nothing -> maybeFlippedINodes (Just a) -> filter (/= a) maybeFlippedINodes @@ -450,13 +450,13 @@ sortINodesByENodes loop inSegSets inGens@(INodeSet rawGenerations) [] -> error "could not find old connecting PLine." [v] -> v (_:_) -> error "filter passed too many connecting PLines." - iNodeInsOf myINode = filter (\a -> isNothing . findENodeByOutput (eNodeSetOf $ slist initialENodes) $ fst a) $ insOf myINode + iNodeInsOf myINode = filter (\a -> isNothing $ findENodeByOutput (eNodeSetOf $ slist initialENodes) a) $ insOf myINode withoutConnectingPLine = filter (/= oldConnectingPLine) -- Determine if the given INode has a PLine that points to an ENode. - hasENode iNode = any (isJust . findENodeByOutput (eNodeSetOf $ slist initialENodes)) $ fst <$> insOf iNode + hasENode iNode = any (isJust . findENodeByOutput (eNodeSetOf $ slist initialENodes)) $ insOf iNode -- Determine if the given INode has a PLine that points to another INode. - hasINode iNode = any (isNothing . findENodeByOutput (eNodeSetOf $ slist initialENodes)) $ fst <$> insOf iNode + hasINode iNode = any (isNothing . findENodeByOutput (eNodeSetOf $ slist initialENodes)) $ insOf iNode -- Construct an ENodeSet eNodeSetOf :: Slist ENode -> ENodeSet @@ -487,12 +487,12 @@ sortINodesByENodes loop inSegSets inGens@(INodeSet rawGenerations) -- | Sort a generation by the first in PLine. sortGeneration :: [INode] -> [INode] - sortGeneration = sortBy (\a b -> if (firstInOf a, mempty) `pLineIsLeft` (firstInOf b, mempty) == Just False then LT else GT) + sortGeneration = sortBy (\a b -> if (firstInOf a) `pLineIsLeft` (firstInOf b) == Just False then LT else GT) -- Find an inode connecting the first and last ENode, if it exists. -- FIXME: this functions, but i don't know why. :) flippedINodeOf :: [INode] -> Maybe INode - flippedINodeOf inodes = case filter (\a -> (firstPLine, mempty) `pLineIsLeft` (firstInOf a, mempty) == Just False) inodes of + flippedINodeOf inodes = case filter (\a -> firstPLine `pLineIsLeft` (firstInOf a) == Just False) inodes of [] -> Nothing [a] -> -- if there is only one result, it's going to only point to enodes. Just a @@ -507,7 +507,7 @@ sortINodesByENodes loop inSegSets inGens@(INodeSet rawGenerations) allInsAreENodes iNode = not $ hasINode iNode -- the output PLine of the first ENode in the input ENode set. - firstPLine = outOf firstENode + firstPLine = outAndErrOf firstENode where -- the first ENode given to us. for sorting uses. firstENode = first initialENodes @@ -527,7 +527,7 @@ sortINodesByENodes loop inSegSets inGens@(INodeSet rawGenerations) -- Order the input nodes of an INode. orderInsByENodes :: INode -> INode - orderInsByENodes inode@(INode _ _ _ out) = makeINode (indexPLinesTo firstPLine $ sortedPLinesWithErr $ indexPLinesTo firstPLine $ insOf inode) out + orderInsByENodes inode@(INode _ _ _ out) = makeINode (indexPLinesTo (fst firstPLine) $ sortedPLinesWithErr $ indexPLinesTo (fst firstPLine) $ insOf inode) out -- | Apply a recursive algorithm to obtain a raw INode set. -- FIXME: does not handle more than two point intersections of arcs properly. diff --git a/Graphics/Slicer/Math/Skeleton/Definitions.hs b/Graphics/Slicer/Math/Skeleton/Definitions.hs index 4e10d5a1b..ae98a7b5c 100644 --- a/Graphics/Slicer/Math/Skeleton/Definitions.hs +++ b/Graphics/Slicer/Math/Skeleton/Definitions.hs @@ -122,7 +122,7 @@ instance Pointable INode where hasIntersectingPairs (Slist pLines _) = any (\(pl1, pl2) -> not $ noIntersection pl1 pl2) $ getPairs pLines cPPointOf a = fst $ cPPointAndErrOfINode a -- Just convert our resolved point. - ePointOf a = fst $ pToEP $ fst $ cPPointAndErrOfINode a + ePointOf a = fst $ pToEP $ cPPointOf a errOfCPPoint a = snd $ cPPointAndErrOfINode a -- Since an INode does not contain a point, we have to attempt to resolve one instead. @@ -216,7 +216,7 @@ data MotorcycleIntersection = newtype RemainingContour = RemainingContour (Slist (Slist LineSeg, [CellDivide])) -- | The exterior nodes of a whole contour or just a cell of a contour. -newtype ENodeSet = ENodeSet { _eNodeSides :: Slist (ENode,Slist ENode) } +newtype ENodeSet = ENodeSet { _eNodeSides :: Slist (ENode, Slist ENode) } deriving Eq deriving stock Show @@ -290,7 +290,7 @@ linePairs contour = rotateRight $ mapWithNeighbors (\a b c -> (handleLineSegErro makeINode :: [(PLine2, PLine2Err)] -> Maybe (PLine2, PLine2Err) -> INode makeINode pLines maybeOut = case pLines of [] -> error "tried to construct a broken INode" - [onePLine] -> error $ "tried to construct a broken INode from one PLine2: " <> show onePLine <> "\n" + [onePLine] -> error $ "tried to construct a broken INode from one input: " <> show onePLine <> "\n" [first,second] -> INode first second (slist []) maybeOut (first:second:more) -> INode first second (slist more) maybeOut @@ -337,7 +337,7 @@ ancestorsOf (INodeSet generations) where ancestors = SL.init generations --- | Examine two line segments that are part of a Contour, and determine if they are concave toward the interior of the Contour. if they are, construct a PLine2 bisecting them, pointing toward the interior of the Contour. +-- | Examine two line segments that are part of a Contour, and determine if they are concave toward the interior of the Contour. if they are, construct a projective line bisecting them, pointing toward the interior of the Contour. concavePLines :: LineSeg -> LineSeg -> Maybe PLine2 concavePLines seg1 seg2 | Just True == pLineIsLeft (eToPL seg1) (eToPL seg2) = Just $ PLine2 $ addVecPair pv1 pv2 @@ -368,12 +368,12 @@ indexPLinesTo firstPLine pLines = pLinesBeforeIndex firstPLine pLines <> pLinesA pLinesAfterIndex myFirstPLine = filter (\a -> (myFirstPLine, mempty) `pLineIsLeft` a == Just False) -- | Find the last PLine of an INode. -lastInOf :: INode -> PLine2 +lastInOf :: INode -> (PLine2, PLine2Err) lastInOf (INode _ secondPLine morePLines _) - | isEmpty morePLines = fst $ secondPLine - | otherwise = fst $ SL.last morePLines + | isEmpty morePLines = secondPLine + | otherwise = SL.last morePLines -- | Find the first PLine of an INode. -firstInOf :: INode -> PLine2 -firstInOf (INode a _ _ _) = fst a +firstInOf :: INode -> (PLine2, PLine2Err) +firstInOf (INode a _ _ _) = a diff --git a/Graphics/Slicer/Math/Skeleton/Face.hs b/Graphics/Slicer/Math/Skeleton/Face.hs index 7a28238de..6e322182d 100644 --- a/Graphics/Slicer/Math/Skeleton/Face.hs +++ b/Graphics/Slicer/Math/Skeleton/Face.hs @@ -22,7 +22,7 @@ -- | This file contains code for creating a series of Faces, covering a straight skeleton. module Graphics.Slicer.Math.Skeleton.Face (Face(Face), orderedFacesOf, facesOf) where -import Prelude ((==), fst, otherwise, (<$>), ($), length, error, (<>), show, Eq, Show, (<>), Bool(True), null, not, and, snd, (&&), (>), (/=), mempty) +import Prelude ((==), fst, otherwise, (<$>), ($), length, error, (<>), show, Eq, Show, (<>), Bool(True), null, not, and, snd, (&&), (>), (/=)) import Data.List (uncons) @@ -131,7 +131,7 @@ facesOfNodeTree nodeTree@(NodeTree myENodes iNodeSet@(INodeSet generations)) allInsAreENodes myTarget = and $ isJust <$> (findENodeByOutput eNodes <$> inArcsOf myTarget) where -- Make a list of the PLines of an INode's input arcs. - inArcsOf (INode firstArc secondArc (Slist rawMoreArcs _) _) = fst <$> firstArc : secondArc : rawMoreArcs + inArcsOf (INode firstArc secondArc (Slist rawMoreArcs _) _) = firstArc : secondArc : rawMoreArcs -- | wrap getFaces so the first line segment of the input set is the first face given. rotateFaces :: INodeSet -> ENodeSet -> INode -> [Face] @@ -150,36 +150,36 @@ getFaces iNodeSet@(INodeSet myGenerations) eNodes iNode = findFacesRecurse iNode allPLines = sortedPLinesWithErr $ insOf iNode <> if hasArc iNode then [outAndErrOf iNode] else [] where insOf (INode pLine1 pLine2 (Slist morePLines _) _) = pLine1 : pLine2 : morePLines - firstPLine = fst $ head $ slist allPLines + firstPLine = head $ slist allPLines -- responsible for placing faces under the first pline given (if applicable), and between that pline, and the following pline. then.. recurse! findFacesRecurse :: INode -> [(PLine2, PLine2Err)] -> [Face] findFacesRecurse myINode pLines = case pLines of [] -> error "we should never get here." -- Just one PLine? assume we're the last one. do not place a face, but do place faces under the PLine. - [(onePLine,_)] -> placeFacesBeneath onePLine firstPLine - <> placeFaceBetween onePLine firstPLine + [onePLine] -> placeFacesBeneath onePLine firstPLine + <> placeFaceBetween onePLine firstPLine -- More than one PLine? place faces under onePLine, place a face between onePLine and anotherPLine, and recurse! - ((onePLine,_) : anotherPLine : myMorePLines) -> placeFacesBeneath onePLine (fst anotherPLine) - <> placeFaceBetween onePLine (fst anotherPLine) - <> findFacesRecurse myINode (anotherPLine:myMorePLines) + (onePLine : anotherPLine : myMorePLines) -> placeFacesBeneath onePLine anotherPLine + <> placeFaceBetween onePLine anotherPLine + <> findFacesRecurse myINode (anotherPLine:myMorePLines) where -- zero or one face, not a real list. - placeFaceBetween :: PLine2 -> PLine2 -> [Face] + placeFaceBetween :: (PLine2, PLine2Err) -> (PLine2, PLine2Err) -> [Face] placeFaceBetween onePLine anotherPLine - | hasArc myINode && outOf myINode == onePLine = [] -- don't place faces along the incoming PLine. the caller does that. - | hasArc myINode && outOf myINode == anotherPLine = [] -- don't place faces along the incoming PLine. the caller does that. + | hasArc myINode && isCollinear (outAndErrOf myINode) onePLine = [] -- don't place faces along the incoming PLine. the caller does that. + | hasArc myINode && isCollinear (outAndErrOf myINode) anotherPLine = [] -- don't place faces along the incoming PLine. the caller does that. | otherwise = [areaBetween iNodeSet eNodes onePLine anotherPLine] - placeFacesBeneath :: PLine2 -> PLine2 -> [Face] + placeFacesBeneath :: (PLine2, PLine2Err) -> (PLine2, PLine2Err) -> [Face] placeFacesBeneath onePLine anotherPLine - | isENode eNodes onePLine = [] -- don't climb down an enode, you're done - | hasArc myINode && onePLine == outOf myINode = [] -- don't try to climb back up the tree - | hasArc myINode && anotherPLine == outOf myINode = [] -- don't try to climb back up the tree + | isENode eNodes onePLine = [] -- don't climb down an enode, you're done + | hasArc myINode && isCollinear (outAndErrOf myINode) onePLine = [] -- don't try to climb back up the tree + | hasArc myINode && isCollinear (outAndErrOf myINode) anotherPLine = [] -- don't try to climb back up the tree | len myGenerations == 0 = error $ "wtf!\n" <> show onePLine <> "\n" <> show eNodes <> "\n" <> show iNodeSet | otherwise = getFaces (ancestorsOf iNodeSet) eNodes $ firstINodeOfPLine iNodeSet eNodes onePLine -- | Create a face covering the space between two PLines with a single Face. Both PLines must be a part of the same INode. -areaBetween :: INodeSet -> ENodeSet -> PLine2 -> PLine2 -> Face +areaBetween :: INodeSet -> ENodeSet -> (PLine2, PLine2Err) -> (PLine2, PLine2Err) -> Face areaBetween _ (ENodeSet (Slist [] _)) _ _ = error "no sides?" areaBetween _ (ENodeSet (Slist (_:_:_) _)) _ _ = error "too many sides?" areaBetween iNodeSet eNodeSet@(ENodeSet (Slist [(_,_)] _)) pLine1 pLine2 @@ -198,12 +198,12 @@ intraNodeFace :: NodeTree -> NodeTree -> Face intraNodeFace nodeTree1 nodeTree2 | nodeTree1 `isLeftOf` nodeTree2 = if nodeTree1 `follows` nodeTree2 then fromMaybe errNodesNotNeighbors $ - makeFace (firstENodeOf nodeTree1) (init (lastPLinesOf nodeTree1) <> tail (tail $ SL.reverse $ firstPLinesOf nodeTree2)) (lastENodeOf nodeTree2) + makeFace (firstENodeOf nodeTree1) (init (lastPLinesOf nodeTree1) <> tail (tail $ SL.reverse $ firstPLinesOf nodeTree2)) (lastENodeOf nodeTree2) else fromMaybe errNodesNotNeighbors $ - makeFace (firstENodeOf nodeTree1) (init (lastPLinesOf nodeTree1) <> tail (SL.reverse $ firstPLinesOf nodeTree2)) (lastENodeOf nodeTree2) + makeFace (firstENodeOf nodeTree1) (init (lastPLinesOf nodeTree1) <> tail (SL.reverse $ firstPLinesOf nodeTree2)) (lastENodeOf nodeTree2) | nodeTree1 `isRightOf` nodeTree2 = if nodeTree2 `follows` nodeTree1 then fromMaybe errNodesNotNeighbors $ - makeFace (lastENodeOf nodeTree2) (init (firstPLinesOf nodeTree2) <> tail (tail $ SL.reverse $ lastPLinesOf nodeTree1)) (firstENodeOf nodeTree1) + makeFace (lastENodeOf nodeTree2) (init (firstPLinesOf nodeTree2) <> tail (tail $ SL.reverse $ lastPLinesOf nodeTree1)) (firstENodeOf nodeTree1) else fromMaybe errNodesNotNeighbors $ makeFace (firstENodeOf nodeTree2) (init (firstPLinesOf nodeTree2) <> tail (SL.reverse $ lastPLinesOf nodeTree1)) (lastENodeOf nodeTree1) | nodeTree1 == nodeTree2 = error $ "two identical nodes given.\n" <> show nodeTree1 <> "\n" <> show nodeTree2 <> "\n" @@ -211,62 +211,62 @@ intraNodeFace nodeTree1 nodeTree2 where errNodesNotNeighbors = error $ "cannot make a face from nodes that are not neighbors: \n" <> show nodeTree1 <> "\n" <> show nodeTree2 <> "\n" follows :: NodeTree -> NodeTree -> Bool - follows nt1 nt2 = isCollinear (last $ firstPLinesOf nt1, mempty) (last $ lastPLinesOf nt2, mempty) + follows nt1 nt2 = isCollinear (last $ firstPLinesOf nt1) (last $ lastPLinesOf nt2) isLeftOf :: NodeTree -> NodeTree -> Bool isLeftOf nt1 nt2 = firstSegOf nt1 == lastSegOf nt2 isRightOf :: NodeTree -> NodeTree -> Bool isRightOf nt1 nt2 = lastSegOf nt1 == firstSegOf nt2 - lastPLinesOf :: NodeTree -> Slist PLine2 + lastPLinesOf :: NodeTree -> Slist (PLine2, PLine2Err) lastPLinesOf nodeTree = slist $ (\(a,_,_) -> a) $ pathLast nodeTree - firstPLinesOf :: NodeTree -> Slist PLine2 + firstPLinesOf :: NodeTree -> Slist (PLine2, PLine2Err) firstPLinesOf nodeTree = slist $ (\(a,_,_) -> a) $ pathFirst nodeTree -- Find the bottom ENode going down the last paths from the given PLine2. -lastDescendent :: INodeSet -> ENodeSet -> PLine2 -> ENode +lastDescendent :: INodeSet -> ENodeSet -> (PLine2, PLine2Err) -> ENode lastDescendent iNodeSet eNodeSet pLine | null $ pathToLastDescendent iNodeSet eNodeSet pLine = -- handle the case where we're asked for an ENode's output. fromMaybe (error "could not find ENode!") $ findENodeByOutput eNodeSet pLine | otherwise = fromMaybe (error $ "could not find ENode!\nLooking for: " <> show pLine <> "\nIn InodeSet: " <> show iNodeSet <> "\n") $ findENodeByOutput eNodeSet $ lastInOf $ lastINodeOfPLine iNodeSet eNodeSet pLine -- Find the bottom ENode going down the first paths from the given PLine2. -firstDescendent :: INodeSet -> ENodeSet -> PLine2 -> ENode +firstDescendent :: INodeSet -> ENodeSet -> (PLine2, PLine2Err) -> ENode firstDescendent iNodeSet eNodeSet pLine | null $ pathToFirstDescendent iNodeSet eNodeSet pLine = -- handle the case where we're asked for an ENode's output. fromMaybe (error "could not find ENode!") $ findENodeByOutput eNodeSet pLine | otherwise = fromMaybe (error "could not find ENode!") $ findENodeByOutput eNodeSet $ firstInOf $ firstINodeOfPLine iNodeSet eNodeSet pLine -- | find the First INode of a PLine. -firstINodeOfPLine :: INodeSet -> ENodeSet -> PLine2 -> INode +firstINodeOfPLine :: INodeSet -> ENodeSet -> (PLine2, PLine2Err) -> INode firstINodeOfPLine iNodeSet eNodeSet pLine = snd $ fromMaybe (error $ "could not find INode!\nLooking for: " <> show pLine <> "\nIn InodeSet: " <> show iNodeSet <> "\n") $ findINodeByOutput iNodeSet (last $ pathToFirstDescendent iNodeSet eNodeSet pLine) True -- | find the last INode of a PLine. -lastINodeOfPLine :: INodeSet -> ENodeSet -> PLine2 -> INode +lastINodeOfPLine :: INodeSet -> ENodeSet -> (PLine2, PLine2Err) -> INode lastINodeOfPLine iNodeSet eNodeSet pLine = snd $ fromMaybe (error "could not find INode!") $ findINodeByOutput iNodeSet (last $ pathToLastDescendent iNodeSet eNodeSet pLine) True -- | Find the parent inode of a given PLine2. -parentINodeOfPLine :: INodeSet -> PLine2 -> INode +parentINodeOfPLine :: INodeSet -> (PLine2, PLine2Err) -> INode parentINodeOfPLine iNodeSet pLine = snd $ fromMaybe (error $ "could not find INode!\nLooking for: " <> show pLine <> "\nIn INodeSet: " <> show iNodeSet <> "\n") $ findINodeByOutput iNodeSet pLine True -- | Determine if a PLine matches the output of an ENode. -isENode :: ENodeSet -> PLine2 -> Bool +isENode :: ENodeSet -> (PLine2, PLine2Err) -> Bool isENode eNodes pLine = isJust $ findENodeByOutput eNodes pLine -- | Travel down the INode tree, taking the 'First' path, marking down all of the pLine2s as we go, until we get to the bottom. -pathToFirstDescendent :: INodeSet -> ENodeSet -> PLine2 -> Slist PLine2 +pathToFirstDescendent :: INodeSet -> ENodeSet -> (PLine2, PLine2Err) -> Slist (PLine2, PLine2Err) pathToFirstDescendent iNodeSet eNodeSet pLine | isENode eNodeSet pLine = slist [] | otherwise = one pLine <> pathToFirstDescendent iNodeSet eNodeSet (firstInOf $ parentINodeOfPLine iNodeSet pLine) -- | Travel down the INode tree, taking the 'Last' path, marking down all of the pLine2s as we go, until we get to the bottom. -pathToLastDescendent :: INodeSet -> ENodeSet -> PLine2 -> Slist PLine2 +pathToLastDescendent :: INodeSet -> ENodeSet -> (PLine2, PLine2Err) -> Slist (PLine2, PLine2Err) pathToLastDescendent iNodeSet eNodeSet pLine | isENode eNodeSet pLine = slist [] | otherwise = one pLine <> pathToLastDescendent iNodeSet eNodeSet (lastInOf $ parentINodeOfPLine iNodeSet pLine) -- | Construct a face from two nodes, and a set of arcs. the nodes must follow each other on the contour. -makeFace :: ENode -> Slist PLine2 -> ENode -> Maybe Face -makeFace e1 arcs e2 - | getLastLineSeg e1 == getFirstLineSeg e2 = Just $ Face (getFirstLineSeg e2) (outOf e2) arcs (outOf e1) - | getFirstLineSeg e1 == getLastLineSeg e2 = Just $ Face (getFirstLineSeg e1) (outOf e1) arcs (outOf e2) +makeFace :: ENode -> Slist (PLine2, PLine2Err) -> ENode -> Maybe Face +makeFace e1 (Slist arcs _) e2 + | getLastLineSeg e1 == getFirstLineSeg e2 = Just $ Face (getFirstLineSeg e2) (outOf e2) (slist $ fst <$> arcs) (outOf e1) + | getFirstLineSeg e1 == getLastLineSeg e2 = Just $ Face (getFirstLineSeg e1) (outOf e1) (slist $ fst <$> arcs) (outOf e2) | otherwise = error $ "failed to match inputs:\nE1: " <> show e1 <> "\nE2: " <> show e2 <> "\n" diff --git a/Graphics/Slicer/Math/Skeleton/NodeTrees.hs b/Graphics/Slicer/Math/Skeleton/NodeTrees.hs index 5051b26a7..9e8b74f98 100644 --- a/Graphics/Slicer/Math/Skeleton/NodeTrees.hs +++ b/Graphics/Slicer/Math/Skeleton/NodeTrees.hs @@ -21,7 +21,7 @@ module Graphics.Slicer.Math.Skeleton.NodeTrees (firstENodeOf, firstSegOf, lastEN import Prelude (Bool(True,False), Eq, Show, (==), otherwise, snd, ($), error, (<>), notElem, show, (&&), (/=), null, (<$>), fst) -import Data.Maybe( Maybe(Just, Nothing), fromJust, fromMaybe, isJust) +import Data.Maybe( Maybe(Just, Nothing), fromMaybe, isJust) import Slist.Type (Slist(Slist)) @@ -31,9 +31,11 @@ import Slist as SL (filter, last, head, init, isEmpty) import Graphics.Slicer.Math.Definitions (LineSeg) +import Graphics.Slicer.Math.Intersections (isCollinear) + import Graphics.Slicer.Math.Skeleton.Definitions (ENode, INode(INode), ENodeSet(ENodeSet), INodeSet(INodeSet), NodeTree(NodeTree), finalINodeOf, finalPLine, getFirstLineSeg, getLastLineSeg, hasNoINodes, ancestorsOf, indexPLinesTo, makeINode, sortedPLinesWithErr) -import Graphics.Slicer.Math.PGA (PLine2, Arcable(hasArc, outOf)) +import Graphics.Slicer.Math.PGA (PLine2, PLine2Err, Arcable(hasArc, outOf), outAndErrOf) lastSegOf :: NodeTree -> LineSeg lastSegOf nodeTree = getLastLineSeg $ lastENodeOf nodeTree @@ -55,32 +57,32 @@ firstENodeOf (NodeTree (ENodeSet sides) _) = fst $ SL.head sides data Direction = Head | Last -pathFirst, pathLast :: NodeTree -> ([PLine2], [INode], ENode) +pathFirst, pathLast :: NodeTree -> ([(PLine2, PLine2Err)], [INode], ENode) pathFirst nodeTree = pathTo nodeTree Head pathLast nodeTree = pathTo nodeTree Last -- | Find all of the Nodes and all of the arcs between the last item in the nodeTree and the node that is part of the original contour on the given side. -pathTo :: NodeTree -> Direction -> ([PLine2], [INode], ENode) +pathTo :: NodeTree -> Direction -> ([(PLine2, PLine2Err)], [INode], ENode) pathTo (NodeTree (ENodeSet (Slist [] _)) _) _ = error "unable to pathTo a Nodetree without ENodes." pathTo (NodeTree eNodeSet@(ENodeSet eNodeSides) iNodeSet@(INodeSet generations)) direction | isEmpty generations = case eNodeSides of - (Slist [(firstENode,_)] _) -> ([outOf firstENode], [], firstENode) + (Slist [(firstENode,_)] _) -> ([outAndErrOf firstENode], [], firstENode) (Slist _ _) -> error "looking for a first ENode in an ENodeSet with more than one side." | otherwise = pathInner (ancestorsOf iNodeSet) eNodeSet (finalINodeOf iNodeSet) where - pathInner :: INodeSet -> ENodeSet -> INode -> ([PLine2], [INode], ENode) + pathInner :: INodeSet -> ENodeSet -> INode -> ([(PLine2, PLine2Err)], [INode], ENode) pathInner myINodeSet@(INodeSet myGenerations) myENodeSet target@(INode firstPLine secondPLine morePLines _) - | hasArc target = (outOf target : childPlines, target: endNodes, finalENode) - | otherwise = ( childPlines, target: endNodes, finalENode) + | hasArc target = (outAndErrOf target : childPlines, target: endNodes, finalENode) + | otherwise = ( childPlines, target: endNodes, finalENode) where - pLineToFollow = fst $ case direction of - Head -> firstPLine - Last -> SL.last (cons secondPLine morePLines) + pLineToFollow = case direction of + Head -> firstPLine + Last -> SL.last (cons secondPLine morePLines) iNodeOnThisLevel = findINodeByOutput myINodeSet pLineToFollow False iNodeOnLowerLevel = findINodeByOutput (ancestorsOf myINodeSet) pLineToFollow True result = findENodeByOutput myENodeSet pLineToFollow terminate = case result of - (Just eNode) -> ([outOf eNode], [], eNode) + (Just eNode) -> ([outAndErrOf eNode], [], eNode) Nothing -> error "FIXME: cannot happen." myError = error $ "could not find enode for " <> show pLineToFollow <> "\n" <> show eNodeSides <> "\n" <> show myINodeSet <> "\n" (childPlines, endNodes, finalENode) = if isJust result @@ -96,7 +98,7 @@ pathTo (NodeTree eNodeSet@(ENodeSet eNodeSides) iNodeSet@(INodeSet generations)) Nothing -> myError -- | Find an exterior Node with an output of the PLine given. -findENodeByOutput :: ENodeSet -> PLine2 -> Maybe ENode +findENodeByOutput :: ENodeSet -> (PLine2, PLine2Err) -> Maybe ENode findENodeByOutput (ENodeSet eNodeSides) plineOut = case eNodeSides of (Slist [] _) -> Nothing @@ -107,17 +109,17 @@ findENodeByOutput (ENodeSet eNodeSides) plineOut = (_:_) -> error "more than one eNode found?" where res = (`findENodeOnSideByOutput` plineOut) <$> sides where - findENodeOnSideByOutput :: (ENode,Slist ENode) -> PLine2 -> Maybe ENode + findENodeOnSideByOutput :: (ENode,Slist ENode) -> (PLine2, PLine2Err) -> Maybe ENode findENodeOnSideByOutput (firstENode,moreENodes) myPlineOut = case nodesMatching of (Slist [] _) -> Nothing (Slist [oneNode] _) -> Just oneNode (Slist (_:_) _)-> error "more than one exterior node with the same PLine out!" where - nodesMatching = SL.filter (\eNode -> outOf eNode == myPlineOut) (cons firstENode moreENodes) + nodesMatching = SL.filter (\eNode -> isCollinear (outAndErrOf eNode) myPlineOut) (cons firstENode moreENodes) -- | Find an INode that has an output of the PLine given. Check the most recent generation, and if recurse is set, check previous generations. -- Also returns the generation the INode was found in, it's generation, and it's prior generations. -findINodeByOutput :: INodeSet -> PLine2 -> Bool -> Maybe (INodeSet, INode) +findINodeByOutput :: INodeSet -> (PLine2, PLine2Err) -> Bool -> Maybe (INodeSet, INode) findINodeByOutput iNodeSet@(INodeSet generations) plineOut recurse | isEmpty generations = Nothing | otherwise = case nodesMatching of @@ -130,7 +132,7 @@ findINodeByOutput iNodeSet@(INodeSet generations) plineOut recurse (Slist [iNode] _) -> Just (iNodeSet, iNode) (Slist (_:_) _) -> error "more than one node in a the same generation with the same PLine out!" where - nodesMatching = SL.filter (\(INode _ _ _ a) -> isJust a && fst (fromJust a) == plineOut) $ slist (SL.last generations) + nodesMatching = SL.filter (\a -> hasArc a && isCollinear (outAndErrOf a) plineOut) $ slist (SL.last generations) -- | a smart constructor for a NodeTree makeNodeTree :: [ENode] -> INodeSet -> NodeTree From ab3c4d4d61635dcd2d0dce24f84865135d2ccc56 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 1 Jan 2023 15:22:09 +0000 Subject: [PATCH 190/206] add INLINABLE pragmas GHC requests. --- Graphics/Slicer/Math/Intersections.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/Graphics/Slicer/Math/Intersections.hs b/Graphics/Slicer/Math/Intersections.hs index 51cc42a79..af5c17518 100644 --- a/Graphics/Slicer/Math/Intersections.hs +++ b/Graphics/Slicer/Math/Intersections.hs @@ -52,18 +52,22 @@ noIntersection :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b noIntersection line1 line2 = isCollinear line1 line2 || isParallel line1 line2 || isAntiCollinear line1 line2 || isAntiParallel line1 line2 -- | Check if two lines are really the same line. +{-# INLINABLE isCollinear #-} isCollinear :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Bool isCollinear line1 line2 = plinesIntersectIn line1 line2 == PCollinear -- | Check if two lines are really the same line, reversed. +{-# INLINABLE isAntiCollinear #-} isAntiCollinear :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Bool isAntiCollinear line1 line2 = plinesIntersectIn line1 line2 == PAntiCollinear -- | Check if two lines are parallel. +{-# INLINABLE isParallel #-} isParallel :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Bool isParallel line1 line2 = plinesIntersectIn line1 line2 == PParallel -- | Check if two lines are anti-parallel. +{-# INLINABLE isAntiParallel #-} isAntiParallel :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Bool isAntiParallel line1 line2 = plinesIntersectIn line1 line2 == PAntiParallel From 89944f565fc55dc686c2c18266110bc2f55e35ba Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 1 Jan 2023 15:34:04 +0000 Subject: [PATCH 191/206] sort better. --- Graphics/Slicer/Math/Lossy.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index 979de4c05..482b214dd 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -39,13 +39,13 @@ import Prelude (($), fst, mempty) -- The numeric type in HSlice. import Graphics.Slicer.Definitions (ℝ) -import Graphics.Slicer.Math.Definitions (LineSeg, Point2) - import qualified Graphics.Slicer.Math.Arcs as Arcs (getFirstArc) +import Graphics.Slicer.Math.Definitions (LineSeg, Point2) + import Graphics.Slicer.Math.PGA (CPPoint2, PLine2, PLine2Err, PPoint2, PPoint2Err, ProjectiveLine2, ProjectivePoint2, canonicalizeP, distance2PP, distancePPToPL, eToPL, interpolate2PP, join2PP, pPointOnPerpWithErr, pToEP, translateL, translateRotatePPoint2WithErr) --- | canonicalize a euclidian point. +-- | Canonicalize a euclidian projective point. canonicalizePPoint2 :: PPoint2 -> CPPoint2 canonicalizePPoint2 point = fst $ canonicalizeP point @@ -78,10 +78,6 @@ getFirstArc p1 p2 p3 = fst $ Arcs.getFirstArc p1 p2 p3 join2PPoint2 :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> PLine2 join2PPoint2 pp1 pp2 = fst $ join2PP pp1 pp2 --- | Convert a projective endpoint to a euclidian endpoint. -pToEPoint2 :: (ProjectivePoint2 a) => a -> Point2 -pToEPoint2 pp = fst $ pToEP pp - -- | Find a point somewhere along the line between the two points given. -- Requires two weights. the ratio of these weights determines the position of the found points, E.G: (2/3,1/3) is 1/3 the way FROM the stopPoint, and 2/3 the way FROM the startPoint. weights can sum to anything. pPointBetweenPPoints :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> ℝ -> ℝ -> PPoint2 @@ -91,7 +87,11 @@ pPointBetweenPPoints startOfSeg stopOfSeg weight1 weight2 = fst $ interpolate2PP pPointOnPerp :: (ProjectiveLine2 a, ProjectivePoint2 b) => a -> b -> ℝ -> PPoint2 pPointOnPerp pline ppoint d = fst $ pPointOnPerpWithErr pline ppoint d --- | translate a projective line along it's perpendicular bisector. +-- | Convert a projective endpoint to a euclidian endpoint. +pToEPoint2 :: (ProjectivePoint2 a) => a -> Point2 +pToEPoint2 pp = fst $ pToEP pp + +-- | Translate a projective line along it's perpendicular bisector. translatePLine2 :: (ProjectiveLine2 a) => a -> ℝ -> PLine2 translatePLine2 pline distance = fst $ translateL pline distance From 4e659fdcdc05bffdf50c6ae572fbdac5ef71bc0e Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 1 Jan 2023 20:42:11 +0000 Subject: [PATCH 192/206] remove some ID tests, and use startPoint/endPoint. --- Graphics/Slicer/Math/Lossy.hs | 4 ++-- Graphics/Slicer/Math/PGA.hs | 22 ++++++++-------------- Graphics/Slicer/Math/PGAPrimitives.hs | 2 ++ 3 files changed, 12 insertions(+), 16 deletions(-) diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index 482b214dd..57a8cddf9 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -70,7 +70,7 @@ distancePPointToPLineWithErr point line = fst $ distancePPToPL point line eToPLine2 :: LineSeg -> PLine2 eToPLine2 l1 = fst $ eToPL l1 --- | Get a PLine in the direction of the inside of the contour, at the angle bisector of the intersection of the line segment, and another segment from the end of the given line segment, toward the given point. +-- | Get a PLine in the direction of the inside of the contour, at the angle bisector of the intersection of a line segment from p1 to p2, and a line segment from p3 to p2. getFirstArc :: Point2 -> Point2 -> Point2 -> PLine2 getFirstArc p1 p2 p3 = fst $ Arcs.getFirstArc p1 p2 p3 @@ -89,7 +89,7 @@ pPointOnPerp pline ppoint d = fst $ pPointOnPerpWithErr pline ppoint d -- | Convert a projective endpoint to a euclidian endpoint. pToEPoint2 :: (ProjectivePoint2 a) => a -> Point2 -pToEPoint2 pp = fst $ pToEP pp +pToEPoint2 ppoint = fst $ pToEP ppoint -- | Translate a projective line along it's perpendicular bisector. translatePLine2 :: (ProjectiveLine2 a) => a -> ℝ -> PLine2 diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 1e565bad5..abcbcef4f 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -102,7 +102,7 @@ import Numeric.Rounded.Hardware (Rounded, RoundingMode(TowardInf, TowardNegInf)) import Graphics.Slicer.Definitions (ℝ) -import Graphics.Slicer.Math.Definitions (Point2(Point2), LineSeg(LineSeg), addPoints, startPoint, endPoint, distance) +import Graphics.Slicer.Math.Definitions (Point2(Point2), LineSeg, startPoint, endPoint, distance) import Graphics.Slicer.Math.GeometricAlgebra (ErrVal, GNum(G0, GEPlus, GEZero), GVal(GVal), GVec(GVec), UlpSum(UlpSum), (⎤+), (⨅+), (•), addValWithoutErr, addVecPairWithoutErr, eValOf, getVal, mulScalarVecWithErr, ulpRaw, ulpVal, valOf) @@ -143,27 +143,22 @@ plinesIntersectIn (pl1, pl1Err) (pl2, pl2Err) | otherwise = IntersectsIn res (pl1Err <> npl1Err, pl2Err <> npl2Err, resErr) where -- | The distance within which we consider (anti)parallel lines to be (anti)colinear. - parallelFuzziness = ulpVal $ dErr <> pLineErrAtPPoint (npl1, npl1Err <> pl1Err) res <> pLineErrAtPPoint (npl2, npl2Err <> pl2Err) res + parallelFuzziness = ulpVal $ dErr <> pLineErrAtPPoint (pl1, pl1Err) res <> pLineErrAtPPoint (pl2, pl2Err) res -- | When two lines are really close to parallel or antiparallel, we use the distance between the lines to decide whether to promote them to being (anti)colinear. - (d, (_, _, dErr)) = distance2PL npl1 npl2 + (d, (_, _, dErr)) = distance2PL pl1 pl2 (idealNorm, idnErr) = idealNormOfP res - (res, (_, _, resErr)) = fromJust canonicalizedIntersection - canonicalizedIntersection = canonicalizedIntersectionOf2PL npl1 npl2 - (npl1, npl1Err) = normalizeL pl1 - (npl2, npl2Err) = normalizeL pl2 + (res, (npl1Err, npl2Err, resErr)) = fromJust canonicalizedIntersection + canonicalizedIntersection = canonicalizedIntersectionOf2PL pl1 pl2 -- | Check if the second line's direction is on the 'left' side of the first line, assuming they intersect. If they don't intersect, return Nothing. +{-# INLINABLE pLineIsLeft #-} pLineIsLeft :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Maybe Bool pLineIsLeft (pl1, _) (pl2, _) - -- | FIXME: Is there a way we can use Eq on a and b if they are the same type, rather than normalizing them first? - | npl1 == npl2 = Nothing | abs res <= angleFuzz = Nothing | otherwise = Just $ res > 0 where angleFuzz = ulpVal angleFuzzRaw (res, (_,_, angleFuzzRaw)) = angleCosBetween2PL pl1 pl2 - (npl1, _) = normalizeL pl1 - (npl2, _) = normalizeL pl2 -- | Find the distance between a projective point and a projective line, along with the difference's error quotent. -- Note: Fails in the case of ideal points. @@ -481,11 +476,10 @@ combineConsecutiveLineSegs lines = case lines of (Just v) -> if canCombineLineSegs v l1 then maybeToList (combineLineSegs v l1) <> (l2:initSafe ls) else v:l1:l2:initSafe ls -- | determine if two euclidian line segments are on the same projective line, and if they share a middle point. canCombineLineSegs :: LineSeg -> LineSeg -> Bool - canCombineLineSegs l1@(LineSeg p1 s1) l2@(LineSeg p2 _) = sameLineSeg && sameMiddlePoint + canCombineLineSegs l1 l2 = sameLineSeg && sameMiddlePoint where - -- FIXME: this does not take into account the Err introduced by eToPLine2. sameLineSeg = plinesIntersectIn (eToPL l1) (eToPL l2) == PCollinear - sameMiddlePoint = p2 == addPoints p1 s1 + sameMiddlePoint = startPoint l2 == endPoint l1 ------------------------------------------------ ----- And now draw the rest of the algebra ----- diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index a49e5c969..636a67526 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -484,6 +484,7 @@ angleCosBetweenProjectiveLines, angleCosBetween2PL :: (ProjectiveLine2 a, Projec -- FIXME: the sum of iPointErrVals is not +/- radians. -- FIXME: lots of places for precision related error here, that are not recorded or reported. -- FIXME: what was the older method we used here? perhaps it has less opportunities for fuzziness? +{-# INLINEABLE angleCosBetweenProjectiveLines #-} angleCosBetweenProjectiveLines line1 line2 | isNothing canonicalizedIntersection = (0, mempty) | otherwise = (angle, (npl1Err, npl2Err, sumPPointErrs iPointErrVals)) @@ -498,6 +499,7 @@ angleCosBetweenProjectiveLines line1 line2 lvec1 = vecOfL $ forceBasisOfL line1 lvec2 = vecOfL $ forceBasisOfL line2 -- | Wrapper. +{-# INLINEABLE angleCosBetween2PL #-} angleCosBetween2PL l1 l2 = angleCosBetweenProjectiveLines l1 l2 -- | Get the canonicalized intersection of two lines. From af88dfb6808455200eb75d9fca8bf062476b97fc Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Mon, 2 Jan 2023 16:12:34 +0000 Subject: [PATCH 193/206] add short circuits for Eq case of angleBetweenProjectiveLines, and distanceBetweenProjectiveLines. also, fix test case. --- Graphics/Slicer/Math/Lossy.hs | 1 - Graphics/Slicer/Math/PGAPrimitives.hs | 26 ++++++++++++++++++++------ tests/Math/PGA.hs | 2 +- 3 files changed, 21 insertions(+), 8 deletions(-) diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index 57a8cddf9..ba834818f 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -65,7 +65,6 @@ distancePPointToPLine point line = fst $ distancePPToPL (point, mempty) (line, m distancePPointToPLineWithErr :: (ProjectivePoint2 a, ProjectiveLine2 b) => (a, PPoint2Err) -> (b, PLine2Err) -> ℝ distancePPointToPLineWithErr point line = fst $ distancePPToPL point line - -- | Create an un-normalized projective line from a euclidian line segment. eToPLine2 :: LineSeg -> PLine2 eToPLine2 l1 = fst $ eToPL l1 diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index 636a67526..9a4ebca24 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -75,6 +75,8 @@ import Data.List (foldl', sort) import Data.Maybe (Maybe(Just,Nothing), fromJust, isJust, isNothing) +import Data.Typeable (Typeable, cast, typeOf) + import Data.Set (Set, elems, fromList, singleton) import GHC.Generics (Generic) @@ -144,14 +146,14 @@ forceBasis numsets (GVec vals) = GVec $ forceVal vals <$> sort numsets -- | A projective line in 2D space. newtype PLine2 = PLine2 GVec - deriving (Eq, Generic, NFData, Show) + deriving (Eq, Generic, NFData, Show, Typeable) -- | A normalized projective line in 2D space. newtype NPLine2 = NPLine2 GVec - deriving (Eq, Generic, NFData, Show) + deriving (Eq, Generic, NFData, Show, Typeable) -- | The typeclass definition. functions that must be implemented for any projective line type. -class (Show a) => ProjectiveLine2 a where +class (Eq a, Show a, Typeable a) => ProjectiveLine2 a where consLikeL :: a -> (GVec -> a) normalizeL :: a -> (NPLine2, PLine2Err) vecOfL :: a -> GVec @@ -200,10 +202,16 @@ instance Monoid PLine2Err where -- Results in a value that is ~+1 when a line points in the same direction of the other given line, and ~-1 when pointing backwards. {-# INLINABLE angleBetweenProjectiveLines #-} angleBetweenProjectiveLines :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, ([ErrVal], [ErrVal]), UlpSum)) -angleBetweenProjectiveLines line1 line2 = (scalarPart likeRes, resErr) +angleBetweenProjectiveLines line1 line2 + -- Short circuit (returning 1) if the two inputs are identical, and of the same type. + | typeOf line1 == typeOf line2 && line1 == fromJust (cast line2) = (1, mempty) + -- Short circuit (returning 1) if the two inputs are equivalent after normalization. + | npl1 == npl2 = (1, mempty) + -- Otherwise, calculate an answer. note the above can be commented out (ignored), as they are just speedups. + | otherwise = (scalarPart likeRes, resErr) where resErr = (npl1Err, npl2Err, (likeMulErr,likeAddErr), ulpSum) - -- FIXME: this returned ULPsum is wrong. actually try to interpret it. + -- FIXME: this returned ULPsum is wrong. actually try to interpret it. If you can get this to fail, add more repetitions, and pray really hard. ulpSum = sumErrVals likeMulErr <> sumErrVals likeAddErr <> sumErrVals likeMulErr <> sumErrVals likeAddErr <> sumErrVals likeMulErr <> sumErrVals likeAddErr @@ -222,7 +230,13 @@ angleBetween2PL l1 l2 = crushErr $ angleBetweenProjectiveLines l1 l2 -- | Find the distance between two parallel or antiparallel projective lines. {-# INLINABLE distanceBetweenProjectiveLines #-} distanceBetweenProjectiveLines :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, ([ErrVal], [ErrVal]), UlpSum)) -distanceBetweenProjectiveLines line1 line2 = (res, resErr) +distanceBetweenProjectiveLines line1 line2 + -- Short circuit (returning 0) if the two inputs are identical, and of the same type. + | typeOf line1 == typeOf line2 && line1 == fromJust (cast line2) = (0, mempty) + -- Short circuit (returning 0) if the two inputs are equvalent after normalization. + | npl1 == npl2 = (0, mempty) + -- Otherwise, calculate an answer. note the above can be commented out (ignored), as they are just speedups. + | otherwise = (res, resErr) where (res, idealErr) = idealNormOfP $ PPoint2 like resErr = (npl1Err, npl2Err, likeErr, idealErr) diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index 45fded330..7e8f558ac 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -1337,7 +1337,7 @@ prop_obtuseBisectorOnBiggerSide_makeENode x y d1 rawR1 d2 rawR2 testFirstLine bisector = (flipL $ outOf eNode, errOfOut eNode) prop_obtuseBisectorOnBiggerSide_makeINode :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> Positive ℝ -> Radian ℝ -> Bool -> Bool -> Expectation -prop_obtuseBisectorOnBiggerSide_makeINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 = (angleFound > (1-ulpVal angleErr), angleFound < realToFrac (-1 + (ulpRaw angleErr) :: Rounded 'TowardInf ℝ)) --> (True, False) +prop_obtuseBisectorOnBiggerSide_makeINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 = (angleFound >= (1-ulpVal angleErr), angleFound < realToFrac (-1 + (ulpRaw angleErr) :: Rounded 'TowardInf ℝ)) --> (True, False) where (angleFound, (_,_, angleErr)) = angleBetween2PL bisector1 bisector2 eNode = randomENode x y d1 rawR1 d2 rawR2 From c8b779a9906f07b596a6dca560f825e2bb89f2ab Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Mon, 2 Jan 2023 19:51:40 +0000 Subject: [PATCH 194/206] use oppositeDirection rather than re-implementing it (poorly). --- Graphics/Slicer/Math/PGA.hs | 1 + Graphics/Slicer/Math/Skeleton/Motorcycles.hs | 9 +++------ tests/Math/PGA.hs | 4 ++-- 3 files changed, 6 insertions(+), 8 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index abcbcef4f..1da3c8097 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -70,6 +70,7 @@ module Graphics.Slicer.Math.PGA( join2EP, join2PP, makeCPPoint2, + oppositeDirection, outAndErrOf, pLineErrAtPPoint, pLineIntersectsLineSeg, diff --git a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs index d19a7e1ee..42a058bed 100644 --- a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs +++ b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs @@ -52,9 +52,9 @@ import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, mapWithNeighb import Graphics.Slicer.Math.Intersections (intersectionOf, isAntiCollinear, noIntersection, outputIntersectsLineSeg, outputIntersectsPLineAt) -import Graphics.Slicer.Math.Lossy (pPointBetweenPPoints, distanceBetweenPPoints, distanceBetweenPPointsWithErr, eToPLine2, pToEPoint2) +import Graphics.Slicer.Math.Lossy (pPointBetweenPPoints, distanceBetweenPPoints, distanceBetweenPPointsWithErr, eToPLine2, join2PPoint2, pToEPoint2) -import Graphics.Slicer.Math.PGA (CPPoint2, PLine2, PLine2Err, PPoint2, PPoint2Err, Arcable(outOf), Pointable(canPoint, cPPointOf, ePointOf), cPPointAndErrOf, eToPL, flipL, pLineIsLeft, pPointsOnSameSideOfPLine, PIntersection(IntersectsIn,PAntiCollinear), ProjectivePoint2, angleBetween2PL, distance2PP, eToPP, join2EP, outAndErrOf, plinesIntersectIn, translateL) +import Graphics.Slicer.Math.PGA (CPPoint2, PLine2, PLine2Err, PPoint2, PPoint2Err, Arcable(outOf), Pointable(canPoint, cPPointOf, ePointOf), cPPointAndErrOf, eToPL, flipL, pLineIsLeft, pPointsOnSameSideOfPLine, PIntersection(IntersectsIn,PAntiCollinear), ProjectivePoint2, angleBetween2PL, distance2PP, eToPP, join2EP, oppositeDirection, outAndErrOf, plinesIntersectIn, translateL) import Graphics.Slicer.Math.Skeleton.Definitions (CellDivide(CellDivide), DividingMotorcycles(DividingMotorcycles), ENode(ENode), Motorcycle(Motorcycle), MotorcycleIntersection(WithLineSeg, WithENode, WithMotorcycle), getFirstLineSeg, linePairs) @@ -162,10 +162,7 @@ crashMotorcycles contour holes _ -> Nothing where intersectionPPoint = intersectionOf (outAndErrOf mot1) (outAndErrOf mot2) - intersectionIsBehind m = angleFound < ulpVal angleErr - where - (angleFound, (_,_, angleErr)) = angleBetween2PL (outOf m) (eToPLine2 $ lineSegToIntersection m) - lineSegToIntersection m = makeLineSeg (ePointOf m) (pToEPoint2 $ fst intersectionPPoint) + intersectionIsBehind m = oppositeDirection (outOf m) (join2PPoint2 (cPPointOf m) (fst intersectionPPoint)) -- | Find the non-reflex virtexes of a contour and draw motorcycles from them. Useful for contours that are a 'hole' in a bigger contour. -- This function is meant to be used on the exterior contour. diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index 7e8f558ac..7597f1dd3 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -47,10 +47,10 @@ import Data.List (foldl') import Data.Maybe (fromJust, fromMaybe, isNothing, Maybe(Just, Nothing)) -import Numeric.Rounded.Hardware (Rounded, RoundingMode(TowardInf)) - import Data.Set (singleton, fromList) +import Numeric.Rounded.Hardware (Rounded, RoundingMode(TowardInf)) + import Slist (slist, len) -- The numeric type in HSlice. From 509f426aa425d8cb8bcca54b8b0e6f900634eb01 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Mon, 2 Jan 2023 20:13:59 +0000 Subject: [PATCH 195/206] remove three more manual implementations. --- Graphics/Slicer/Math/Skeleton/Motorcycles.hs | 14 +++----------- 1 file changed, 3 insertions(+), 11 deletions(-) diff --git a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs index 42a058bed..4a8430daa 100644 --- a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs +++ b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs @@ -247,14 +247,8 @@ motorcycleMightIntersectWith lineSegs motorcycle then Nothing else Just intersection where - intersectionPointIsBehind point = angleFound < ulpVal angleErr - where - (angleFound, (_,_, angleErr)) = angleBetween2PL (outOf motorcycle) (eToPLine2 $ lineSegToIntersection point) - intersectionCPPointIsBehind pPoint = angleFound < ulpVal angleErr - where - (angleFound, (_,_, angleErr)) = angleBetween2PL (outOf motorcycle) (eToPLine2 $ lineSegToIntersectionP pPoint) - lineSegToIntersection myPoint = makeLineSeg (ePointOf motorcycle) myPoint - lineSegToIntersectionP myPPoint = makeLineSeg (ePointOf motorcycle) (pToEPoint2 myPPoint) + intersectionPointIsBehind point = oppositeDirection (outOf motorcycle) (eToPLine2 $ makeLineSeg (ePointOf motorcycle) point) + intersectionCPPointIsBehind pPoint = oppositeDirection (outOf motorcycle) (eToPLine2 $ makeLineSeg (ePointOf motorcycle) (pToEPoint2 pPoint)) -- | Find the closest place where a motorcycle intersects a contour that is not the point where it ejects from. -- If the motorcycle lands between two segments, return the second line segment, otherwise return the PPoint2 of the intersection with the first LineSeg. @@ -290,9 +284,7 @@ motorcycleIntersectsAt contour motorcycle = case intersections of then Nothing else Just intersection where - intersectionPointIsBehind point = angleFound < ulpVal angleErr - where - (angleFound, (_,_, angleErr)) = angleBetween2PL (outOf motorcycle) (eToPLine2 $ lineSegToIntersection point) + intersectionPointIsBehind point = oppositeDirection (outOf motorcycle) (eToPLine2 $ lineSegToIntersection point) intersectionPPointIsBehind pPoint = angleFound < ulpVal angleErr where (angleFound, (_,_, angleErr)) = angleBetween2PL (outOf motorcycle) (eToPLine2 $ lineSegToIntersectionP pPoint) From 299d76543123535230303d95a706542fac3e0caf Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Mon, 2 Jan 2023 20:39:08 +0000 Subject: [PATCH 196/206] remove more bad implementations of oppositeDirection. --- Graphics/Slicer/Math/Skeleton/Cells.hs | 7 ++----- Graphics/Slicer/Math/Skeleton/Motorcycles.hs | 10 +++------- 2 files changed, 5 insertions(+), 12 deletions(-) diff --git a/Graphics/Slicer/Math/Skeleton/Cells.hs b/Graphics/Slicer/Math/Skeleton/Cells.hs index ff3788659..bec823dbc 100644 --- a/Graphics/Slicer/Math/Skeleton/Cells.hs +++ b/Graphics/Slicer/Math/Skeleton/Cells.hs @@ -58,7 +58,7 @@ import Graphics.Slicer.Math.Intersections (intersectionBetweenArcsOf, isAntiColl import Graphics.Slicer.Math.Lossy (distanceBetweenPPoints, distanceBetweenPPointsWithErr, eToPLine2, pToEPoint2) -import Graphics.Slicer.Math.PGA (Arcable(outOf), CPPoint2, Pointable(canPoint, ePointOf, cPPointOf), angleBetween2PL, distance2PP, eToPL, eToPP, join2PP, outAndErrOf, cPPointAndErrOf) +import Graphics.Slicer.Math.PGA (Arcable(outOf), CPPoint2, Pointable(canPoint, ePointOf, cPPointOf), distance2PP, eToPL, eToPP, join2PP, oppositeDirection, outAndErrOf, cPPointAndErrOf) data UnsupportedReason = INodeCrossesDivide ![(INode,CellDivide)] !NodeTree deriving (Show, Eq) @@ -109,10 +109,7 @@ findDivisions contour crashTree = case motorcyclesIn crashTree of -- LOWHANGINGFRUIT: what about two motorcycles that are anticolinear? error "don't know what to do with these motorcycles." where - intersectionIsBehind m = angleFound < ulpVal angleErr - where - (angleFound, (_,_, angleErr)) = angleBetween2PL (outOf m) (eToPLine2 $ lineSegToIntersection m) - lineSegToIntersection m = makeLineSeg (ePointOf m) (pToEPoint2 intersectionPPoint) + intersectionIsBehind m = oppositeDirection (outOf m) (eToPLine2 $ makeLineSeg (ePointOf m) (pToEPoint2 intersectionPPoint)) (intersectionPPoint, _) = fromMaybe (error "has arcs, but no intersection?") $ intersectionBetweenArcsOf firstMC secondMC (Slist (_:_) _) -> error "too many motorcycles." motorcyclesIn (CrashTree motorcycles _ _) = motorcycles diff --git a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs index 4a8430daa..c14a6b6ed 100644 --- a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs +++ b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs @@ -54,7 +54,7 @@ import Graphics.Slicer.Math.Intersections (intersectionOf, isAntiCollinear, noIn import Graphics.Slicer.Math.Lossy (pPointBetweenPPoints, distanceBetweenPPoints, distanceBetweenPPointsWithErr, eToPLine2, join2PPoint2, pToEPoint2) -import Graphics.Slicer.Math.PGA (CPPoint2, PLine2, PLine2Err, PPoint2, PPoint2Err, Arcable(outOf), Pointable(canPoint, cPPointOf, ePointOf), cPPointAndErrOf, eToPL, flipL, pLineIsLeft, pPointsOnSameSideOfPLine, PIntersection(IntersectsIn,PAntiCollinear), ProjectivePoint2, angleBetween2PL, distance2PP, eToPP, join2EP, oppositeDirection, outAndErrOf, plinesIntersectIn, translateL) +import Graphics.Slicer.Math.PGA (CPPoint2, PLine2, PLine2Err, PPoint2, PPoint2Err, Arcable(outOf), Pointable(canPoint, cPPointOf, ePointOf), cPPointAndErrOf, eToPL, flipL, pLineIsLeft, pPointsOnSameSideOfPLine, PIntersection(IntersectsIn,PAntiCollinear), ProjectivePoint2, distance2PP, eToPP, join2EP, oppositeDirection, outAndErrOf, plinesIntersectIn, translateL) import Graphics.Slicer.Math.Skeleton.Definitions (CellDivide(CellDivide), DividingMotorcycles(DividingMotorcycles), ENode(ENode), Motorcycle(Motorcycle), MotorcycleIntersection(WithLineSeg, WithENode, WithMotorcycle), getFirstLineSeg, linePairs) @@ -284,12 +284,8 @@ motorcycleIntersectsAt contour motorcycle = case intersections of then Nothing else Just intersection where - intersectionPointIsBehind point = oppositeDirection (outOf motorcycle) (eToPLine2 $ lineSegToIntersection point) - intersectionPPointIsBehind pPoint = angleFound < ulpVal angleErr - where - (angleFound, (_,_, angleErr)) = angleBetween2PL (outOf motorcycle) (eToPLine2 $ lineSegToIntersectionP pPoint) - lineSegToIntersection myPoint = makeLineSeg (ePointOf motorcycle) myPoint - lineSegToIntersectionP myPPoint = makeLineSeg (ePointOf motorcycle) (pToEPoint2 myPPoint) + intersectionPointIsBehind point = oppositeDirection (outOf motorcycle) (eToPLine2 $ makeLineSeg (ePointOf motorcycle) point) + intersectionPPointIsBehind pPoint = oppositeDirection (outOf motorcycle) (eToPLine2 $ makeLineSeg (ePointOf motorcycle) (pToEPoint2 pPoint)) motorcyclePoint = cPPointOf motorcycle intersections = getMotorcycleContourIntersections motorcycle contour From 8edde5b476bb643e87e4d84b068de7f3e95ebcc5 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Mon, 2 Jan 2023 23:32:15 +0000 Subject: [PATCH 197/206] use ProjectivePoint2 more. --- Graphics/Slicer/Math/Lossy.hs | 2 +- Graphics/Slicer/Math/PGA.hs | 11 +++++------ 2 files changed, 6 insertions(+), 7 deletions(-) diff --git a/Graphics/Slicer/Math/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs index ba834818f..5aecdb0ae 100644 --- a/Graphics/Slicer/Math/Lossy.hs +++ b/Graphics/Slicer/Math/Lossy.hs @@ -46,7 +46,7 @@ import Graphics.Slicer.Math.Definitions (LineSeg, Point2) import Graphics.Slicer.Math.PGA (CPPoint2, PLine2, PLine2Err, PPoint2, PPoint2Err, ProjectiveLine2, ProjectivePoint2, canonicalizeP, distance2PP, distancePPToPL, eToPL, interpolate2PP, join2PP, pPointOnPerpWithErr, pToEP, translateL, translateRotatePPoint2WithErr) -- | Canonicalize a euclidian projective point. -canonicalizePPoint2 :: PPoint2 -> CPPoint2 +canonicalizePPoint2 :: (ProjectivePoint2 a) => a -> CPPoint2 canonicalizePPoint2 point = fst $ canonicalizeP point -- | Find the distance between two projective points. diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 1da3c8097..d73431775 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -155,11 +155,10 @@ plinesIntersectIn (pl1, pl1Err) (pl2, pl2Err) {-# INLINABLE pLineIsLeft #-} pLineIsLeft :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Maybe Bool pLineIsLeft (pl1, _) (pl2, _) - | abs res <= angleFuzz = Nothing - | otherwise = Just $ res > 0 + | abs res <= ulpVal angleFuzz = Nothing + | otherwise = Just $ res > 0 where - angleFuzz = ulpVal angleFuzzRaw - (res, (_,_, angleFuzzRaw)) = angleCosBetween2PL pl1 pl2 + (res, (_,_, angleFuzz)) = angleCosBetween2PL pl1 pl2 -- | Find the distance between a projective point and a projective line, along with the difference's error quotent. -- Note: Fails in the case of ideal points. @@ -210,7 +209,7 @@ sameDirection a b = res >= maxAngle -- ceiling value. a value bigger than maxAngle is considered to be going the same direction. maxAngle :: ℝ maxAngle = realToFrac (1 - ulpRaw resErr :: Rounded 'TowardInf ℝ) - (res, (_,_,resErr)) = angleBetween2PL a b + (res, (_,_, resErr)) = angleBetween2PL a b -- | A checker, to ensure two Projective Lines are going the opposite direction, and are parallel. oppositeDirection :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Bool @@ -219,7 +218,7 @@ oppositeDirection a b = res <= minAngle -- floor value. a value smaller than minAngle is considered to be going the opposite direction. minAngle :: ℝ minAngle = realToFrac (realToFrac (ulpRaw resErr) + (-1) :: Rounded 'TowardNegInf ℝ) - (res, (_,_,resErr)) = angleBetween2PL a b + (res, (_,_, resErr)) = angleBetween2PL a b -- | Find a projective point a given distance along a line perpendicularly bisecting the given line at a given point. -- FIXME: many operators here have error preserving forms, use those! From 34eadf866b61f98807ca53669d6574acede48eee Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Tue, 3 Jan 2023 14:00:39 +0000 Subject: [PATCH 198/206] INLINABLE, not INLINEABLE --- Graphics/Slicer/Math/PGAPrimitives.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index 9a4ebca24..7e650464f 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -75,10 +75,10 @@ import Data.List (foldl', sort) import Data.Maybe (Maybe(Just,Nothing), fromJust, isJust, isNothing) -import Data.Typeable (Typeable, cast, typeOf) - import Data.Set (Set, elems, fromList, singleton) +import Data.Typeable (Typeable, cast, typeOf) + import GHC.Generics (Generic) import Graphics.Slicer.Definitions (ℝ) @@ -498,7 +498,7 @@ angleCosBetweenProjectiveLines, angleCosBetween2PL :: (ProjectiveLine2 a, Projec -- FIXME: the sum of iPointErrVals is not +/- radians. -- FIXME: lots of places for precision related error here, that are not recorded or reported. -- FIXME: what was the older method we used here? perhaps it has less opportunities for fuzziness? -{-# INLINEABLE angleCosBetweenProjectiveLines #-} +{-# INLINABLE angleCosBetweenProjectiveLines #-} angleCosBetweenProjectiveLines line1 line2 | isNothing canonicalizedIntersection = (0, mempty) | otherwise = (angle, (npl1Err, npl2Err, sumPPointErrs iPointErrVals)) @@ -513,7 +513,7 @@ angleCosBetweenProjectiveLines line1 line2 lvec1 = vecOfL $ forceBasisOfL line1 lvec2 = vecOfL $ forceBasisOfL line2 -- | Wrapper. -{-# INLINEABLE angleCosBetween2PL #-} +{-# INLINABLE angleCosBetween2PL #-} angleCosBetween2PL l1 l2 = angleCosBetweenProjectiveLines l1 l2 -- | Get the canonicalized intersection of two lines. From dfd5228f50104381190d8ad814b91a4cafc5c271 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Tue, 3 Jan 2023 22:15:02 +0000 Subject: [PATCH 199/206] use Typeable to implement short circuits for distance, and join of points. --- Graphics/Slicer/Math/PGA.hs | 2 +- Graphics/Slicer/Math/PGAPrimitives.hs | 20 +++++++++++++++----- 2 files changed, 16 insertions(+), 6 deletions(-) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index d73431775..d1bb4ad8f 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -434,7 +434,7 @@ lineSegIntersectsLineSeg l1 l2 <> "tfuzz2: " <> show tFuzz2 <> "\n" -- | Given the result of intersectionPoint, find out whether this intersection point is on the given segment, or not. -onSegment :: LineSeg -> (CPPoint2, PPoint2Err) -> Bool +onSegment :: (ProjectivePoint2 a) => LineSeg -> (a, PPoint2Err) -> Bool onSegment ls i = (startDistance <= startFudgeFactor) || (midDistance <= (lengthOfSegment/2) + midFudgeFactor) diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index 7e650464f..b1377cf9b 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -577,11 +577,11 @@ instance Semigroup PPoint2Err where instance Monoid PPoint2Err where mempty = PPoint2Err mempty mempty mempty mempty mempty mempty mempty --- | A fake instance; so when we are sorting PPoint2, PPoint2Err pairs, the latter doesn't matter. +-- | A fake instance; so when we are sorting (PPoint2, PPoint2Err) pairs, the latter doesn't matter. instance Ord PPoint2Err where compare _ _ = EQ -class (Show a) => ProjectivePoint2 a where +class (Eq a, Show a, Typeable a) => ProjectivePoint2 a where canonicalizeP :: a -> (CPPoint2, PPoint2Err) consLikeP :: a -> (GVec -> a) isIdealP :: a -> Bool @@ -605,7 +605,7 @@ instance ProjectivePoint2 CPPoint2 where canonicalizeProjectivePoint :: (ProjectivePoint2 a) => a -> (CPPoint2, PPoint2Err) canonicalizeProjectivePoint point | isIdealP point = error $ "tried to canonicalize an ideal point: " <> show point <> "\n" - -- | Handle the ID case. The passed in point is canonicalized already. + -- Handle the ID case. The passed in point is canonicalized already. | valOf 1 foundVal == 1 = (CPPoint2 $ GVec rawVals, mempty) | otherwise = (res, PPoint2Err mempty scaledErrs mempty mempty mempty mempty mempty) where @@ -619,7 +619,11 @@ canonicalizeProjectivePoint point -- | Find the distance between two projective points, and the error component of the result. distanceBetweenProjectivePoints :: (ProjectivePoint2 a, ProjectivePoint2 b) => (a, PPoint2Err) -> (b, PPoint2Err) -> (ℝ, (PPoint2Err, PPoint2Err, PLine2Err, UlpSum)) distanceBetweenProjectivePoints (point1, point1Err) (point2, point2Err) + -- Short circuit (returning 0) if the two inputs are identical, and of the same type. + | typeOf point1 == typeOf point2 && point1 == fromJust (cast point2) = (0, mempty) + -- Short circuit (returning 0) if the two inputs are equivalent after canonicalization. | cPoint1 == cPoint2 = (0, (cPoint1Err, cPoint2Err, mempty, mempty)) + -- Otherwise, calculate an answer. note the above can be commented out (ignored), as they are just speedups. | otherwise = (res, resErr) where resErr = (cPoint1Err, cPoint2Err, newPLineErr, ulpSum) @@ -683,8 +687,14 @@ idealNormOfP p = idealNormOfProjectivePoint p {-# INLINABLE joinOfProjectivePoints #-} joinOfProjectivePoints, join2PP :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> (PLine2, (PPoint2Err, PPoint2Err, PLine2Err)) -- | Actual implementation. -joinOfProjectivePoints point1 point2 = (PLine2 res, - (cPoint1Err, cPoint2Err, PLine2Err mempty mempty mempty mempty mempty resUlp)) +joinOfProjectivePoints point1 point2 + -- Short circuit (returning 0) if the two inputs are identical, and of the same type. + | typeOf point1 == typeOf point2 && point1 == fromJust (cast point2) = (PLine2 (GVec []), mempty) + -- Short circuit (returning 0) if the two inputs are equivalent after canonicalization. + | cPoint1 == cPoint2 = (PLine2 (GVec []), (cPoint1Err, cPoint2Err, mempty)) + -- Otherwise, calculate an answer. note the above can be commented out (ignored), as they are just speedups. + | otherwise = (PLine2 res, + (cPoint1Err, cPoint2Err, PLine2Err mempty mempty mempty mempty mempty resUlp)) where -- FIXME: how does error in canonicalization effect the PLine generated here? (res, resUlp) = pv1 ∨+ pv2 From b2972b4ce99c37d909b609595f4c0f476af1e859 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Tue, 10 Jan 2023 21:47:50 +0000 Subject: [PATCH 200/206] make onSegment have a smaller hit box, make pLineIsLeft stop accepting error that it ignores, and fix a typo in pLineErrAtPPoint. --- Graphics/Slicer/Math/Contour.hs | 4 +-- Graphics/Slicer/Math/PGA.hs | 35 +++++++++++--------- Graphics/Slicer/Math/PGAPrimitives.hs | 2 +- Graphics/Slicer/Math/Skeleton/Concave.hs | 8 ++--- Graphics/Slicer/Math/Skeleton/Definitions.hs | 10 +++--- Graphics/Slicer/Math/Skeleton/Line.hs | 2 +- Graphics/Slicer/Math/Skeleton/Motorcycles.hs | 4 +-- tests/Math/PGA.hs | 33 ++++++++++++------ 8 files changed, 56 insertions(+), 42 deletions(-) diff --git a/Graphics/Slicer/Math/Contour.hs b/Graphics/Slicer/Math/Contour.hs index f9ce9f06e..c2afcb17a 100644 --- a/Graphics/Slicer/Math/Contour.hs +++ b/Graphics/Slicer/Math/Contour.hs @@ -227,12 +227,12 @@ followingLineSeg x = followingLineSegLooped x x -- | Check if the left hand side of the first line segment of a contour is toward the inside of the contour. insideIsLeft :: Contour -> Maybe Bool insideIsLeft contour - | isJust (innerContourPoint contour) = Just $ pLineIsLeft line1 (lineToInside, lineToInsideErr) == Just True + | isJust (innerContourPoint contour) = Just $ line1 `pLineIsLeft` lineToInside == Just True | otherwise = Nothing where (lineToInside, (_,_, lineToInsideErr)) = join2PP midPoint innerPoint midPoint = pPointBetweenPPoints (eToPP p1) (eToPP p2) 0.5 0.5 - line1 = join2EP p1 p2 + (line1,_) = join2EP p1 p2 innerPoint = fromJust $ innerContourPoint contour (p1, p2) = firstPointPairOfContour contour diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index d1bb4ad8f..87a837d83 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -153,12 +153,12 @@ plinesIntersectIn (pl1, pl1Err) (pl2, pl2Err) -- | Check if the second line's direction is on the 'left' side of the first line, assuming they intersect. If they don't intersect, return Nothing. {-# INLINABLE pLineIsLeft #-} -pLineIsLeft :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> Maybe Bool -pLineIsLeft (pl1, _) (pl2, _) +pLineIsLeft :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Maybe Bool +pLineIsLeft line1 line2 | abs res <= ulpVal angleFuzz = Nothing | otherwise = Just $ res > 0 where - (res, (_,_, angleFuzz)) = angleCosBetween2PL pl1 pl2 + (res, (_,_, angleFuzz)) = angleCosBetween2PL line1 line2 -- | Find the distance between a projective point and a projective line, along with the difference's error quotent. -- Note: Fails in the case of ideal points. @@ -435,23 +435,26 @@ lineSegIntersectsLineSeg l1 l2 -- | Given the result of intersectionPoint, find out whether this intersection point is on the given segment, or not. onSegment :: (ProjectivePoint2 a) => LineSeg -> (a, PPoint2Err) -> Bool -onSegment ls i = +onSegment lineSeg iPoint@(iP,_) = (startDistance <= startFudgeFactor) - || (midDistance <= (lengthOfSegment/2) + midFudgeFactor) + || (lineDistance <= lineFudgeFactor && (midDistance <= (lengthOfSegment/2) + midFudgeFactor)) || (endDistance <= endFudgeFactor) where - start = eToPP $ startPoint ls + startFudgeFactor = ulpVal $ startDistanceErr <> iErr <> tErr <> pLineErrAtPPoint pLine start + midFudgeFactor = ulpVal $ midDistanceErr <> iErr <> tErr <> pLineErrAtPPoint pLine mid + lineFudgeFactor = ulpVal $ iErr <> tErr <> pLineErrAtPPoint pLine iP + endFudgeFactor = ulpVal $ endDistanceErr <> iErr <> tErr <> pLineErrAtPPoint pLine end + (startDistance, (_,_, startDistanceErr)) = distance2PP iPoint (start, mempty) + (midDistance, (_,_, midDistanceErr)) = distance2PP iPoint (mid, midErr) + (lineDistance, _) = distancePPToPL iPoint pLine + (endDistance, (_,_, endDistanceErr)) = distance2PP iPoint (end, mempty) + lengthOfSegment = distance (startPoint lineSeg) (endPoint lineSeg) (mid, (_, _, midErr)) = interpolate2PP start end 0.5 0.5 - end = eToPP $ endPoint ls - (startDistance, (_,_, startDistanceErr)) = distance2PP i (start, mempty) - (midDistance, (_,_, midDistanceErr)) = distance2PP i (mid, midErr) - (endDistance, (_,_, endDistanceErr)) = distance2PP i (end, mempty) - tFuzz = fuzzinessOfL $ eToPL ls - lengthOfSegment = distance (startPoint ls) (endPoint ls) - startFudgeFactor, midFudgeFactor, endFudgeFactor :: ℝ - startFudgeFactor = ulpVal $ startDistanceErr <> tFuzz <> pLineErrAtPPoint (eToPL ls) start - midFudgeFactor = ulpVal $ midDistanceErr <> tFuzz <> pLineErrAtPPoint (eToPL ls) mid - endFudgeFactor = ulpVal $ endDistanceErr <> tFuzz <> pLineErrAtPPoint (eToPL ls) end + start = eToPP $ startPoint lineSeg + end = eToPP $ endPoint lineSeg + tErr = fuzzinessOfL pLine + iErr = fuzzinessOfP iPoint + pLine = eToPL lineSeg -- | Combine consecutive line segments. expects line segments with their end points connecting, EG, a contour generated by makeContours. combineConsecutiveLineSegs :: [LineSeg] -> [LineSeg] diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs index b1377cf9b..1c7068843 100644 --- a/Graphics/Slicer/Math/PGAPrimitives.hs +++ b/Graphics/Slicer/Math/PGAPrimitives.hs @@ -419,7 +419,7 @@ pLineErrAtPPoint (line, lineErr) errPoint yMin = getRounded $ realToFrac yInterceptDistance - (realToFrac (ulpVal rawYInterceptFuzz) :: Rounded 'TowardNegInf ℝ) rawYInterceptFuzz = snd $ fromJust $ yIntercept (nPLine, nPLineErr) rawXInterceptFuzz = snd $ fromJust $ xIntercept (nPLine, nPLineErr) - yInterceptDistance = abs $ fromRight 0 $ fst $ fromJust $ xIntercept (nPLine, nPLineErr) + yInterceptDistance = abs $ fromRight 0 $ fst $ fromJust $ yIntercept (nPLine, nPLineErr) xInterceptDistance = abs $ fromRight 0 $ fst $ fromJust $ xIntercept (nPLine, nPLineErr) -- FIXME: collect this error, and take it into account. (Point2 (xPos,yPos),_) = pToEP errPoint diff --git a/Graphics/Slicer/Math/Skeleton/Concave.hs b/Graphics/Slicer/Math/Skeleton/Concave.hs index bd08419e7..ea2f54b53 100644 --- a/Graphics/Slicer/Math/Skeleton/Concave.hs +++ b/Graphics/Slicer/Math/Skeleton/Concave.hs @@ -372,9 +372,9 @@ sortINodesByENodes loop inSegSets inGens@(INodeSet rawGenerations) indexTo iNodes = iNodesBeforePLine iNodes <> iNodesAfterPLine iNodes where iNodesBeforePLine :: [INode] -> [INode] - iNodesBeforePLine = filter (\a -> firstPLine `pLineIsLeft` (firstInOf a) /= Just False) + iNodesBeforePLine = filter (\a -> (fst firstPLine) `pLineIsLeft` (fst $ firstInOf a) /= Just False) -- nodes in the right order, after the divide. - iNodesAfterPLine myINodes = withoutFlippedINodes $ filter (\a -> firstPLine `pLineIsLeft` (firstInOf a) == Just False) myINodes + iNodesAfterPLine myINodes = withoutFlippedINodes $ filter (\a -> (fst firstPLine) `pLineIsLeft` (fst $ firstInOf a) == Just False) myINodes withoutFlippedINodes maybeFlippedINodes = case flippedINodeOf maybeFlippedINodes of Nothing -> maybeFlippedINodes (Just a) -> filter (/= a) maybeFlippedINodes @@ -487,12 +487,12 @@ sortINodesByENodes loop inSegSets inGens@(INodeSet rawGenerations) -- | Sort a generation by the first in PLine. sortGeneration :: [INode] -> [INode] - sortGeneration = sortBy (\a b -> if (firstInOf a) `pLineIsLeft` (firstInOf b) == Just False then LT else GT) + sortGeneration = sortBy (\a b -> if (fst $ firstInOf a) `pLineIsLeft` (fst $ firstInOf b) == Just False then LT else GT) -- Find an inode connecting the first and last ENode, if it exists. -- FIXME: this functions, but i don't know why. :) flippedINodeOf :: [INode] -> Maybe INode - flippedINodeOf inodes = case filter (\a -> firstPLine `pLineIsLeft` (firstInOf a) == Just False) inodes of + flippedINodeOf inodes = case filter (\a -> (fst firstPLine) `pLineIsLeft` (fst $ firstInOf a) == Just False) inodes of [] -> Nothing [a] -> -- if there is only one result, it's going to only point to enodes. Just a diff --git a/Graphics/Slicer/Math/Skeleton/Definitions.hs b/Graphics/Slicer/Math/Skeleton/Definitions.hs index ae98a7b5c..f06f7df74 100644 --- a/Graphics/Slicer/Math/Skeleton/Definitions.hs +++ b/Graphics/Slicer/Math/Skeleton/Definitions.hs @@ -340,7 +340,7 @@ ancestorsOf (INodeSet generations) -- | Examine two line segments that are part of a Contour, and determine if they are concave toward the interior of the Contour. if they are, construct a projective line bisecting them, pointing toward the interior of the Contour. concavePLines :: LineSeg -> LineSeg -> Maybe PLine2 concavePLines seg1 seg2 - | Just True == pLineIsLeft (eToPL seg1) (eToPL seg2) = Just $ PLine2 $ addVecPair pv1 pv2 + | Just True == (fst $ eToPL seg1) `pLineIsLeft` (fst $ eToPL seg2) = Just $ PLine2 $ addVecPair pv1 pv2 | otherwise = Nothing where (PLine2 pv1) = eToPLine2 seg1 @@ -354,18 +354,18 @@ hasNoINodes iNodeSet = case iNodeSet of -- | Sort a set of PLines. yes, this is 'backwards', to match the counterclockwise order of contours. sortedPLines :: [PLine2] -> [PLine2] -sortedPLines = sortBy (\n1 n2 -> if (n1, mempty) `pLineIsLeft` (n2, mempty) == Just True then LT else GT) +sortedPLines = sortBy (\n1 n2 -> if n1 `pLineIsLeft` n2 == Just True then LT else GT) -- | Sort a set of PLines. yes, this is 'backwards', to match the counterclockwise order of contours. sortedPLinesWithErr :: [(PLine2, PLine2Err)] -> [(PLine2, PLine2Err)] -sortedPLinesWithErr = sortBy (\n1 n2 -> if (n1 `pLineIsLeft` n2) == Just True then LT else GT) +sortedPLinesWithErr = sortBy (\(n1,_) (n2,_) -> if n1 `pLineIsLeft` n2 == Just True then LT else GT) -- | Take a sorted list of PLines, and make sure the list starts with the pline closest to (but not left of) the given PLine. indexPLinesTo :: PLine2 -> [(PLine2, PLine2Err)] -> [(PLine2, PLine2Err)] indexPLinesTo firstPLine pLines = pLinesBeforeIndex firstPLine pLines <> pLinesAfterIndex firstPLine pLines where - pLinesBeforeIndex myFirstPLine = filter (\a -> (myFirstPLine, mempty) `pLineIsLeft` a /= Just False) - pLinesAfterIndex myFirstPLine = filter (\a -> (myFirstPLine, mempty) `pLineIsLeft` a == Just False) + pLinesBeforeIndex myFirstPLine = filter (\(a,_) -> myFirstPLine `pLineIsLeft` a /= Just False) + pLinesAfterIndex myFirstPLine = filter (\(a,_) -> myFirstPLine `pLineIsLeft` a == Just False) -- | Find the last PLine of an INode. lastInOf :: INode -> (PLine2, PLine2Err) diff --git a/Graphics/Slicer/Math/Skeleton/Line.hs b/Graphics/Slicer/Math/Skeleton/Line.hs index 65727f593..31e9fd0d8 100644 --- a/Graphics/Slicer/Math/Skeleton/Line.hs +++ b/Graphics/Slicer/Math/Skeleton/Line.hs @@ -68,7 +68,7 @@ addLineSegsToFace distance insets face@(Face edge firstArc midArcs@(Slist rawMid ----------------------------------------------------------------------------------------- -- | The direction we need to translate our edge in order for it to be going inward. - translateDir v = case pLineIsLeft (eToPL edge) (firstArc, mempty) of + translateDir v = case pLineIsLeft (fst $ eToPL edge) firstArc of (Just True) -> (-v) (Just False) -> v Nothing -> error "cannot happen: edge and firstArc are the same line?" diff --git a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs index c14a6b6ed..9aad4cabf 100644 --- a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs +++ b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs @@ -182,8 +182,8 @@ convexMotorcycles contour = mapMaybe onlyMotorcycles $ zip (rotateLeft $ linePai | otherwise = Just resPLine where resPLine = motorcycleFromPoints p1 p2 p3 - pl1 = eToPL $ makeLineSeg p1 p2 - pl2 = eToPL $ makeLineSeg p2 p3 + pl1 = fst $ eToPL $ makeLineSeg p1 p2 + pl2 = fst $ eToPL $ makeLineSeg p2 p3 -- | generate the PLine2 of a motorcycle created by the three points given. motorcycleFromPoints :: Point2 -> Point2 -> Point2 -> (PLine2, PLine2Err) diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index 7597f1dd3..0139fdb6f 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -363,13 +363,22 @@ prop_TwoAxisAlignedLines d1 d2 r1 r2 = (\(GVec gVals) -> bases gVals) ((\(PLine2 bases gvals = (\(GVal _ base) -> base) <$> gvals -- | A property test making sure that the scalar part of the big-dot product of two identical PLines is not zero. -prop_TwoOverlappingLinesScalar :: ℝ -> ℝ -> NonZero ℝ -> NonZero ℝ -> Bool -prop_TwoOverlappingLinesScalar x y dx dy = scalarPart ((\(PLine2 a) -> a) (randomPLine x y dx dy) • (\(PLine2 a) -> a) (randomPLine x y dx dy)) /= 0 +prop_TwoOverlappingLinesScalar :: ℝ -> ℝ -> NonZero ℝ -> NonZero ℝ -> ℝ -> ℝ -> NonZero ℝ -> NonZero ℝ -> Bool +prop_TwoOverlappingLinesScalar x1 y1 dx1 dy1 x2 y2 dx2 dy2 = scalarPart ((vecOfL pl1) • (vecOfL pl2)) /= 0 + where + pl1 = randomPLine x1 y1 dx1 dy1 + pl2 = randomPLine x2 y2 dx2 dy2 -- | A property test for making sure that there is never a vector result of the big-dot product of two identical PLines. prop_TwoOverlappingLinesVector :: ℝ -> ℝ -> NonZero ℝ -> NonZero ℝ -> Expectation prop_TwoOverlappingLinesVector x y dx dy = vectorPart ((\(PLine2 a) -> a) (randomPLine x y dx dy) • (\(PLine2 a) -> a) (randomPLine x y dx dy)) --> GVec [] +-- | A property test making sure that the scalar part of the big-dot product of two identical PLines is not zero. +prop_TwoIdenticalLinesScalar :: ℝ -> ℝ -> NonZero ℝ -> NonZero ℝ -> Bool +prop_TwoIdenticalLinesScalar x y dx dy = scalarPart ((vecOfL pl1) • (vecOfL pl1)) /= 0 + where + pl1 = randomPLine x y dx dy + proj2DGeomAlgSpec :: Spec proj2DGeomAlgSpec = do describe "Points (Math/PGA)" $ @@ -388,6 +397,8 @@ proj2DGeomAlgSpec = do GVec [GVal (-2) (fromList [GEZero 1, GEPlus 1]), GVal 2 (fromList [GEZero 1, GEPlus 2]), GVal (-1) (fromList [GEPlus 1, GEPlus 2])] it "the geometric product of any two overlapping lines is only a Scalar" $ property prop_TwoOverlappingLinesScalar + it "the geometric product of two identical lines is only a Scalar" $ + property prop_TwoIdenticalLinesScalar it "the geometric product of any two overlapping lines does not have produce a vector component" $ property prop_TwoOverlappingLinesVector it "A line constructed from a line segment is correct" $ @@ -538,7 +549,7 @@ prop_QuadBisectorCrosses rawX1 rawY1 rawX2 rawY2 bisector1Err = bisectorRawErr <> bisector1NormErr bisector2 = getFirstArc (Point2 (x1,y1)) (Point2 (0,0)) (Point2 (x2,y2)) eNode = makeENode (Point2 (x1,y1)) (Point2 (0,0)) (Point2 (x2,y2)) - -- X1, Y1 and X2 forced uniqueness. additionally, forced "not 180 degree opposition). + -- X1, Y1 and X2 forced uniqueness. additionally, forced "not 180 degree" opposition. x1,y1,x2,y2 :: ℝ x1 | coerce rawX1 == y1 = coerce rawX1 /2 @@ -935,18 +946,18 @@ prop_TriangleNoDivides centerX centerY rawRadians rawDists = findDivisions trian <> show firstSeg <> "\n" <> show firstPoints <> "\n" <> show (insideIsLeft triangle) <> "\n" - <> show (pLineIsLeft pLine (PLine2 pLineToInside, mempty)) <> "\n" + <> show (pLineIsLeft pLine (PLine2 pLineToInside)) <> "\n" maybeInnerPoint = innerContourPoint triangle triangle = randomTriangle centerX centerY rawRadians rawDists firstSeg = firstLineSegOfContour triangle - pLine = eToPL firstSeg + (pLine,_) = eToPL firstSeg firstPoints = firstPointPairOfContour triangle (p1, p2) = firstPointPairOfContour triangle (myMidPoint,_) = interpolate2PP (eToPP p1) (eToPP p2) 0.5 0.5 - pLineToInside = vecOfL $ join2PPoint2 myMidPoint innerPoint - pLineToOutside = vecOfL $ join2PPoint2 innerPoint $ eToPP outsidePoint + pLineToInside = vecOfL $ join2PPoint2 myMidPoint innerPoint + pLineToOutside = vecOfL $ join2PPoint2 innerPoint $ eToPP outsidePoint innerPoint = fromMaybe (dumpError2) maybeInnerPoint - minPoint = fst $ minMaxPoints triangle + (minPoint,_) = minMaxPoints triangle outsidePoint = Point2 (xOf minPoint - 0.00000001 , yOf minPoint - 0.00000001) prop_TriangleHasStraightSkeleton :: ℝ -> ℝ -> ListThree (Radian ℝ) -> ListThree (Positive ℝ) -> Expectation @@ -1329,12 +1340,12 @@ prop_PPointOnPerpWithinErrRange x1 y1 rawX2 rawY2 rawD prop_obtuseBisectorOnBiggerSide_makeENode :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> Positive ℝ -> Radian ℝ -> Bool -> Expectation prop_obtuseBisectorOnBiggerSide_makeENode x y d1 rawR1 d2 rawR2 testFirstLine | testFirstLine = pLineIsLeft bisector pl1 --> Just True - | otherwise = pLineIsLeft (pl2, mempty) bisector --> Just True + | otherwise = pLineIsLeft pl2 bisector --> Just True where - pl1 = eToPL $ getFirstLineSeg eNode + pl1 = fst $ eToPL $ getFirstLineSeg eNode pl2 = flipL $ eToPLine2 $ getLastLineSeg eNode eNode = randomENode x y d1 rawR1 d2 rawR2 - bisector = (flipL $ outOf eNode, errOfOut eNode) + bisector = flipL $ outOf eNode prop_obtuseBisectorOnBiggerSide_makeINode :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> Positive ℝ -> Radian ℝ -> Bool -> Bool -> Expectation prop_obtuseBisectorOnBiggerSide_makeINode x y d1 rawR1 d2 rawR2 flipIn1 flipIn2 = (angleFound >= (1-ulpVal angleErr), angleFound < realToFrac (-1 + (ulpRaw angleErr) :: Rounded 'TowardInf ℝ)) --> (True, False) From 0444b1f86fe19460f41f01297e08496d961a0e62 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sat, 14 Jan 2023 21:16:32 +0000 Subject: [PATCH 201/206] add fuzzinessOfP when determining whether we can sufficiently resolve a line segment or not. --- Graphics/Slicer/Math/Contour.hs | 8 ++++---- Graphics/Slicer/Math/PGA.hs | 8 ++++++-- 2 files changed, 10 insertions(+), 6 deletions(-) diff --git a/Graphics/Slicer/Math/Contour.hs b/Graphics/Slicer/Math/Contour.hs index c2afcb17a..6902d5d02 100644 --- a/Graphics/Slicer/Math/Contour.hs +++ b/Graphics/Slicer/Math/Contour.hs @@ -286,8 +286,8 @@ pointFarOutsideContours contour1 contour2 | not (noIntersection line3 firstLine) && not (noIntersection line3 secondLine) = outsidePoint3 | otherwise = error "cannot get here...?" where - (minPoint1, _)= minMaxPoints contour1 - (minPoint2, _)= minMaxPoints contour2 + (minPoint1,_) = minMaxPoints contour1 + (minPoint2,_) = minMaxPoints contour2 minPoint = Point2 (min (xOf minPoint1) (xOf minPoint2),min (yOf minPoint1) (yOf minPoint2)) (p1, p2) = firstPointPairOfContour contour1 (p3, p4) = firstPointPairOfContour contour2 @@ -300,7 +300,7 @@ pointFarOutsideContours contour1 contour2 outsidePoint2 = Point2 (xOf minPoint - 0.2 , yOf minPoint - 0.1) outsidePoint3 = Point2 (xOf minPoint - 0.1 , yOf minPoint - 0.2) --- | return the contour as a list of points. +-- | Return the contour as a list of points. pointsOfContour :: Contour -> [Point2] pointsOfContour (PointContour _ _ p1 p2 p3 pts@(Slist vals _)) | size pts == Infinity = error "cannot handle infinite contours." @@ -309,7 +309,7 @@ pointsOfContour (LineSegContour _ _ l1 l2 moreLines@(Slist lns _)) | size moreLines == Infinity = error "cannot handle infinite contours." | otherwise = startPoint l1:startPoint l2:(startPoint <$> lns) --- | return the number of points in a contour. +-- | Return the number of points in a contour. numPointsOfContour :: Contour -> Int numPointsOfContour (PointContour _ _ _ _ _ pts) = 3 + len pts numPointsOfContour (LineSegContour _ _ l1 l2 lns) = case safeLast lns of diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index 87a837d83..d368082e1 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -383,10 +383,10 @@ lineSegIntersectsLineSeg l1 l2 | res == PAntiParallel = Right PAntiParallel | hasIntersection && res == PCollinear = Right PCollinear | hasIntersection && res == PAntiCollinear = Right PAntiCollinear - | hasIntersection && distance (startPoint l1) (endPoint l1) < ulpVal (start1FudgeFactor <> end1FudgeFactor <> tFuzz1) = error $ "cannot resolve endpoints of segment: " <> show l1 <> ".\n" <> dumpMiss + | hasIntersection && distance (startPoint l1) (endPoint l1) < lineSegError1 = error $ "cannot resolve endpoints of segment: " <> show l1 <> ".\n" <> dumpMiss | hasIntersection && start1Distance <= ulpStart1Sum = Left $ HitStartPoint l1 | hasIntersection && end1Distance <= ulpEnd1Sum = Left $ HitEndPoint l1 - | hasIntersection && distance (startPoint l2) (endPoint l2) < ulpVal (start2FudgeFactor <> end2FudgeFactor <> tFuzz2) = error $ "cannot resolve endpoints of segment: " <> show l2 <> ".\n" <> dumpMiss + | hasIntersection && distance (startPoint l2) (endPoint l2) < lineSegError2 = error $ "cannot resolve endpoints of segment: " <> show l2 <> ".\n" <> dumpMiss | hasIntersection && start2Distance <= ulpStart2Sum = Left $ HitStartPoint l2 | hasIntersection && end2Distance <= ulpEnd2Sum = Left $ HitEndPoint l2 | hasIntersection = Right $ IntersectsIn rawIntersection (pl1Err, pl2Err, rawIntersectionErr) @@ -394,6 +394,9 @@ lineSegIntersectsLineSeg l1 l2 | otherwise = Left $ NoIntersection ((\(PPoint2 v) -> CPPoint2 v) rawIntersect) (pl1Err, pl2Err, rawIntersectErr) where res = plinesIntersectIn (pl1, pl1Err) (pl2, pl2Err) + -- The value below which it is impossible to tell whether we have hit the beginning, middle, or end of a line segment. + lineSegError1 = ulpVal $ start1FudgeFactor <> tFuzz1 <> end1FudgeFactor <> pFuzz + lineSegError2 = ulpVal $ start2FudgeFactor <> tFuzz2 <> end2FudgeFactor <> pFuzz start1FudgeFactor = start1DistanceErr <> pLineErrAtPPoint (pl1,pl1Err) start1 end1FudgeFactor = end1DistanceErr <> pLineErrAtPPoint (pl1,pl1Err) end1 start2FudgeFactor = start2DistanceErr <> pLineErrAtPPoint (pl2,pl2Err) start2 @@ -408,6 +411,7 @@ lineSegIntersectsLineSeg l1 l2 (end2Distance, (_,_, end2DistanceErr)) = distance2PP (rawIntersection, rawIntersectionErr) (end2, mempty) tFuzz1 = fuzzinessOfL (pl1, pl1Err) tFuzz2 = fuzzinessOfL (pl2, pl2Err) + pFuzz = fuzzinessOfP (rawIntersection, rawIntersectionErr) hasIntersection = hasRawIntersection && hitSegment hitSegment = onSegment l1 (rawIntersection, rawIntersectionErr) && onSegment l2 (rawIntersection, rawIntersectionErr) hasRawIntersection = isJust foundVal From a10795ca7f3e96be82e2bc35e934f8462f93a9ba Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 15 Jan 2023 14:57:19 +0000 Subject: [PATCH 202/206] move pointsOfContour into Definitions.hs, so that Ganja.hs can be used more liberally. --- Graphics/Slicer/Machine/GCode.hs | 4 ++-- Graphics/Slicer/Math/Contour.hs | 23 +++++--------------- Graphics/Slicer/Math/Definitions.hs | 14 ++++++++++-- Graphics/Slicer/Math/Ganja.hs | 4 +--- Graphics/Slicer/Math/Skeleton/Motorcycles.hs | 4 +--- tests/Math/PGA.hs | 6 ++--- 6 files changed, 25 insertions(+), 30 deletions(-) diff --git a/Graphics/Slicer/Machine/GCode.hs b/Graphics/Slicer/Machine/GCode.hs index b60650b6c..8ce7397ef 100644 --- a/Graphics/Slicer/Machine/GCode.hs +++ b/Graphics/Slicer/Machine/GCode.hs @@ -50,9 +50,9 @@ import Control.DeepSeq (NFData) import Graphics.Slicer.Definitions(ℝ, ℝ2, ℝ3, ℕ, Fastℕ, fromFastℕ) -import Graphics.Slicer.Math.Contour (pointsOfContour, lastPointOfContour) +import Graphics.Slicer.Math.Contour (lastPointOfContour) -import Graphics.Slicer.Math.Definitions (Point3(Point3), Point2(Point2), Contour, LineSeg(LineSeg), distance, endPoint, roundToFifth) +import Graphics.Slicer.Math.Definitions (Point3(Point3), Point2(Point2), Contour, LineSeg(LineSeg), distance, endPoint, pointsOfContour, roundToFifth) import Graphics.Slicer.Math.Slicer (accumulateValues) diff --git a/Graphics/Slicer/Math/Contour.hs b/Graphics/Slicer/Math/Contour.hs index 6902d5d02..d81edc04c 100644 --- a/Graphics/Slicer/Math/Contour.hs +++ b/Graphics/Slicer/Math/Contour.hs @@ -22,7 +22,7 @@ {-# OPTIONS_GHC -Wno-partial-type-signatures #-} -- | functions for handling contours. -module Graphics.Slicer.Math.Contour (followingLineSeg, getContours, makeContourTreeSet, ContourTree(ContourTree), ContourTreeSet(ContourTreeSet), contourContainsContour, numPointsOfContour, pointsOfContour, firstLineSegOfContour, firstPointOfContour, justOneContourFrom, lastPointOfContour, makePointContour, firstContourOfContourTreeSet, lineSegsOfContour, makeLineSegContour, maybeFlipContour, firstPointPairOfContour, insideIsLeft, innerContourPoint, pointFarOutsideContour) where +module Graphics.Slicer.Math.Contour (followingLineSeg, getContours, makeContourTreeSet, ContourTree(ContourTree), ContourTreeSet(ContourTreeSet), contourContainsContour, numPointsOfContour, firstLineSegOfContour, firstPointOfContour, justOneContourFrom, lastPointOfContour, makePointContour, firstContourOfContourTreeSet, lineSegsOfContour, makeLineSegContour, maybeFlipContour, firstPointPairOfContour, insideIsLeft, innerContourPoint, pointFarOutsideContour) where import Prelude ((==), (&&), (*), (>), Int, (+), otherwise, (.), null, (<$>), ($), Show, filter, (/=), odd, snd, error, (<>), show, fst, Bool(True,False), Eq, compare, maximum, minimum, min, (-), not) @@ -34,27 +34,25 @@ import Data.List.Extra (unsnoc) import Data.Maybe (Maybe(Just,Nothing), catMaybes, fromJust, fromMaybe, isJust, mapMaybe) -import Slist (len, size, slist, safeLast, safeLast, safeHead) +import Slist (len, slist, safeLast, safeLast, safeHead) import Slist as SL (last) import Slist.Type (Slist(Slist)) -import Slist.Size (Size(Infinity)) - import Graphics.Implicit.Definitions (ℝ) import Graphics.Slicer.Math.ContourIntersections (contourIntersectionCount) -import Graphics.Slicer.Math.Definitions (Contour(PointContour, LineSegContour), LineSeg(endPoint, startPoint), Point2(Point2), fudgeFactor, lineSegsOfContour, makeLineSeg, minMaxPoints, xOf, yOf) +import Graphics.Slicer.Math.Definitions (Contour(PointContour, LineSegContour), LineSeg(endPoint, startPoint), Point2(Point2), fudgeFactor, lineSegsOfContour, makeLineSeg, minMaxPoints, pointsOfContour, xOf, yOf) import Graphics.Slicer.Math.GeometricAlgebra (ulpVal) import Graphics.Slicer.Math.Intersections (noIntersection) -import Graphics.Slicer.Math.Lossy (pPointBetweenPPoints, pToEPoint2) +import Graphics.Slicer.Math.Lossy (join2PPoint2, pPointBetweenPPoints, pToEPoint2) -import Graphics.Slicer.Math.PGA (PPoint2, eToPP, join2EP, join2PP, pLineIsLeft, pPointOnPerpWithErr) +import Graphics.Slicer.Math.PGA (PPoint2, eToPP, join2EP, pLineIsLeft, pPointOnPerpWithErr) -- Unapologetically ripped from ImplicitCAD. -- Added the ability to look at line segments backwards. @@ -230,7 +228,7 @@ insideIsLeft contour | isJust (innerContourPoint contour) = Just $ line1 `pLineIsLeft` lineToInside == Just True | otherwise = Nothing where - (lineToInside, (_,_, lineToInsideErr)) = join2PP midPoint innerPoint + lineToInside = join2PPoint2 midPoint innerPoint midPoint = pPointBetweenPPoints (eToPP p1) (eToPP p2) 0.5 0.5 (line1,_) = join2EP p1 p2 innerPoint = fromJust $ innerContourPoint contour @@ -300,15 +298,6 @@ pointFarOutsideContours contour1 contour2 outsidePoint2 = Point2 (xOf minPoint - 0.2 , yOf minPoint - 0.1) outsidePoint3 = Point2 (xOf minPoint - 0.1 , yOf minPoint - 0.2) --- | Return the contour as a list of points. -pointsOfContour :: Contour -> [Point2] -pointsOfContour (PointContour _ _ p1 p2 p3 pts@(Slist vals _)) - | size pts == Infinity = error "cannot handle infinite contours." - | otherwise = p1:p2:p3:vals -pointsOfContour (LineSegContour _ _ l1 l2 moreLines@(Slist lns _)) - | size moreLines == Infinity = error "cannot handle infinite contours." - | otherwise = startPoint l1:startPoint l2:(startPoint <$> lns) - -- | Return the number of points in a contour. numPointsOfContour :: Contour -> Int numPointsOfContour (PointContour _ _ _ _ _ pts) = 3 + len pts diff --git a/Graphics/Slicer/Math/Definitions.hs b/Graphics/Slicer/Math/Definitions.hs index 4a8da52e5..1e8725449 100644 --- a/Graphics/Slicer/Math/Definitions.hs +++ b/Graphics/Slicer/Math/Definitions.hs @@ -41,6 +41,7 @@ module Graphics.Slicer.Math.Definitions( minMaxPoints, negatePoint, pointBetweenPoints, + pointsOfContour, roundPoint2, roundToFifth, scalePoint, @@ -50,7 +51,7 @@ module Graphics.Slicer.Math.Definitions( zOf ) where -import Prelude (Eq, Show, (==), (*), sqrt, (+), ($), Bool, fromIntegral, round, (/), Ord(compare), otherwise, zipWith3, (<>), error, show, (<), (&&), negate) +import Prelude (Eq, Show, (==), (*), (<$>), sqrt, (+), ($), Bool, fromIntegral, round, (/), Ord(compare), otherwise, zipWith3, (<>), error, show, (<), (&&), negate) import Prelude as PL (zipWith) @@ -244,7 +245,16 @@ makeLineSeg p1 p2 | p1 == p2 = error "tried to make a zero length line segment." | otherwise = LineSeg p1 p2 --- | return the contour as a list of LineSegs. +-- | Return the contour as a list of points. +pointsOfContour :: Contour -> [Point2] +pointsOfContour (PointContour _ _ p1 p2 p3 pts@(Slist vals _)) + | size pts == Infinity = error "cannot handle infinite contours." + | otherwise = p1:p2:p3:vals +pointsOfContour (LineSegContour _ _ l1 l2 moreLines@(Slist lns _)) + | size moreLines == Infinity = error "cannot handle infinite contours." + | otherwise = startPoint l1:startPoint l2:(startPoint <$> lns) + +-- | Return the contour as a list of LineSegs. lineSegsOfContour :: Contour -> [LineSeg] lineSegsOfContour (PointContour _ _ p1 p2 p3 pts) = [makeLineSeg p1 p2, makeLineSeg p2 p3] <> consSegsWithPoints p3 pts p1 diff --git a/Graphics/Slicer/Math/Ganja.hs b/Graphics/Slicer/Math/Ganja.hs index 34f7da4bb..fd6873079 100644 --- a/Graphics/Slicer/Math/Ganja.hs +++ b/Graphics/Slicer/Math/Ganja.hs @@ -96,9 +96,7 @@ import Slist.Type (Slist(Slist)) import Slist (last, len) -import Graphics.Slicer.Math.Contour (pointsOfContour) - -import Graphics.Slicer.Math.Definitions (Contour, Point2(Point2), LineSeg, endPoint, mapWithFollower, startPoint) +import Graphics.Slicer.Math.Definitions (Contour, Point2(Point2), LineSeg, endPoint, mapWithFollower, pointsOfContour, startPoint) import Graphics.Slicer.Math.GeometricAlgebra (GNum(GEPlus, GEZero), GVec(GVec), getVal, valOf) diff --git a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs index 9aad4cabf..264c5f3f6 100644 --- a/Graphics/Slicer/Math/Skeleton/Motorcycles.hs +++ b/Graphics/Slicer/Math/Skeleton/Motorcycles.hs @@ -44,11 +44,9 @@ import Graphics.Slicer.Definitions (ℝ) import Graphics.Slicer.Math.Arcs (getInsideArc) -import Graphics.Slicer.Math.Contour (pointsOfContour) - import Graphics.Slicer.Math.ContourIntersections (getMotorcycleContourIntersections, getMotorcycleSegSetIntersections) -import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, mapWithNeighbors, startPoint, endPoint, makeLineSeg) +import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, mapWithNeighbors, startPoint, endPoint, makeLineSeg, pointsOfContour) import Graphics.Slicer.Math.Intersections (intersectionOf, isAntiCollinear, noIntersection, outputIntersectsLineSeg, outputIntersectsPLineAt) diff --git a/tests/Math/PGA.hs b/tests/Math/PGA.hs index 0139fdb6f..49086e085 100644 --- a/tests/Math/PGA.hs +++ b/tests/Math/PGA.hs @@ -57,7 +57,7 @@ import Slist (slist, len) import Graphics.Slicer (ℝ) -- A euclidian point. -import Graphics.Slicer.Math.Definitions(Point2(Point2), Contour(LineSegContour), LineSeg(LineSeg), roundPoint2, startPoint, distance, xOf, yOf, minMaxPoints, makeLineSeg, endPoint) +import Graphics.Slicer.Math.Definitions(Point2(Point2), Contour(LineSegContour), LineSeg(LineSeg), roundPoint2, startPoint, distance, xOf, yOf, minMaxPoints, makeLineSeg, endPoint, pointsOfContour) -- Our Geometric Algebra library. import Graphics.Slicer.Math.GeometricAlgebra (ErrVal(ErrVal), GNum(GEZero, GEPlus, G0), GVal(GVal), GVec(GVec), UlpSum(UlpSum), addValPairWithErr, subValPairWithErr, addValWithErr, ulpRaw, ulpVal, subVal, addVecPair, subVecPair, mulScalarVecWithErr, divVecScalarWithErr, scalarPart, vectorPart, (•), (∧), (⋅), (⎣), (⎤)) @@ -67,14 +67,14 @@ import Graphics.Slicer.Math.Intersections (outputIntersectsLineSeg) import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, distancePPointToPLine, eToPLine2, getFirstArc, join2PPoint2, pPointOnPerp) -- Our 2D Projective Geometric Algebra library. -import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PLine2Err(PLine2Err), ProjectiveLine2, canonicalizeP, distance2PP, distancePPToPL, eToPL, eToPP, eToPP, interpolate2PP, intersect2PL, translateL, translateRotatePPoint2WithErr, angleBetween2PL, flipL, join2PP, makeCPPoint2, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), cPPointAndErrOf, distance2PL, intersectsWithErr, errOfOut, pPointOnPerpWithErr, outOf, vecOfL) +import Graphics.Slicer.Math.PGA (CPPoint2(CPPoint2), NPLine2(NPLine2), PPoint2(PPoint2), PLine2(PLine2), PLine2Err(PLine2Err), ProjectiveLine2, canonicalizeP, distance2PP, distancePPToPL, eToPL, eToPP, eToPP, interpolate2PP, intersect2PL, translateL, translateRotatePPoint2WithErr, angleBetween2PL, flipL, join2PP, makeCPPoint2, normalizeL, pLineIsLeft, pPointsOnSameSideOfPLine, Intersection(HitStartPoint, HitEndPoint, NoIntersection), PIntersection(PCollinear, PAntiCollinear, PParallel, PAntiParallel, IntersectsIn), cPPointAndErrOf, distance2PL, intersectsWithErr, pPointOnPerpWithErr, outOf, vecOfL) -- The primitives of our PGA only library, and error estimation code. import Graphics.Slicer.Math.PGAPrimitives (pLineErrAtPPoint, xIntercept, yIntercept) -- Our Contour library. -import Graphics.Slicer.Math.Contour (contourContainsContour, getContours, pointsOfContour, numPointsOfContour, justOneContourFrom, lineSegsOfContour, makeLineSegContour, makePointContour, insideIsLeft, innerContourPoint, firstPointPairOfContour, firstLineSegOfContour) +import Graphics.Slicer.Math.Contour (contourContainsContour, getContours, numPointsOfContour, justOneContourFrom, lineSegsOfContour, makeLineSegContour, makePointContour, insideIsLeft, innerContourPoint, firstPointPairOfContour, firstLineSegOfContour) -- Our imprecise Contour library. import Graphics.Slicer.Machine.Contour (shrinkContour, expandContour) From d99e33b7763e22988f6c50d8448b05d35375a225 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 15 Jan 2023 15:14:33 +0000 Subject: [PATCH 203/206] change module definition format. --- Graphics/Slicer/Math/Contour.hs | 23 ++++++++++++++++++++++- 1 file changed, 22 insertions(+), 1 deletion(-) diff --git a/Graphics/Slicer/Math/Contour.hs b/Graphics/Slicer/Math/Contour.hs index d81edc04c..a0f03cb30 100644 --- a/Graphics/Slicer/Math/Contour.hs +++ b/Graphics/Slicer/Math/Contour.hs @@ -22,7 +22,28 @@ {-# OPTIONS_GHC -Wno-partial-type-signatures #-} -- | functions for handling contours. -module Graphics.Slicer.Math.Contour (followingLineSeg, getContours, makeContourTreeSet, ContourTree(ContourTree), ContourTreeSet(ContourTreeSet), contourContainsContour, numPointsOfContour, firstLineSegOfContour, firstPointOfContour, justOneContourFrom, lastPointOfContour, makePointContour, firstContourOfContourTreeSet, lineSegsOfContour, makeLineSegContour, maybeFlipContour, firstPointPairOfContour, insideIsLeft, innerContourPoint, pointFarOutsideContour) where +module Graphics.Slicer.Math.Contour ( + ContourTree(ContourTree), + ContourTreeSet(ContourTreeSet), + contourContainsContour, + firstContourOfContourTreeSet, + firstLineSegOfContour, + firstPointOfContour, + firstPointPairOfContour, + followingLineSeg, + getContours, + innerContourPoint, + insideIsLeft, + justOneContourFrom, + lastPointOfContour, + lineSegsOfContour, + makeContourTreeSet, + makeLineSegContour, + makePointContour, + maybeFlipContour, + numPointsOfContour, + pointFarOutsideContour + ) where import Prelude ((==), (&&), (*), (>), Int, (+), otherwise, (.), null, (<$>), ($), Show, filter, (/=), odd, snd, error, (<>), show, fst, Bool(True,False), Eq, compare, maximum, minimum, min, (-), not) From 10450b8541e886ffd802b9739d7d60fe12884339 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 15 Jan 2023 23:39:18 +0000 Subject: [PATCH 204/206] move function order. --- Graphics/Slicer/Math/Definitions.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/Graphics/Slicer/Math/Definitions.hs b/Graphics/Slicer/Math/Definitions.hs index 1e8725449..cdc7e7c92 100644 --- a/Graphics/Slicer/Math/Definitions.hs +++ b/Graphics/Slicer/Math/Definitions.hs @@ -245,15 +245,6 @@ makeLineSeg p1 p2 | p1 == p2 = error "tried to make a zero length line segment." | otherwise = LineSeg p1 p2 --- | Return the contour as a list of points. -pointsOfContour :: Contour -> [Point2] -pointsOfContour (PointContour _ _ p1 p2 p3 pts@(Slist vals _)) - | size pts == Infinity = error "cannot handle infinite contours." - | otherwise = p1:p2:p3:vals -pointsOfContour (LineSegContour _ _ l1 l2 moreLines@(Slist lns _)) - | size moreLines == Infinity = error "cannot handle infinite contours." - | otherwise = startPoint l1:startPoint l2:(startPoint <$> lns) - -- | Return the contour as a list of LineSegs. lineSegsOfContour :: Contour -> [LineSeg] lineSegsOfContour (PointContour _ _ p1 p2 p3 pts) = [makeLineSeg p1 p2, @@ -272,3 +263,12 @@ lineSegsOfContour (LineSegContour _ _ l1 l2 moreLines@(Slist lns _)) | size moreLines == Infinity = error "cannot handle infinite contours." | otherwise = l1:l2:lns +-- | Return the contour as a list of points. +pointsOfContour :: Contour -> [Point2] +pointsOfContour (PointContour _ _ p1 p2 p3 pts@(Slist vals _)) + | size pts == Infinity = error "cannot handle infinite contours." + | otherwise = p1:p2:p3:vals +pointsOfContour (LineSegContour _ _ l1 l2 moreLines@(Slist lns _)) + | size moreLines == Infinity = error "cannot handle infinite contours." + | otherwise = startPoint l1:startPoint l2:(startPoint <$> lns) + From 4c89d20fd0b5229c1b2c8e2ae2c254dfc36cf9ba Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 15 Jan 2023 23:39:52 +0000 Subject: [PATCH 205/206] export angleCosBetween2PL. --- Graphics/Slicer/Math/PGA.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs index d368082e1..c431f8f6c 100644 --- a/Graphics/Slicer/Math/PGA.hs +++ b/Graphics/Slicer/Math/PGA.hs @@ -53,6 +53,7 @@ module Graphics.Slicer.Math.PGA( vecOfP ), angleBetween2PL, + angleCosBetween2PL, canonicalizedIntersectionOf2PL, combineConsecutiveLineSegs, cPPointAndErrOf, From e6c8961f526b0d99adf534e74a986c49d4ce1fcb Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Sun, 15 Jan 2023 23:56:43 +0000 Subject: [PATCH 206/206] use an outside point and a lineseg as close to perpendicular as possible, when determining what direction to wind a contour. --- Graphics/Slicer/Math/Contour.hs | 115 ++++++++++++++----------- Graphics/Slicer/Math/RandomGeometry.hs | 9 +- 2 files changed, 71 insertions(+), 53 deletions(-) diff --git a/Graphics/Slicer/Math/Contour.hs b/Graphics/Slicer/Math/Contour.hs index a0f03cb30..cabb40615 100644 --- a/Graphics/Slicer/Math/Contour.hs +++ b/Graphics/Slicer/Math/Contour.hs @@ -41,13 +41,13 @@ module Graphics.Slicer.Math.Contour ( makeLineSegContour, makePointContour, maybeFlipContour, - numPointsOfContour, - pointFarOutsideContour + mostPerpPointAndLineSeg, + numPointsOfContour ) where -import Prelude ((==), (&&), (*), (>), Int, (+), otherwise, (.), null, (<$>), ($), Show, filter, (/=), odd, snd, error, (<>), show, fst, Bool(True,False), Eq, compare, maximum, minimum, min, (-), not) +import Prelude ((==), (&&), (*), (>), Int, (+), abs, head, otherwise, (.), null, (<$>), ($), Show, filter, (/=), odd, snd, error, (<>), show, fst, Bool(True,False), Eq, compare, maximum, minimum, min, (-), not) -import Data.List (partition, reverse, sortBy) +import Data.List (partition, reverse, sortBy, zip) import Data.List as DL (uncons) @@ -65,15 +65,15 @@ import Graphics.Implicit.Definitions (ℝ) import Graphics.Slicer.Math.ContourIntersections (contourIntersectionCount) -import Graphics.Slicer.Math.Definitions (Contour(PointContour, LineSegContour), LineSeg(endPoint, startPoint), Point2(Point2), fudgeFactor, lineSegsOfContour, makeLineSeg, minMaxPoints, pointsOfContour, xOf, yOf) +import Graphics.Slicer.Math.Definitions (Contour(PointContour, LineSegContour), LineSeg(endPoint, startPoint), Point2(Point2), fudgeFactor, lineSegsOfContour, makeLineSeg, minMaxPoints, pointBetweenPoints, pointsOfContour, xOf, yOf) import Graphics.Slicer.Math.GeometricAlgebra (ulpVal) -import Graphics.Slicer.Math.Intersections (noIntersection) +import Graphics.Slicer.Math.Intersections (intersectionOf, noIntersection) -import Graphics.Slicer.Math.Lossy (join2PPoint2, pPointBetweenPPoints, pToEPoint2) +import Graphics.Slicer.Math.Lossy (eToPLine2, join2PPoint2, pPointBetweenPPoints, pToEPoint2) -import Graphics.Slicer.Math.PGA (PPoint2, eToPP, join2EP, pLineIsLeft, pPointOnPerpWithErr) +import Graphics.Slicer.Math.PGA (ProjectiveLine2, PPoint2, angleCosBetween2PL, eToPL, eToPP, fuzzinessOfL, fuzzinessOfP, join2EP, pLineErrAtPPoint, pLineIsLeft, pPointOnPerpWithErr) -- Unapologetically ripped from ImplicitCAD. -- Added the ability to look at line segments backwards. @@ -266,36 +266,55 @@ innerContourPoint contour where numIntersections = contourIntersectionCount contour (pToEPoint2 perpPoint, outsidePoint) otherIntersections = contourIntersectionCount contour (pToEPoint2 otherPoint, outsidePoint) - (perpPoint, (_,_,_, perpErr)) = pPointOnPerpWithErr source midPoint minDistanceFromSeg - (otherPoint, (_,_,_, otherErr)) = pPointOnPerpWithErr source midPoint (-minDistanceFromSeg) - midPoint = pPointBetweenPPoints (eToPP p1) (eToPP p2) 0.5 0.5 - -- FIXME: Error loss. - (source, _) = join2EP p1 p2 - outsidePoint = pointFarOutsideContour contour - (p1, p2) = firstPointPairOfContour contour + (perpPoint, (_,_,_, perpErr)) = pPointOnPerpWithErr pLine midPoint minDistanceFromSeg + (otherPoint, (_,_,_, otherErr)) = pPointOnPerpWithErr pLine midPoint (-minDistanceFromSeg) + midPoint = eToPP $ pointBetweenPoints (startPoint lineSeg) (endPoint lineSeg) + pLine = eToPLine2 lineSeg -- | the minimum measurable distance of a point from a line segment - -- FIXME: make this smaller, make more errors. - -- FIXME: magic number - minDistanceFromSeg :: ℝ - minDistanceFromSeg = fudgeFactor*10000000 + minDistanceFromSeg = minDistanceFromSegMidPoint outsidePoint lineSeg + (outsidePoint, lineSeg) = mostPerpPointAndLineSeg contour --- | Find a point that is guaranteed to be outside of the given contour, and is not on the same line as the first line segment of the contour. -pointFarOutsideContour :: Contour -> Point2 -pointFarOutsideContour contour - | not (noIntersection line1 firstLine) = outsidePoint1 - | not (noIntersection line2 firstLine) = outsidePoint2 - | not (noIntersection line3 firstLine) = outsidePoint3 - | otherwise = error "cannot get here." +-- | The minimum measurable distance of a point from the midpoint of a line segment +minDistanceFromSegMidPoint :: Point2 -> LineSeg -> ℝ +minDistanceFromSegMidPoint outsidePoint lineSeg = midPointFuzz + lineFuzz + where + -- The minimum distance you have to get away from this line segment not to have intersection functions think you contact it. + -- FIXME: two magic numbers. the bigger these values are, the more likely we are to have a perpendicular segment that hits another line segment of the contour. + lineFuzz = case ulpVal (fuzzinessOfL pLine <> pLineErrAtPPoint pLine (eToPP midPoint)) of + -- things very close to 0 have no error to multiply. we have to have some value, so use this. + 0 -> 10000 * fudgeFactor + -- for points further away. + v -> 10000 * v + -- The amount of error introduced by intersecting from the outsidePoint to the given line segment. + midPointFuzz = ulpVal $ fuzzinessOfP $ intersectionOf pLine outsideLine + outsideLine = join2EP midPoint outsidePoint + midPoint = pointBetweenPoints (startPoint lineSeg) (endPoint lineSeg) + pLine = eToPL lineSeg + +-- | Find a point that is guaranteed to be outside of the contour, along with the line segment of the contour that is most perpendicular to it. +mostPerpPointAndLineSeg :: Contour -> (Point2, LineSeg) +mostPerpPointAndLineSeg contour = res where - (minPoint, _) = minMaxPoints contour - (p1, p2) = firstPointPairOfContour contour - firstLine = join2EP p1 p2 - line1 = join2EP p1 outsidePoint1 - line2 = join2EP p1 outsidePoint2 - line3 = join2EP p1 outsidePoint3 - outsidePoint1 = Point2 (xOf minPoint - 0.1 , yOf minPoint - 0.1) - outsidePoint2 = Point2 (xOf minPoint - 0.2 , yOf minPoint - 0.1) - outsidePoint3 = Point2 (xOf minPoint - 0.1 , yOf minPoint - 0.2) + res = if posAngle > negAngle + then if posAngle > midAngle + then (outsidePosPoint, posLineSeg) + else (outsideMidPoint, midLineSeg) + else if midAngle > negAngle + then (outsideMidPoint, midLineSeg) + else (outsideNegPoint, negLineSeg) + outsideMidPoint = pointBetweenPoints outsidePosPoint outsideNegPoint + outsidePosPoint = Point2 (xOf minPoint - 0.1 , yOf maxPoint + 0.1) + outsideNegPoint = Point2 (xOf minPoint - 0.1 , yOf minPoint - 0.1) + (minPoint, maxPoint) = minMaxPoints contour + (posLineSeg, posAngle) = mostPerp contour (eToPLine2 $ makeLineSeg (Point2 (0,0)) (Point2 (-1, 1))) + (midLineSeg, midAngle) = mostPerp contour (eToPLine2 $ makeLineSeg (Point2 (0,0)) (Point2 (-1, 0))) + (negLineSeg, negAngle) = mostPerp contour (eToPLine2 $ makeLineSeg (Point2 (0,0)) (Point2 (-1,-1))) + -- | Find the most perpendicular line segment of a contour, when compared to the given projective line. + mostPerp :: (ProjectiveLine2 a) => Contour -> a -> (LineSeg, ℝ) + mostPerp myContour line = (\(a, (b, _)) -> (a, abs b)) $ head $ sortBy (\(_, d) (_, f) -> compare (abs $ fst d) (abs $ fst f)) $ zip lineSegs $ angleCosBetween2PL line <$> lineSegsAsPLines + where + lineSegsAsPLines = fst . eToPL <$> lineSegs + lineSegs = lineSegsOfContour myContour -- | Find a point that is guaranteed to be outside of the given contour, and is not on the same line as the first line segment of the contour. pointFarOutsideContours :: Contour -> Contour -> Point2 @@ -305,19 +324,19 @@ pointFarOutsideContours contour1 contour2 | not (noIntersection line3 firstLine) && not (noIntersection line3 secondLine) = outsidePoint3 | otherwise = error "cannot get here...?" where - (minPoint1,_) = minMaxPoints contour1 - (minPoint2,_) = minMaxPoints contour2 - minPoint = Point2 (min (xOf minPoint1) (xOf minPoint2),min (yOf minPoint1) (yOf minPoint2)) - (p1, p2) = firstPointPairOfContour contour1 - (p3, p4) = firstPointPairOfContour contour2 - firstLine = join2EP p1 p2 - secondLine = join2EP p3 p4 - line1 = join2EP p1 outsidePoint1 - line2 = join2EP p1 outsidePoint2 - line3 = join2EP p1 outsidePoint3 - outsidePoint1 = Point2 (xOf minPoint - 0.1 , yOf minPoint - 0.1) - outsidePoint2 = Point2 (xOf minPoint - 0.2 , yOf minPoint - 0.1) - outsidePoint3 = Point2 (xOf minPoint - 0.1 , yOf minPoint - 0.2) + (minPoint1, _) = minMaxPoints contour1 + (minPoint2, _) = minMaxPoints contour2 + minPoint = Point2 (min (xOf minPoint1) (xOf minPoint2),min (yOf minPoint1) (yOf minPoint2)) + (p1, p2) = firstPointPairOfContour contour1 + (p3, p4) = firstPointPairOfContour contour2 + firstLine = join2EP p1 p2 + secondLine = join2EP p3 p4 + line1 = join2EP p1 outsidePoint1 + line2 = join2EP p1 outsidePoint2 + line3 = join2EP p1 outsidePoint3 + outsidePoint1 = Point2 (xOf minPoint - 0.1 , yOf minPoint - 0.1) + outsidePoint2 = Point2 (xOf minPoint - 0.2 , yOf minPoint - 0.1) + outsidePoint3 = Point2 (xOf minPoint - 0.1 , yOf minPoint - 0.2) -- | Return the number of points in a contour. numPointsOfContour :: Contour -> Int diff --git a/Graphics/Slicer/Math/RandomGeometry.hs b/Graphics/Slicer/Math/RandomGeometry.hs index 4b14070f9..67488e7b4 100644 --- a/Graphics/Slicer/Math/RandomGeometry.hs +++ b/Graphics/Slicer/Math/RandomGeometry.hs @@ -83,9 +83,9 @@ import Graphics.Slicer (ℝ) import Graphics.Slicer.Math.Arcs (getOutsideArc) -import Graphics.Slicer.Math.Contour (makePointContour, maybeFlipContour, firstPointPairOfContour, pointFarOutsideContour) +import Graphics.Slicer.Math.Contour (makePointContour, maybeFlipContour, mostPerpPointAndLineSeg) -import Graphics.Slicer.Math.Definitions (Contour, Point2(Point2), LineSeg, makeLineSeg, pointBetweenPoints) +import Graphics.Slicer.Math.Definitions (Contour, Point2(Point2), LineSeg(startPoint, endPoint), makeLineSeg, pointBetweenPoints) import Graphics.Slicer.Math.Ganja (dumpGanjas, toGanja) @@ -379,9 +379,8 @@ randomStarPoly centerX centerY radianDistPairs = fromMaybe dumpError $ maybeFlip dumpError = error $ "failed to flip a contour:" <> dumpGanjas [toGanja contour, toGanja (Point2 (centerX, centerY)), toGanja outsidePLine] <> "\n" where outsidePLine = fst $ join2EP myMidPoint outsidePoint - outsidePoint = pointFarOutsideContour contour - myMidPoint = pointBetweenPoints p1 p2 - (p1, p2) = firstPointPairOfContour contour + myMidPoint = pointBetweenPoints (startPoint lineSeg) (endPoint lineSeg) + (outsidePoint, lineSeg) = mostPerpPointAndLineSeg contour randomENode :: ℝ -> ℝ -> Positive ℝ -> Radian ℝ -> Positive ℝ -> Radian ℝ -> ENode randomENode x y d1 rawR1 d2 rawR2 = makeENode p1 intersectionPoint p2