diff --git a/Graphics/Slicer/Machine/Contour.hs b/Graphics/Slicer/Machine/Contour.hs
index e9cdd8ec1..f50a628f2 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,15 +31,15 @@ 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, translatePLine2)
+import Graphics.Slicer.Math.Lossy (eToPLine2, pToEPoint2)
-import Graphics.Slicer.Math.PGA (combineConsecutiveLineSegs, PIntersection(IntersectsIn), plinesIntersectIn, cPToEPoint2)
+import Graphics.Slicer.Math.PGA (combineConsecutiveLineSegs, eToPL, translateL)
-import Graphics.Slicer.Definitions(ℝ)
+import Graphics.Slicer.Definitions (ℝ)
---------------------------------------------------------------
-------------------- Contour Optimizer ------------------------
@@ -101,29 +101,12 @@ modifyContour pathWidth contour direction
(Just (middleSegs,lastSeg)) -> middleSegs <> if noIntersection (inwardAdjust lastSeg) (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.
| 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 (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 = case plinesIntersectIn (inwardAdjust l1) (inwardAdjust l2) of
- IntersectsIn _ _ -> True
- _other -> False
- intersectionPoint pl1 pl2 = case plinesIntersectIn pl1 pl2 of
- IntersectsIn p2 _ -> cPToEPoint2 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)
diff --git a/Graphics/Slicer/Machine/GCode.hs b/Graphics/Slicer/Machine/GCode.hs
index 56b119c97..8ce7397ef 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)
@@ -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)
@@ -205,11 +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
@@ -220,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
diff --git a/Graphics/Slicer/Machine/Infill.hs b/Graphics/Slicer/Machine/Infill.hs
index b7a764f3c..d7a3c093d 100644
--- a/Graphics/Slicer/Machine/Infill.hs
+++ b/Graphics/Slicer/Machine/Infill.hs
@@ -23,23 +23,23 @@
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)
-import Data.Maybe (Maybe(Just, Nothing), catMaybes)
+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.Intersections (getPLine2Intersections)
+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, ProjectiveLine2, join2EP)
-- | what direction to put down infill lines.
data InfillType = Diag1 | Diag2 | Vert | Horiz
@@ -48,7 +48,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
@@ -56,7 +56,7 @@ makeInfill contour insideContours ls layerType = catMaybes $ infillLineSegInside
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 :: (ProjectiveLine2 a) => Contour -> [Contour] -> (a, PLine2Err) -> Maybe [LineSeg]
infillLineSegInside contour childContours line
| not (null allLines) = Just $ (allLines !!) <$> [0,2..length allLines - 1]
| otherwise = Nothing
@@ -64,17 +64,17 @@ infillLineSegInside contour childContours line
allLines :: [LineSeg]
allLines = makeLineSegs allPoints
where
- allPoints = filterTooShort . sort . concat $ getPLine2Intersections line <$> contour:childContours
+ allPoints = (filterTooShort . sort) $ concatMap (getLineContourIntersections line) (contour:childContours)
filterTooShort :: [Point2] -> [Point2]
filterTooShort [] = []
filterTooShort [a] = [a]
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)
@@ -91,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)
@@ -111,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)
@@ -126,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/Arcs.hs b/Graphics/Slicer/Math/Arcs.hs
new file mode 100644
index 000000000..5ced5d88b
--- /dev/null
+++ b/Graphics/Slicer/Math/Arcs.hs
@@ -0,0 +1,128 @@
+{- 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 (getFirstArc, getInsideArc, getOutsideArc, towardIntersection) where
+
+import Prelude (Bool, ($), (<>), (==), (>), (<=), (&&), (||), error, mempty, otherwise, show)
+
+import Graphics.Slicer.Math.Definitions (Point2, addPoints, distance, makeLineSeg, scalePoint)
+
+import Graphics.Slicer.Math.GeometricAlgebra (addVecPairWithErr, ulpVal)
+
+import Graphics.Slicer.Math.Intersections (intersectionOf, isAntiCollinear, isCollinear, noIntersection)
+
+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)
+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.
+-- Note: we return normalization error, because we construct projective lines here.
+getAcuteArcFromPoints :: Point2 -> Point2 -> Point2 -> (PLine2, (PLine2Err, PLine2Err, PLine2Err))
+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 line1 line2
+ -- FIXME: how do these error quotents effect the resulting line?
+ line1@(_, side1NormErr) = normalizeL side1Raw
+ (side1Raw, side1ConsErr) = eToPL (makeLineSeg p1 p2)
+ 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
+
+-- | 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.
+-- 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!"
+ | 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
+ lv1 = vecOfL $ flipL npline1
+ lv2 = vecOfL npline2
+ (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, 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 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!"
+ | 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 <= 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 <= 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
+ (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
+
+-- | 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 <= 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
+ (d, (_,_, dErr)) = distance2PP point1 point2
+ (newPLine, _) = join2PP pp1 pp2
diff --git a/Graphics/Slicer/Math/Contour.hs b/Graphics/Slicer/Math/Contour.hs
index 3280462ad..cabb40615 100644
--- a/Graphics/Slicer/Math/Contour.hs
+++ b/Graphics/Slicer/Math/Contour.hs
@@ -22,37 +22,58 @@
{-# 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
-
-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)
+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,
+ mostPerpPointAndLineSeg,
+ numPointsOfContour
+ ) where
+
+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, zip)
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)
+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.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), LineSeg(endPoint, startPoint), Point2(Point2), fudgeFactor, lineSegsOfContour, makeLineSeg, minMaxPoints, pointBetweenPoints, pointsOfContour, xOf, yOf)
-import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum))
+import Graphics.Slicer.Math.GeometricAlgebra (ulpVal)
-import Graphics.Slicer.Math.Intersections (contourIntersectionCount, noIntersection)
+import Graphics.Slicer.Math.Intersections (intersectionOf, noIntersection)
-import Graphics.Slicer.Math.Lossy (eToPPoint2, join2PPoint2, pPointBetweenPPoints)
+import Graphics.Slicer.Math.Lossy (eToPLine2, join2PPoint2, pPointBetweenPPoints, pToEPoint2)
-import Graphics.Slicer.Math.PGA (PPoint2, pLineFromEndpointsWithErr, pLineIsLeft, pPointOnPerpWithErr, pToEPoint2)
+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.
@@ -69,7 +90,7 @@ import Graphics.Slicer.Math.PGA (PPoint2, pLineFromEndpointsWithErr, 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
@@ -81,7 +102,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
@@ -155,11 +176,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
@@ -225,88 +246,99 @@ 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 $ line1 `pLineIsLeft` lineToInside == Just True
| otherwise = Nothing
where
- (p1, p2) = firstPointPairOfContour contour
- myMidPoint = pPointBetweenPPoints (eToPPoint2 p1) (eToPPoint2 p2) 0.5 0.5
- pLineToInside = join2PPoint2 myMidPoint innerPoint
- innerPoint = fromJust $ innerContourPoint contour
- (pline1,_) = pLineFromEndpointsWithErr p1 p2
+ lineToInside = join2PPoint2 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 = error "cannot ensure perp point is on right side of contour."
- | odd otherIntersections && otherErr < realToFrac 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
- (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)
numIntersections = contourIntersectionCount contour (pToEPoint2 perpPoint, outsidePoint)
otherIntersections = contourIntersectionCount contour (pToEPoint2 otherPoint, outsidePoint)
- outsidePoint = pointFarOutsideContour 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 pline1 firstPLine) = outsidePoint1
- | not (noIntersection pline2 firstPLine) = outsidePoint2
- | not (noIntersection pline3 firstPLine) = 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 = 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)
- 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
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 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
- minPoint2 = fst $ minMaxPoints 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)
- 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 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.
+ (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
numPointsOfContour (PointContour _ _ _ _ _ pts) = 3 + len pts
numPointsOfContour (LineSegContour _ _ l1 l2 lns) = case safeLast lns of
diff --git a/Graphics/Slicer/Math/ContourIntersections.hs b/Graphics/Slicer/Math/ContourIntersections.hs
new file mode 100644
index 000000000..133b54e2c
--- /dev/null
+++ b/Graphics/Slicer/Math/ContourIntersections.hs
@@ -0,0 +1,186 @@
+{- 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,
+ getLineContourIntersections,
+ 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, Nothing), catMaybes, fromJust, isJust)
+
+import Slist.Type (Slist)
+
+import Slist (len, slist)
+
+import Graphics.Slicer.Definitions (ℝ)
+
+import Graphics.Slicer.Math.Definitions (Contour, LineSeg(endPoint, startPoint), Point2, distance, fudgeFactor, lineSegsOfContour, makeLineSeg, mapWithNeighbors)
+
+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))
+
+-- | 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 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"
+ | 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
+ -- 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
+ 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.
+getMotorcycleContourIntersections :: Motorcycle -> Contour -> [(LineSeg, Either Point2 CPPoint2)]
+getMotorcycleContourIntersections m@(Motorcycle (inSeg, outSeg) _ _) c = stripInSegOutSeg $ catMaybes $ mapWithNeighbors filterIntersections $ openCircuit $ zip contourLines $ outputIntersectsLineSeg m <$> contourLines
+ where
+ 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
+
+-- | 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
+
+-- | 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/Definitions.hs b/Graphics/Slicer/Math/Definitions.hs
index 619e54f38..cdc7e7c92 100644
--- a/Graphics/Slicer/Math/Definitions.hs
+++ b/Graphics/Slicer/Math/Definitions.hs
@@ -20,9 +20,38 @@
{-# 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
-
-import Prelude (Eq, Show, (==), (*), sqrt, (+), ($), Bool, fromIntegral, round, (/), Ord(compare), otherwise, zipWith3, (<>), error, show, (<), (&&), negate)
+module Graphics.Slicer.Math.Definitions(
+ Contour(PointContour, LineSegContour),
+ LineSeg(LineSeg),
+ PlanePoint,
+ Point2(Point2),
+ Point3(Point3),
+ SpacePoint,
+ (~=),
+ addPoints,
+ distance,
+ endPoint,
+ flatten,
+ fudgeFactor,
+ lineSegsOfContour,
+ makeLineSeg,
+ mapWithNeighbors,
+ mapWithFollower,
+ mapWithPredecessor,
+ minMaxPoints,
+ negatePoint,
+ pointBetweenPoints,
+ pointsOfContour,
+ roundPoint2,
+ roundToFifth,
+ scalePoint,
+ startPoint,
+ xOf,
+ yOf,
+ zOf
+ ) where
+
+import Prelude (Eq, Show, (==), (*), (<$>), sqrt, (+), ($), Bool, fromIntegral, round, (/), Ord(compare), otherwise, zipWith3, (<>), error, show, (<), (&&), negate)
import Prelude as PL (zipWith)
@@ -154,6 +183,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
@@ -212,7 +245,7 @@ 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 LineSegs.
lineSegsOfContour :: Contour -> [LineSeg]
lineSegsOfContour (PointContour _ _ p1 p2 p3 pts) = [makeLineSeg p1 p2,
makeLineSeg p2 p3] <> consSegsWithPoints p3 pts p1
@@ -230,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)
+
diff --git a/Graphics/Slicer/Math/Ganja.hs b/Graphics/Slicer/Math/Ganja.hs
index 5e4ac94fe..fd6873079 100644
--- a/Graphics/Slicer/Math/Ganja.hs
+++ b/Graphics/Slicer/Math/Ganja.hs
@@ -74,57 +74,44 @@
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,
+ dumpGanja,
+ dumpGanjas,
+ toGanja
+ ) where
-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
+import Prelude (String, (<>), (<>), (<$>), ($), (>=), (==), (.), (/=), concat, error, fst, otherwise, show, snd, zip)
-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 Data.List (concatMap)
-import Data.Coerce (coerce)
+import Data.Maybe (Maybe(Nothing), catMaybes)
-import Data.List (sort)
-
-import Data.List.Unique (allUnique)
-
-import Data.Maybe (Maybe(Nothing, Just), maybeToList, catMaybes, fromMaybe)
-
-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 (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, pointsOfContour, startPoint)
-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, eToPPoint2, join2PPoint2, normalizePLine2, pPointBetweenPPoints)
+import Graphics.Slicer.Math.PGA (PLine2, PPoint2, PPoint2Err, hasArc, outAndErrOf, outOf, vecOfL, vecOfP)
-import Graphics.Slicer.Math.PGA (PPoint2(PPoint2), PLine2(PLine2), flipPLine2, pToEPoint2, translateRotatePPoint2, pLineFromEndpointsWithErr, ulpOfLineSeg, outOf, pPointOf, NPLine2(NPLine2))
-
-import Graphics.Slicer.Math.Skeleton.Concave (makeENode, getOutsideArc)
-
-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))
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",
@@ -134,7 +121,7 @@ instance GanjaAble Point2 where
showFullPrecision v = showFFloat Nothing v ""
instance GanjaAble LineSeg where
- toGanja l1 varname = (
+ toGanja lineSeg varname = (
p1var
<> p2var,
" 0x882288,\n"
@@ -143,17 +130,35 @@ 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 (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)
+ <> "e02"
+ <> (if e01 >= 0 then "+" <> showFullPrecision e01 else showFullPrecision e01)
+ <> "e01;\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 (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
@@ -161,9 +166,10 @@ 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 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)
@@ -177,12 +183,13 @@ 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)
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
@@ -205,7 +212,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
@@ -222,12 +229,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
@@ -235,33 +242,33 @@ 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'] ]
- allMotorcycles = firstMotorcycle:moreMotorcycles
+ allMotorcycles = firstMotorcycle:moreMotorcycles
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)
+ toGanja iNode@(INode firstPLine secondPLine (Slist rawMorePLines _) _) 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 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 <> (if hasArc iNode then [outAndErrOf iNode] else [])
instance GanjaAble StraightSkeleton where
toGanja (StraightSkeleton (Slist [[nodetree]] _) _) = toGanja nodetree
@@ -270,7 +277,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
@@ -297,7 +304,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
@@ -307,9 +314,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
@@ -324,7 +331,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'] ]
@@ -355,414 +362,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) -> translateRotatePPoint2 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
- outsidePLine = join2PPoint2 myMidPoint outsidePoint
- outsidePoint = eToPPoint2 $ pointFarOutsideContour contour
- myMidPoint = pPointBetweenPPoints (eToPPoint2 p1) (eToPPoint2 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 = translateRotatePPoint2 intersectionPPoint (coerce d1) (coerce r1)
- pp2 = translateRotatePPoint2 intersectionPPoint (coerce d2) (coerce r2)
- p1 = pToEPoint2 pp1
- p2 = pToEPoint2 pp2
- 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)
- where
- 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
- 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
- bisector1 = (\(NPLine2 a) -> PLine2 a) $ normalizePLine2 $ getOutsideArc pp1 (normalizePLine2 maybeFlippedpl1) pp2 (normalizePLine2 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, UlpSum)
-randomPLineWithErr x y dx dy = pLineFromEndpointsWithErr (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
-
-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)
-randomPLineThroughOrigin x y = pLineFromEndpointsWithErr (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))
-
--- | 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)
- 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)
- 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)
- 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)
- 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)]
-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/GeometricAlgebra.hs b/Graphics/Slicer/Math/GeometricAlgebra.hs
index 3e5f84fe4..79c6311c8 100644
--- a/Graphics/Slicer/Math/GeometricAlgebra.hs
+++ b/Graphics/Slicer/Math/GeometricAlgebra.hs
@@ -16,16 +16,59 @@
- 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,
+ scalarPart,
+ subVal,
+ subValPairWithErr,
+ subVecPair,
+ sumErrVals,
+ ulpRaw,
+ ulpVal,
+ unlikeVecPair,
+ valOf,
+ 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)
@@ -53,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)
@@ -87,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)
+-- | 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
@@ -750,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 79c2a216a..af5c17518 100644
--- a/Graphics/Slicer/Math/Intersections.hs
+++ b/Graphics/Slicer/Math/Intersections.hs
@@ -16,203 +16,171 @@
- 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.Intersections (getMotorcycleSegSetIntersections, getMotorcycleContourIntersections, contourIntersectionCount, getPLine2Intersections, intersectionOf, intersectionBetween, noIntersection, isCollinear, isAntiCollinear, isParallel, isAntiParallel) where
+{-
+ - This file contains code for retrieving and reasoning about the intersection of two projective lines.
+ -}
-import Prelude (Bool, Either(Left,Right), error, otherwise, show, (&&), (<>), ($), (<$>), (/=), (.), zip, Int, (<), (*), (||), (==), length, odd, realToFrac)
+module Graphics.Slicer.Math.Intersections (
+ intersectionBetween,
+ intersectionBetweenArcsOf,
+ intersectionOf,
+ intersectionsAtSamePoint,
+ isAntiCollinear,
+ isAntiParallel,
+ isCollinear,
+ isParallel,
+ noIntersection,
+ outputIntersectsLineSeg,
+ outputIntersectsPLineAt
+ ) where
-import Data.Maybe( Maybe(Just,Nothing), catMaybes, isJust, fromJust)
+import Prelude (Bool(True), (<>), ($), (<), (||), (==), (&&), (<$>), (<=), and, error, otherwise, show)
-import Data.List as L (filter)
+import Data.Either (Either(Left, Right), lefts, rights)
-import Slist.Type (Slist)
+import Data.Maybe (Maybe(Just, Nothing), catMaybes, isJust, isNothing)
-import Slist (len, slist)
+import Graphics.Slicer.Math.Definitions (LineSeg, mapWithFollower)
-import Graphics.Slicer.Definitions (ℝ)
+import Graphics.Slicer.Math.GeometricAlgebra (ulpVal)
-import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, mapWithNeighbors, startPoint, distance, lineSegsOfContour, endPoint, fudgeFactor, makeLineSeg)
+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)
-import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum))
+-- | 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
-import Graphics.Slicer.Math.Lossy (normalizePLine2)
+-- | 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
-import Graphics.Slicer.Math.PGA (CPPoint2, PIntersection(IntersectsIn, PParallel, PAntiParallel, PCollinear, PAntiCollinear), Intersection(HitEndPoint, HitStartPoint, NoIntersection), PLine2, intersectsWith, cPToEPoint2, distanceBetweenNPLine2sWithErr, outputIntersectsLineSeg, plinesIntersectIn, ulpOfLineSeg)
+-- | 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
-import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle))
+-- | 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
--- | 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, ulpOfLineSeg 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 = L.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, ulpOfLineSeg 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
-
--- | 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) $ intersectsWith (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.
-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
- openCircuit v = Just <$> v
- getPoints :: [(LineSeg, Either Point2 CPPoint2)] -> [Point2]
- getPoints vs = getPoint <$> vs
- where
- getPoint (_, Left v) = v
- getPoint (_, Right v) = cPToEPoint2 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.
-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)
+-- | 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
-- | Get the intersection point of two lines we know have an intersection point.
-intersectionOf :: PLine2 -> PLine2 -> CPPoint2
-intersectionOf pl1 pl2 = saneIntersection $ plinesIntersectIn pl1 pl2
+{-# INLINABLE intersectionOf #-}
+intersectionOf :: (ProjectiveLine2 a, ProjectiveLine2 b) => (a, PLine2Err) -> (b, PLine2Err) -> (CPPoint2, PPoint2Err)
+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 (IntersectsIn p _) = p
-
--- | Get the intersection point of two lines.
-intersectionBetween :: PLine2 -> PLine2 -> Maybe (Either PLine2 CPPoint2)
-intersectionBetween pl1 pl2 = saneIntersection $ plinesIntersectIn pl1 pl2
+ 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. 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
- (foundDistance, UlpSum foundErr) = distanceBetweenNPLine2sWithErr (normalizePLine2 pl1) (normalizePLine2 pl2)
- saneIntersection PAntiCollinear = Just $ Left pl1
- saneIntersection PCollinear = Just $ Left pl1
- saneIntersection PParallel = if foundDistance < realToFrac foundErr
- then Just $ Left pl1
+ (foundDistance, (_,_, foundErr)) = distance2PL l1 l2
+ saneIntersection PAntiCollinear = Just $ Left line1
+ saneIntersection PCollinear = Just $ Left line1
+ saneIntersection PParallel = if foundDistance < ulpVal foundErr
+ then Just $ Left line1
else Nothing
- saneIntersection PAntiParallel = if foundDistance < realToFrac foundErr
- then Just $ Left pl1
+ saneIntersection PAntiParallel = if foundDistance < ulpVal foundErr
+ then Just $ Left line1
else Nothing
- saneIntersection (IntersectsIn p _) = Just $ Right p
-
--- | 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
-
--- | check if two lines are really the same line.
-isCollinear :: PLine2 -> PLine2 -> 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 pline2 == PAntiCollinear
-
--- | check if two lines are parallel.
-isParallel :: PLine2 -> PLine2 -> Bool
-isParallel pline1 pline2 = plinesIntersectIn pline1 pline2 == PParallel
-
--- | check if two lines are anti-parallel.
-isAntiParallel :: PLine2 -> PLine2 -> Bool
-isAntiParallel pline1 pline2 = plinesIntersectIn pline1 pline2 == PAntiParallel
+ 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
+ (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)
+
+-- | 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
+ (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
+
+-- | 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)
+ 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 <= ulpVal resErr || res < 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 < errSum
+ where
+ (foundDistance, (_, _, _, _, _, resErr)) = distancePPToPL 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/Lossy.hs b/Graphics/Slicer/Math/Lossy.hs
index 81a69ab75..5aecdb0ae 100644
--- a/Graphics/Slicer/Math/Lossy.hs
+++ b/Graphics/Slicer/Math/Lossy.hs
@@ -19,117 +19,81 @@
-- | 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,
- distanceBetweenNPLine2s,
- distanceCPPointToNPLine,
+ distanceBetweenPPointsWithErr,
distancePPointToPLine,
- eToCPPoint2,
- eToNPLine2,
+ distancePPointToPLineWithErr,
eToPLine2,
- eToPPoint2,
getFirstArc,
- getInsideArc,
- join2CPPoint2,
join2PPoint2,
- makePPoint2,
- makeCPPoint2,
- normalizePLine2,
- pLineFromEndpoints,
pPointBetweenPPoints,
pPointOnPerp,
- translatePLine2
+ pToEPoint2,
+ translatePLine2,
+ translateRotatePPoint2
) where
-import Prelude (($), fst)
+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.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.Definitions (LineSeg, Point2)
-angleBetween :: NPLine2 -> NPLine2 -> ℝ
-angleBetween nPLine1 nPLine2 = fst $ angleBetweenWithErr nPLine1 nPLine2
+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
-canonicalizePPoint2 point = fst $ canonicalizePPoint2WithErr point
+-- | Canonicalize a euclidian projective point.
+canonicalizePPoint2 :: (ProjectivePoint2 a) => a -> CPPoint2
+canonicalizePPoint2 point = fst $ canonicalizeP point
+-- | Find the distance between two projective points.
distanceBetweenPPoints :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> ℝ
-distanceBetweenPPoints point1 point2 = fst $ distanceBetweenPPointsWithErr point1 point2
-
-distanceBetweenNPLine2s :: NPLine2 -> NPLine2 -> ℝ
-distanceBetweenNPLine2s nPLine1 nPLine2 = fst $ distanceBetweenNPLine2sWithErr nPLine1 nPLine2
-
--- | Find the unsigned distance between a point and a line.
-distanceCPPointToNPLine :: CPPoint2 -> NPLine2 -> ℝ
-distanceCPPointToNPLine point line = fst $ distanceCPPointToNPLineWithErr point line
+distanceBetweenPPoints point1 point2 = fst $ distance2PP (point1, mempty) (point2, mempty)
--- | Find the unsigned distance between a point and a line.
-distancePPointToPLine :: PPoint2 -> PLine2 -> ℝ
-distancePPointToPLine point line = fst $ distancePPointToPLineWithErr point line
+-- | 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
--- | Create a projective point from a euclidian point.
-eToCPPoint2 :: Point2 -> CPPoint2
-eToCPPoint2 point = fst $ eToCPPoint2WithErr point
+-- | 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)
--- | Create a normalized projective line from a euclidian line segment.
-eToNPLine2 :: LineSeg -> NPLine2
-eToNPLine2 l1 = normalizePLine2 $ fst $ eToPLine2WithErr l1
+-- | 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 an un-normalized projective line from a euclidian line segment.
eToPLine2 :: LineSeg -> PLine2
-eToPLine2 l1 = fst $ eToPLine2WithErr l1
+eToPLine2 l1 = fst $ eToPL 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.
+-- | 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 $ getFirstArcWithErr p1 p2 p3
-
-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
+getFirstArc p1 p2 p3 = fst $ Arcs.getFirstArc p1 p2 p3
--- | 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
-makePPoint2 :: ℝ -> ℝ -> PPoint2
-makePPoint2 x y = (\(CPPoint2 p) -> PPoint2 p) $ fst $ makeCPPoint2WithErr x y
-
--- | Normalize a PLine2.
-normalizePLine2 :: PLine2 -> NPLine2
-normalizePLine2 pl = fst $ normalizePLine2WithErr pl
-
--- | Create a projective line from a pair of euclidian points.
-pLineFromEndpoints :: Point2 -> Point2 -> PLine2
-pLineFromEndpoints point1 point2 = fst $ pLineFromEndpointsWithErr point1 point2
+-- | 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
-- | 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 $ 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 :: 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
+-- | Convert a projective endpoint to a euclidian endpoint.
+pToEPoint2 :: (ProjectivePoint2 a) => a -> Point2
+pToEPoint2 ppoint = fst $ pToEP ppoint
+
+-- | Translate a projective line along it's perpendicular bisector.
+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.
+translateRotatePPoint2 :: (ProjectivePoint2 a) => a -> ℝ -> ℝ -> PPoint2
+translateRotatePPoint2 ppoint d rotation = fst $ translateRotatePPoint2WithErr ppoint d rotation
diff --git a/Graphics/Slicer/Math/PGA.hs b/Graphics/Slicer/Math/PGA.hs
index 495720e05..c431f8f6c 100644
--- a/Graphics/Slicer/Math/PGA.hs
+++ b/Graphics/Slicer/Math/PGA.hs
@@ -16,64 +16,75 @@
- 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.
{-# LANGUAGE DataKinds #-}
-- | 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
+ ),
+ 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,
+ cPPointOf,
+ ePointOf,
+ errOfCPPoint
+ ),
PPoint2(PPoint2),
- CPPoint2(CPPoint2),
- Arcable(hasArc, outOf, ulpOfOut, outUlpMag),
- Pointable(canPoint, pPointOf, ePointOf),
- PPoint2PosErr(PPoint2PosErr),
- ProjectivePoint2,
- angleBetweenWithErr,
+ PPoint2Err,
+ ProjectiveLine2(
+ normalizeL,
+ vecOfL
+ ),
+ ProjectivePoint2(
+ canonicalizeP,
+ vecOfP
+ ),
+ angleBetween2PL,
+ angleCosBetween2PL,
+ canonicalizedIntersectionOf2PL,
combineConsecutiveLineSegs,
- canonicalizePPoint2WithErr,
- cPToEPoint2,
- distanceBetweenPPointsWithErr,
- distanceBetweenNPLine2sWithErr,
- distanceCPPointToNPLineWithErr,
- distancePPointToPLineWithErr,
- eToCPPoint2WithErr,
- eToPLine2WithErr,
- eToPPoint2WithErr,
- flipPLine2,
- getInsideArcWithErr,
- getFirstArcWithErr,
- intersectsWith,
+ cPPointAndErrOf,
+ distancePPToPL,
+ distance2PL,
+ distance2PP,
+ eToPL,
+ eToPP,
+ flipL,
+ fuzzinessOfL,
+ fuzzinessOfP,
+ interpolate2PP,
intersectsWithErr,
- join2PPoint2WithErr,
- join2CPPoint2WithErr,
- makeCPPoint2WithErr,
- normalizePLine2WithErr,
- outputIntersectsLineSeg,
- pLineFromEndpointsWithErr,
- pLineIntersectionWithErr,
+ intersect2PL,
+ join2EP,
+ join2PP,
+ makeCPPoint2,
+ oppositeDirection,
+ outAndErrOf,
+ pLineErrAtPPoint,
+ pLineIntersectsLineSeg,
pLineIsLeft,
- pPointBetweenPPointsWithErr,
+ plinesIntersectIn,
pPointOnPerpWithErr,
pPointsOnSameSideOfPLine,
- pToEPoint2,
- plinesIntersectIn,
- translatePLine2WithErr,
- translateRotatePPoint2,
- ulpOfLineSeg,
- ulpOfPLine2
+ pToEP,
+ translateL,
+ translateRotatePPoint2WithErr
) where
-import Prelude (Bool, Eq((==),(/=)), Show(show), Ord, ($), (*), (-), (>=), (&&), (<$>), mempty, otherwise, signum, (>), (<=), (+), sqrt, negate, (/), (||), (<), (<>), abs, error, sin, cos, realToFrac, fst, sum, (.), realToFrac)
-
-import GHC.Generics (Generic)
-
-import Control.DeepSeq (NFData)
+import Prelude (Bool, Eq((==)), Monoid(mempty), Semigroup((<>)), Show(show), ($), (-), (>=), (&&), (<$>), (>), (<=), (+), (/), (||), (<), abs, cos, error, negate, otherwise, realToFrac, signum, sin)
import Data.Bits.Floating.Ulp (doubleUlp)
@@ -81,11 +92,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), maybeToList, catMaybes, fromJust, isNothing, maybeToList)
+import Data.Maybe (Maybe(Just, Nothing), fromJust, isJust, isNothing, maybeToList)
-import Data.Set (Set, singleton, fromList, elems)
+import Data.Set (singleton, fromList)
import Safe (lastMay, initSafe)
@@ -93,11 +104,13 @@ 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, 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)
-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.Line (combineLineSegs, makeLineSeg)
-import Graphics.Slicer.Math.Line (combineLineSegs)
+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.
@@ -111,222 +124,192 @@ data PIntersection =
| PAntiCollinear
| PParallel
| PAntiParallel
- | IntersectsIn !CPPoint2 !(UlpSum, UlpSum, UlpSum, UlpSum, UlpSum, UlpSum)
+ | 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.
-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)
+ || (idealNorm <= 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, intersectUlp, npl1Ulp, npl2Ulp, iaErr, mempty)
- where
- (idealNorm, idnErr) = idealNormPPoint2WithErr 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
- -- 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
+ | 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, resErr)
+ where
+ -- | The distance within which we consider (anti)parallel lines to be (anti)colinear.
+ 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 pl1 pl2
+ (idealNorm, idnErr) = idealNormOfP res
+ (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 -> b -> Maybe Bool
-pLineIsLeft pl1 pl2
- | npl1 == npl2 = Nothing
- | abs res <= 0 = Nothing
- | otherwise = Just $ res > 0
+pLineIsLeft line1 line2
+ | abs res <= ulpVal angleFuzz = Nothing
+ | otherwise = Just $ res > 0
where
- -- FIXME: naieve implementation. use npl1Err and npl2Err to get two angle differences.
- (res, _) = angleCos npl1 npl2
- (npl1, _) = normalize pl1
- (npl2, _) = normalize 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
-
--- | 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) = meet2PLine2WithErr npl1 npl2
- (npl1, npl1Err) = normalize pl1
- (npl2, 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
- | 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
-
-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
- | valOf 0 foundVal == 0 = error "attempted to get the distance of an ideal point."
- | otherwise = (res, ulpTotal)
+ (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.
+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
- (res, resErr) = 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
- foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(CPPoint2 (GVec vals)) -> vals) point
- (NPLine2 nplvec,_) = normalize line
+ 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 (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 at the given point.
+ -- FIXME: where should we put this in PLine2Err?
+ (PLine2 perpLine, (_, _, (plMulErr, plAddErr))) = perpLineAt nLine cPoint
+ 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.
-pPointsOnSameSideOfPLine :: (ProjectiveLine2 c) => PPoint2 -> PPoint2 -> c -> Maybe Bool
+-- 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 = 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
- unlikeP1UlpSum = sumErrVals unlikeP1MulErr <> sumErrVals unlikeP1AddErr
- 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
- lv1 = vecOfL $ forcePLine2Basis 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
- (cpoint1, _) = canonicalize point1
- (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)
- where
- (ideal, idealUlpSum) = idealNormPPoint2WithErr $ PPoint2 likeRes
- resUlpSum = idealUlpSum <> sumErrVals likeMulErr <> sumErrVals likeAddErr
- (likeRes, (likeMulErr, likeAddErr)) = p1 ⎣+ p2
- p1 = vecOfL $ forcePLine2Basis npl1
- p2 = vecOfL $ forcePLine2Basis npl2
- (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
- (PLine2 p1) = forcePLine2Basis $ PLine2 pv1
- (PLine2 p2) = forcePLine2Basis $ PLine2 pv2
- (NPLine2 pv1, _) = normalize pl1
- (NPLine2 pv2, _) = normalize pl2
+ pv1 = vecOfP $ forceBasisOfP point1
+ pv2 = vecOfP $ forceBasisOfP point2
+ 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
+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 - ulpRaw 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?
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.
minAngle :: ℝ
- minAngle = realToFrac (realToFrac (ulpVal resErr) + (-1) :: Rounded 'TowardNegInf ℝ)
- (res, resErr) = angleBetweenWithErr a b
+ 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.
-pPointOnPerpWithErr :: (ProjectiveLine2 a) => a -> PPoint2 -> ℝ -> (PPoint2, UlpSum)
-pPointOnPerpWithErr line rppoint d = (PPoint2 res,
- ulpTotal)
- where
- res = motor•pvec•reverseGVec motor
- (NPLine2 rlvec, lErr) = normalize line
- (perpLine, (plMulErr,plAddErr))= lvec ⨅+ pvec
- (PLine2 lvec) = forcePLine2Basis $ PLine2 rlvec
- (PPoint2 pvec) = forcePPoint2Basis rppoint
+-- 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 = (PPoint2 res, resErr)
+ where
+ -- translate the input point along the perpendicular bisector.
+ res = motor•pVec•reverseGVec motor
+ resErr = (nLineErr, cPointErr, perpLineErrs, gaIScaledErr)
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.
+ -- 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 <>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 :: GVec -> ℝ -> (GVec, PLine2Err)
-translateProjectiveLine2WithErr lineVec d = (res, PLine2Err resErr mempty nErr tErr mempty)
- where
- (res, resErr) = 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
- (n, nErr) = normOfPLine2WithErr (PLine2 lineVec)
+ 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 this in the error quotent of PLine2Err?
+ (PLine2 perpLine, (nLineErr, _, perpLineErrs)) = perpLineAt line cPoint
+ pVec = vecOfP $ forceBasisOfP cPoint
+ (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])))
+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
+ (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.
-translateRotatePPoint2 :: PPoint2 -> ℝ -> ℝ -> PPoint2
-translateRotatePPoint2 ppoint d rotation = PPoint2 $ translator•pvec•reverseGVec translator
- where
- (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
- 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)])
- 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.
- gaIScaled = GVec [GVal (d/2) (fromList [GEZero 1, GEPlus 1, GEPlus 2])]
+-- 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
+ 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
+ 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
+
+----------------------------------------------------------
+-------------------- Node Interface ----------------------
+----------------------------------------------------------
+
+-- | Does this node have an output (resulting) line?
+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.
+ 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 (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
+
+-- | 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, errOfCPPoint node)
+ | otherwise = error "not able to resolve node to a point."
----------------------------------------------------------
-------------- Euclidian Mixed Interface -----------------
@@ -334,200 +317,149 @@ translateRotatePPoint2 ppoint d rotation = PPoint2 $ translator•pvec•reverse
-- | Intersection events that can only happen with line segments.
data Intersection =
- NoIntersection !CPPoint2 !(UlpSum, UlpSum, UlpSum, UlpSum)
+ NoIntersection !CPPoint2 !(PLine2Err, PLine2Err, PPoint2Err)
| HitStartPoint !LineSeg
| 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 pl2
-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, Pointable a) => a -> (LineSeg, UlpSum) -> Either Intersection PIntersection
-outputIntersectsLineSeg source (l1, UlpSum l1Err)
- -- 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
- where
- foundError :: ℝ
- foundError = realToFrac $ l1Err + pl1Err + pl2Err + npl1Err + npl2Err + 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) = angleBetweenWithErr npl1 npl2
- (npl1, UlpSum npl1Err) = normalizePLine2WithErr pl1
- (npl2, UlpSum npl2Err) = normalizePLine2WithErr 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)
- | otherwise = error
- $ "no arc from source?\n"
- <> show source <> "\n"
- (rawIntersection, UlpSum rawIntersectionErr) = fromJust canonicalizedIntersection
- canonicalizedIntersection = canonicalizeIntersectionWithErr pl1 pl2
- (canonicalizedSource, UlpSum canonicalizedSourceErr) = canonicalizePPoint2WithErr $ pPointOf source
- (intersectionDistance, UlpSum intersectionDistanceErr) = distanceBetweenPPointsWithErr canonicalizedSource rawIntersection
-
--- | A type alias, for cases where either input is acceptable.
-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 (Left l1@(rawL1,_)) (Right pl1@(rawPL1,_)) = 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
- (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
- (pl2, _) = eToPLine2WithErr rawL1
+-- | 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
+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 :: (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
- | 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
- | hasIntersection && valOf 0 foundVal == 0 = error "intersection, but cannot cannonicalize."
+pLineIntersectsLineSeg :: (ProjectiveLine2 a) => (a, PLine2Err) -> LineSeg -> Either Intersection PIntersection
+pLineIntersectsLineSeg (pl1, pl1ErrOrigin) l1
+ | res == PParallel = Right PParallel
+ | res == PAntiParallel = Right PAntiParallel
+ | res == PCollinear = Right PCollinear
+ | res == PAntiCollinear = Right PAntiCollinear
+ | 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 (UlpSum $ realToFrac ulpStartSum, UlpSum $ realToFrac ulpEndSum, UlpSum pl1Err, UlpSum pl2Err, UlpSum rawIntersectErr, 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
- (startDistance, UlpSum startDistanceErr) = distanceBetweenPPointsWithErr rawIntersection start
- (endDistance, UlpSum endDistanceErr) = distanceBetweenPPointsWithErr rawIntersection end
- (start, PPoint2PosErr startErr) = eToCPPoint2WithErr $ startPoint l1
- (end, PPoint2PosErr endErr) = eToCPPoint2WithErr $ 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
- | pl1Err < 0 || pl2Err < 0 || l1Err < 0 || rawIntersectErr < 0 = error "negative ULP?\n"
- | otherwise = pl1Err + pl2Err + l1Err + (rawIntersectErr * realToFrac ulpScale)
- 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) = canonicalizePPoint2WithErr rawIntersect
- (rawIntersect, UlpSum rawIntersectErr) = pLineIntersectionWithErr pl1 pl2
- (pl2, UlpSum pl2Err) = eToPLine2WithErr l1
+ | 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)
+ ulpStartSum = ulpVal startDistanceErr
+ ulpEndSum = 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)
+ hasRawIntersection = isJust foundVal
+ (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
+ (rawIntersect, (npl1Err, npl2Err, rawIntersectErr)) = intersect2PL pl1 pl2
+ start = eToPP $ startPoint l1
+ end = eToPP $ endPoint l1
+ (pl2, pl2ErrOrigin) = eToPL l1
+ 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, 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
- | 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
- | hasIntersection && plinesIntersectIn pl1 pl2 == PCollinear = Right PCollinear
- | hasIntersection && plinesIntersectIn pl1 pl2 == 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 = Right $ IntersectsIn rawIntersection (UlpSum $ realToFrac ulpStartSum1, UlpSum $ realToFrac ulpEndSum1, UlpSum $ realToFrac ulpStartSum2, UlpSum $ realToFrac ulpEndSum2, UlpSum ulpTotal, UlpSum rawIntersectErr)
- | 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
- ulpStartSum1, ulpEndSum1, ulpStartSum2, ulpEndSum2 :: ℝ
- ulpStartSum1 = realToFrac $ ulpTotal+start1DistanceErr
- ulpStartSum2 = realToFrac $ ulpTotal+start2DistanceErr
- ulpEndSum1 = realToFrac $ ulpTotal+end1Err
- ulpEndSum2 = realToFrac $ ulpTotal+end2Err
- (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, PPoint2PosErr start1Err) = eToCPPoint2WithErr $ startPoint l1
- (end1, PPoint2PosErr end1Err) = eToCPPoint2WithErr $ endPoint l1
- (start2, PPoint2PosErr start2Err) = eToCPPoint2WithErr $ startPoint l2
- (end2, PPoint2PosErr 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.
- ulpTotal
- | 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
- (npl1, _) = normalizePLine2WithErr pl1
- (npl2, _) = normalizePLine2WithErr 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) = canonicalizePPoint2WithErr rawIntersect
- (rawIntersect, UlpSum rawIntersectErr) = pLineIntersectionWithErr pl1 pl2
+lineSegIntersectsLineSeg :: LineSeg -> LineSeg -> Either Intersection PIntersection
+lineSegIntersectsLineSeg l1 l2
+ | res == PParallel = Right PParallel
+ | res == PAntiParallel = Right PAntiParallel
+ | hasIntersection && res == PCollinear = Right PCollinear
+ | hasIntersection && res == PAntiCollinear = Right PAntiCollinear
+ | 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) < 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)
+ | 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)
+ -- 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
+ end2FudgeFactor = end2DistanceErr <> pLineErrAtPPoint (pl2,pl2Err) end2
+ ulpStart1Sum = ulpVal start1DistanceErr
+ ulpEnd1Sum = ulpVal end1DistanceErr
+ 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)
+ (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
+ (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
+ (rawIntersect, (npl1Err, npl2Err, rawIntersectErr)) = intersect2PL pl1 pl2
+ 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"
+ <> "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 -> ℝ -> ℝ -> Bool
-onSegment ls i startUlp endUlp =
+onSegment :: (ProjectivePoint2 a) => LineSeg -> (a, PPoint2Err) -> Bool
+onSegment lineSeg iPoint@(iP,_) =
(startDistance <= startFudgeFactor)
- || (midDistance <= (lengthOfSegment/2) + midFudgeFactor)
+ || (lineDistance <= lineFudgeFactor && (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
- (start, PPoint2PosErr startErr) = eToCPPoint2WithErr $ startPoint ls
- (mid, UlpSum midErr) = pPointBetweenPPointsWithErr start end 0.5 0.5
- (end, PPoint2PosErr endErr) = eToCPPoint2WithErr $ endPoint ls
- lengthOfSegment = distance (startPoint ls) (endPoint ls)
- startFudgeFactor, midFudgeFactor, endFudgeFactor :: ℝ
- startFudgeFactor = realToFrac $ realToFrac startUlp + startDistanceErr + startErr
- midFudgeFactor = realToFrac $ abs (realToFrac $ doubleUlp lengthOfSegment) + midDistanceErr + midErr
- endFudgeFactor = realToFrac $ realToFrac endUlp + endDistanceErr + endErr
+ 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
+ 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]
@@ -552,235 +484,33 @@ 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 (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) = normalizePLine2WithErr side1Raw
- (side1Raw, UlpSum side1RawErr) = pLineFromEndpointsWithErr p1 p2
- side1Err = side1NormErr+side1RawErr
- (NPLine2 side2, UlpSum side2NormErr) = normalizePLine2WithErr side2Raw
- (side2Raw, UlpSum side2RawErr) = pLineFromEndpointsWithErr p2 p3
- side2Err = side2NormErr+side2RawErr
- (NPLine2 quadRes, UlpSum quadResErr) = normalizePLine2WithErr quad
- (quad, UlpSum quadErr) = pLineFromEndpointsWithErr 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 $ flipPLine2 line1
- pv2 = vecOfL line2
+ sameLineSeg = plinesIntersectIn (eToPL l1) (eToPL l2) == PCollinear
+ sameMiddlePoint = startPoint l2 == endPoint l1
------------------------------------------------
----- 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)
-
--- | Can this node be resolved into a point in 2d space?
-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
- hasArc :: a -> Bool
- outOf :: a -> PLine2
- ulpOfOut :: a -> UlpSum
- outUlpMag :: a -> ℝ
-
-class ProjectivePoint2 a where
- canonicalize :: a -> (CPPoint2, UlpSum)
- vecOfP :: a -> GVec
-
-instance ProjectivePoint2 PPoint2 where
- canonicalize p = canonicalizePPoint2WithErr p
- vecOfP (PPoint2 a) = a
-
-instance ProjectivePoint2 CPPoint2 where
- canonicalize p = (p, mempty)
- 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
- normalize :: a -> (NPLine2, UlpSum)
- flipPLine2 :: a -> a
- forcePLine2Basis :: a -> a
- translatePLine2WithErr :: a -> ℝ -> (a, UlpSum)
- vecOfL :: a -> GVec
-
-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
- vecOfL (NPLine2 a) = a
-
-instance ProjectiveLine2 PLine2 where
- normalize a = 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
-
--- | the two types of error of a projective line.
-data PLine2Err = PLine2Err
- -- AddErr
- [ErrVal]
- -- NormalizationErr
- [ErrVal]
- -- NormErr
- UlpSum
- -- Translation Error. always in GEZero 1.
- UlpSum
- -- JoinErr
- ([ErrVal], [ErrVal])
- deriving (Eq, Show)
-
--- | 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)
+-- | Create a canonical euclidian projective point from the given euclidian point.
+euclidianToProjectivePoint2, eToPP :: Point2 -> CPPoint2
+euclidianToProjectivePoint2 (Point2 (x,y)) = res
where
- vec = dual2DGVec $ res
- ulpSum = sumErrVals mulErr <> sumErrVals addErr
- (res, (addErr, mulErr)) = dual2DGVec a ⎤+ dual2DGVec b
-infixl 9 ∨+
-
--- | a typed join function. join two points, returning a line.
-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
-
--- | 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) = forceCPPoint2Basis pp1
- (CPPoint2 pv2) = forceCPPoint2Basis pp2
-
--- | A typed meet function. the meeting of two lines is a point.
-meet2PLine2WithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (PPoint2, UlpSum)
-meet2PLine2WithErr line1 line2 = (PPoint2 res,
- ulpSum)
- where
- ulpSum = sumErrVals mulErr <> sumErrVals addErr
- (res, (addErr, mulErr)) = pv1 ⎤+ pv2
- (PLine2 pv1) = forcePLine2Basis $ PLine2 plr1
- (PLine2 pv2) = forcePLine2Basis $ PLine2 plr2
- (NPLine2 plr1,_) = normalize line1
- (NPLine2 plr2,_) = normalize line2
-
-newtype PPoint2PosErr = PPoint2PosErr (Rounded 'TowardInf ℝ)
+ res = makeCPPoint2 x y
+eToPP = euclidianToProjectivePoint2
-eToPPoint2WithErr :: Point2 -> (PPoint2, PPoint2PosErr)
-eToPPoint2WithErr (Point2 (x,y)) = (PPoint2 res, resUlp)
+-- | Create a canonical euclidian projective point from the given coordinates.
+makeCPPoint2 :: ℝ -> ℝ -> CPPoint2
+makeCPPoint2 x y = cPPoint
where
- (CPPoint2 res, resUlp) = makeCPPoint2WithErr x y
-
-eToCPPoint2WithErr :: Point2 -> (CPPoint2, PPoint2PosErr)
-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 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)
-
--- | 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 = 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
- 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))
- | e12Val == 0 = Nothing
- | e12Val == 1 = Just $ Point2 (xVal, yVal)
- | otherwise = Just $ Point2 (xVal, yVal)
- where
- (CPPoint2 (GVec vals)) = fst $ canonicalizePPoint2WithErr 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)
+ 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
-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))
@@ -789,196 +519,15 @@ 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 []
- [
- GVal realVal (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)
- ]
- 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
-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 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
-
--- | Reverse a line. same line, but pointed in the other direction.
-flipGVec :: GVec -> GVec
-flipGVec (GVec vals) = 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))
- ]
-
-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)
- 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)
-
--- | 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]
-
--- | 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. ----
----------------------------------------------------------------------
-
--- | find the idealized norm of a projective point (ideal or not).
-idealNormPPoint2WithErr :: PPoint2 -> (ℝ, UlpSum)
-idealNormPPoint2WithErr ppoint@(PPoint2 (GVec rawVals))
- | 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)) $ pToEPoint2 ppoint
- e12Val = valOf 0 (getVal [GEPlus 1, GEPlus 2] 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))
- | 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)
- 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 $ 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
- 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.
-canonicalizeIntersectionWithErr :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> Maybe (CPPoint2, UlpSum)
-canonicalizeIntersectionWithErr pl1 pl2
- | isNothing foundVal = Nothing
- | otherwise = Just (cpp1, ulpTotal)
- where
- (cpp1, UlpSum canonicalizationErr) = canonicalizePPoint2WithErr pp1
- (pp1, UlpSum intersectionErr) = pLineIntersectionWithErr pl1 pl2
- ulpTotal = UlpSum $ intersectionErr + canonicalizationErr
- foundVal = getVal [GEPlus 1, GEPlus 2] $ (\(PPoint2 (GVec vals)) -> vals) pp1
-
--- | 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
- vec = vecOfL line
-
--- | find the norm of a given PLine2
-normOfPLine2WithErr :: (ProjectiveLine2 a) => a -> (ℝ, UlpSum)
-normOfPLine2WithErr pline = (res, ulpTotal)
+euclidianToProjectiveLine, eToPL :: LineSeg -> (PLine2, PLine2Err)
+euclidianToProjectiveLine l = (res, resErr)
where
- res = sqrt sqNormOfPLine2
- (sqNormOfPLine2, UlpSum sqNormErr) = sqNormOfPLine2WithErr pline
- ulpTotal = UlpSum $ abs (realToFrac $ doubleUlp res) + sqNormErr
+ (res, (_, _, resErr)) = join2PP (eToPP $ startPoint l) (eToPP $ endPoint l)
+eToPL l = euclidianToProjectiveLine l
--- | find the squared norm of a given PLine2
-sqNormOfPLine2WithErr :: (ProjectiveLine2 a) => a -> (ℝ, UlpSum)
-sqNormOfPLine2WithErr line = (res, ulpTotal)
+joinTwoEuclidianPoints, join2EP :: Point2 -> Point2 -> (PLine2, PLine2Err)
+joinTwoEuclidianPoints p1 p2 = (res, resErr)
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
+ (res, (_, _, resErr)) = join2PP (eToPP p1) (eToPP p2)
+join2EP p1 p2 = joinTwoEuclidianPoints p1 p2
diff --git a/Graphics/Slicer/Math/PGAPrimitives.hs b/Graphics/Slicer/Math/PGAPrimitives.hs
new file mode 100644
index 000000000..1c7068843
--- /dev/null
+++ b/Graphics/Slicer/Math/PGAPrimitives.hs
@@ -0,0 +1,774 @@
+{- 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 #-}
+
+-- 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".
+
+module Graphics.Slicer.Math.PGAPrimitives
+ (
+ CPPoint2(CPPoint2),
+ NPLine2(NPLine2),
+ PLine2(PLine2),
+ PLine2Err(PLine2Err),
+ PPoint2(PPoint2),
+ PPoint2Err(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
+ ) where
+
+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)
+
+import Data.Bits.Floating.Ulp (doubleUlp)
+
+import Data.Either (Either(Left, Right), fromRight, isRight)
+
+import Data.List (foldl', sort)
+
+import Data.Maybe (Maybe(Just,Nothing), fromJust, isJust, isNothing)
+
+import Data.Set (Set, elems, fromList, singleton)
+
+import Data.Typeable (Typeable, cast, typeOf)
+
+import GHC.Generics (Generic)
+
+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, ulpRaw, ulpVal, valOf)
+
+import Numeric.Rounded.Hardware (Rounded, RoundingMode(TowardNegInf), getRounded)
+
+--------------------------------
+--- common support functions ---
+--------------------------------
+
+-- | 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))
+ where
+ (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...
+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 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)
+ ]
+
+-- | 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
+
+-------------------------------
+--- Projective Line Support ---
+-------------------------------
+
+-- | A projective line in 2D space.
+newtype PLine2 = PLine2 GVec
+ deriving (Eq, Generic, NFData, Show, Typeable)
+
+-- | A normalized projective line in 2D space.
+newtype NPLine2 = NPLine2 GVec
+ deriving (Eq, Generic, NFData, Show, Typeable)
+
+-- | The typeclass definition. functions that must be implemented for any projective line type.
+class (Eq a, Show a, Typeable a) => ProjectiveLine2 a where
+ consLikeL :: a -> (GVec -> a)
+ normalizeL :: a -> (NPLine2, PLine2Err)
+ vecOfL :: a -> GVec
+
+-- | The implementation of typeclass operations for normalized lines.
+instance ProjectiveLine2 NPLine2 where
+ consLikeL _ = NPLine2
+ normalizeL l = (l, mempty)
+ vecOfL (NPLine2 v) = v
+
+-- | The implementation of typeclass operations for un-normalized lines.
+instance ProjectiveLine2 PLine2 where
+ consLikeL _ = PLine2
+ normalizeL l = normalizeProjectiveLine l
+ vecOfL (PLine2 v) = v
+
+-- | The 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
+
+-- | 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.
+{-# INLINABLE angleBetweenProjectiveLines #-}
+angleBetweenProjectiveLines :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, ([ErrVal], [ErrVal]), UlpSum))
+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. 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
+ (likeRes, (likeMulErr, likeAddErr)) = lv1 ⎣+ lv2
+ lv1 = vecOfL $ forceBasisOfL npl1
+ lv2 = vecOfL $ forceBasisOfL npl2
+ (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.
+{-# INLINABLE distanceBetweenProjectiveLines #-}
+distanceBetweenProjectiveLines :: (ProjectiveLine2 a, ProjectiveLine2 b) => a -> b -> (ℝ, (PLine2Err, PLine2Err, ([ErrVal], [ErrVal]), UlpSum))
+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)
+ (like, likeErr) = lv1 ⎣+ lv2
+ lv1 = vecOfL $ forceBasisOfL npl1
+ lv2 = vecOfL $ forceBasisOfL npl2
+ (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.
+{-# INLINABLE distance2PL #-}
+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, flipL :: (ProjectiveLine2 a) => a -> a
+-- | Actual implementation.
+flipProjectiveLine line = (consLikeL line) 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 line
+-- | Wrapper.
+flipL l = flipProjectiveLine l
+
+-- | Ensure all of the '0' components exist on a Projective Line.
+forceProjectiveLineBasis, forceBasisOfL :: (ProjectiveLine2 a) => a -> a
+-- | Actual implementation.
+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)] vec
+ gnums = case vals of
+ [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, 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
+ 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 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.
+{-# INLINABLE intersectionOfProjectiveLines #-}
+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.
+{-# 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,
+ npl2Err,
+ resUnlikeErr))
+ where
+ (res, resUnlikeErr) = lv1 ⎤+ lv2
+ lv1 = vecOfL $ forceBasisOfL npl1
+ lv2 = vecOfL $ forceBasisOfL npl2
+ (npl1, npl1Err) = normalizeL line1
+ (npl2, npl2Err) = normalizeL line2
+
+-- | Normalize a Projective Line.
+normalizeProjectiveLine :: (ProjectiveLine2 a) => a -> (NPLine2, PLine2Err)
+normalizeProjectiveLine 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.
+-- FIXME: should we be placing this error in the PLine2Err? it doesn't effect resolving the line...
+normOfProjectiveLine, normOfL :: (ProjectiveLine2 a) => a -> (ℝ, PLine2Err)
+-- | Actual implementation.
+normOfProjectiveLine 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)
+ 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, sqNormOfL :: (ProjectiveLine2 a) => a -> (ℝ, UlpSum)
+-- | Actual implementation.
+squaredNormOfProjectiveLine 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
+-- | 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, 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
+ m = GVec [GVal tAdd (singleton (GEZero 1))]
+ -- the amount to add to the GEZero 1 component.
+ tAdd = d * norm
+ tUlp = UlpSum $ abs $ realToFrac $ doubleUlp tAdd
+ (norm, normErr) = normOfL line
+-- | Wrapper.
+translateL l d = translateProjectiveLine l d
+
+-----------------------------------------
+--- Projective Line Error Calculation ---
+-----------------------------------------
+
+-- | 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.
+-- 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 = xInterceptFuzz <> yInterceptFuzz
+ -- Only the xIntercept is real. This line is parallel to the Y axis.
+ | xInterceptIsRight = rawXInterceptFuzz
+ -- Only the yIntercept is real. This line is parallel to the X axis.
+ | yInterceptIsRight = rawYInterceptFuzz
+ -- This line passes through the origin (0,0).
+ | otherwise = mempty
+ 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 $ 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)
+ 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 $ 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
+ 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)
+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)
+ -- 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 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.
+ 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)
+ -- This line is (anti)colinear with the Y axis.
+ | isNothing rawX = Just (Left line, mempty)
+ -- 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.
+ 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 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".
+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.
+-- FIXME: what was the older method we used here? perhaps it has less opportunities for fuzziness?
+{-# INLINABLE angleCosBetweenProjectiveLines #-}
+angleCosBetweenProjectiveLines line1 line2
+ | isNothing canonicalizedIntersection = (0, mempty)
+ | 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 _ 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
+ -- I, the infinite point.
+ gaI = GVec [GVal 1 (fromList [GEZero 1, GEPlus 1, GEPlus 2])]
+ lvec1 = vecOfL $ forceBasisOfL line1
+ lvec2 = vecOfL $ forceBasisOfL line2
+-- | Wrapper.
+{-# INLINABLE angleCosBetween2PL #-}
+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.
+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) = canonicalizeP pp1
+ (pp1, (l1Err, l2Err, pp1Err)) = intersect2PL line1 line2
+-- | Wrapper.
+{-# INLINABLE canonicalizedIntersectionOf2PL #-}
+canonicalizedIntersectionOf2PL l1 l2 = canonicalizedIntersectionOfProjectiveLines l1 l2
+
+--------------------------------
+--- 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, Ord, 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
+
+-- | A fake instance; so when we are sorting (PPoint2, PPoint2Err) pairs, the latter doesn't matter.
+instance Ord PPoint2Err where
+ compare _ _ = EQ
+
+class (Eq a, Show a, Typeable a) => ProjectivePoint2 a where
+ canonicalizeP :: a -> (CPPoint2, PPoint2Err)
+ consLikeP :: a -> (GVec -> a)
+ isIdealP :: a -> Bool
+ vecOfP :: a -> GVec
+
+instance ProjectivePoint2 PPoint2 where
+ canonicalizeP p = canonicalizeProjectivePoint p
+ consLikeP (PPoint2 _) = PPoint2
+ isIdealP p = projectivePointIsIdeal p
+ vecOfP (PPoint2 a) = a
+
+instance ProjectivePoint2 CPPoint2 where
+ canonicalizeP p = (p, mempty)
+ consLikeP (CPPoint2 _) = CPPoint2
+ isIdealP _ = False
+ 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.
+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.
+ | valOf 1 foundVal == 1 = (CPPoint2 $ GVec rawVals, mempty)
+ | otherwise = (res, PPoint2Err mempty scaledErrs mempty mempty mempty mempty mempty)
+ where
+ 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])]
+ 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))
+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)
+ -- 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) = 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, forceBasisOfP :: (ProjectivePoint2 a) => a -> a
+-- | Actual implementation.
+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]] vec
+ gnums = case vals of
+ [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, idealNormOfP :: (ProjectivePoint2 a) => a -> (ℝ, UlpSum)
+-- | Actual implementation.
+idealNormOfProjectivePoint point
+ | 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 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.
+{-# INLINABLE joinOfProjectivePoints #-}
+joinOfProjectivePoints, join2PP :: (ProjectivePoint2 a, ProjectivePoint2 b) => a -> b -> (PLine2, (PPoint2Err, PPoint2Err, PLine2Err))
+-- | Actual implementation.
+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
+ pv1 = vecOfP $ forceBasisOfP cPoint1
+ pv2 = vecOfP $ forceBasisOfP cPoint2
+ (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.
+-- 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
+ | isIdealP 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)
+ (rawRes, rawResErr) = addVecPairWithErr weighedStart weighedStop
+ (weighedStart, weighedStartErr) = mulScalarVecWithErr weight1 rawStartPoint
+ (weighedStop, weighedStopErr) = mulScalarVecWithErr weight2 rawStopPoint
+ rawStartPoint = vecOfP cStartPoint
+ rawStopPoint = vecOfP cStopPoint
+ (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.
+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, pToEP :: (ProjectivePoint2 a) => a -> (Point2, PPoint2Err)
+-- | Actual implementation.
+projectivePointToEuclidianPoint point
+ | 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) = canonicalizeP point
+-- | Wrapper.
+pToEP p = projectivePointToEuclidianPoint p
+
+------------------------------------------
+--- 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. 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.
+fuzzinessOfProjectivePoint, fuzzinessOfP :: (ProjectivePoint2 a) => (a, PPoint2Err) -> UlpSum
+-- | Actual implementation.
+fuzzinessOfProjectivePoint (point, pointErr) = UlpSum $ sumTotal * realToFrac (1+(1000*(abs angleIn + realToFrac (ulpRaw $ sumPPointErrs angleUnlikeAddErr <> sumPPointErrs angleUnlikeMulErr))))
+ where
+ sumTotal = ulpRaw $ sumPPointErrs pJoinAddErr
+ <> sumPPointErrs pJoinMulErr
+ <> sumPPointErrs pCanonicalizeErr
+ <> sumPPointErrs pAddErr
+ <> sumPPointErrs pIn1MulErr
+ <> sumPPointErrs pIn2MulErr
+ (PPoint2Err (pJoinAddErr, pJoinMulErr) pCanonicalizeErr pAddErr pIn1MulErr pIn2MulErr angleIn (angleUnlikeAddErr,angleUnlikeMulErr)) = cPointErr <> pointErr
+ (_, cPointErr) = canonicalizeP point
+-- | Wrapper.
+fuzzinessOfP p = fuzzinessOfProjectivePoint p
diff --git a/Graphics/Slicer/Math/RandomGeometry.hs b/Graphics/Slicer/Math/RandomGeometry.hs
new file mode 100644
index 000000000..67488e7b4
--- /dev/null
+++ b/Graphics/Slicer/Math/RandomGeometry.hs
@@ -0,0 +1,504 @@
+{- 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),
+ cellFrom,
+ edgesOf,
+ generationsOf,
+ onlyOne,
+ onlyOneOf,
+ randomConcaveChevronQuad,
+ randomConvexBisectableQuad,
+ randomConvexDualRightQuad,
+ randomConvexQuad,
+ randomConvexSingleRightQuad,
+ randomENode,
+ randomINode,
+ randomLineSeg,
+ randomLineSegFromOriginNotX1Y1,
+ randomLineSegFromPointNotX1Y1,
+ randomPLine,
+ randomPLineThroughOrigin,
+ randomPLineThroughPoint,
+ randomPLineWithErr,
+ randomRectangle,
+ randomSquare,
+ randomTriangle,
+ randomX1Y1LineSegToOrigin,
+ randomX1Y1LineSegToPoint,
+ remainderFrom
+ ) where
+
+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)
+
+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, mostPerpPointAndLineSeg)
+
+import Graphics.Slicer.Math.Definitions (Contour, Point2(Point2), LineSeg(startPoint, endPoint), makeLineSeg, pointBetweenPoints)
+
+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, cPPointOf)
+
+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.
+-- 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
+ 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) -> 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
+ outsidePLine = fst $ join2EP myMidPoint outsidePoint
+ 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
+ where
+ 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)
+ 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 bisector)
+ where
+ r1 = rawR1 / 2
+ r2 = r1 + (rawR2 / 2)
+ (pl1, pl1Err) = eToPL $ getFirstLineSeg eNode
+ (pl2, pl2Err) = (flipL ls, lsErr)
+ where
+ (ls, lsErr) = eToPL $ getLastLineSeg 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)
+ maybeFlippedpl1 = (if flipIn1 then flipL pl1 else pl1, pl1Err)
+ maybeFlippedpl2 = (if flipIn2 then flipL pl2 else pl2, pl2Err)
+ bisector = getOutsideArc (pp1, mempty) maybeFlippedpl1 (pp2, mempty) 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 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/Skeleton/Cells.hs b/Graphics/Slicer/Math/Skeleton/Cells.hs
index 49adbea36..bec823dbc 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)
import Data.Either(Either(Left, Right))
@@ -52,13 +52,13 @@ 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)
+import Graphics.Slicer.Math.Intersections (intersectionBetweenArcsOf, isAntiCollinear, outputIntersectsPLineAt)
-import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, eToCPPoint2, eToNPLine2, eToPLine2, eToPPoint2, join2PPoint2, normalizePLine2)
+import Graphics.Slicer.Math.Lossy (distanceBetweenPPoints, distanceBetweenPPointsWithErr, eToPLine2, 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), CPPoint2, Pointable(canPoint, ePointOf, cPPointOf), distance2PP, eToPL, eToPP, join2PP, oppositeDirection, outAndErrOf, cPPointAndErrOf)
data UnsupportedReason = INodeCrossesDivide ![(INode,CellDivide)] !NodeTree
deriving (Show, Eq)
@@ -109,11 +109,8 @@ 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
- where
- (angleFound, UlpSum angleErr) = angleBetweenWithErr (normalizePLine2 $ outOf m) (eToNPLine2 $ lineSegToIntersection m)
- lineSegToIntersection m = makeLineSeg (ePointOf m) (cPToEPoint2 intersectionPPoint)
- intersectionPPoint = intersectionOf (outOf firstMC) (outOf secondMC)
+ 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
-- | find where the last motorcycle of a divide lands
@@ -125,20 +122,16 @@ 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
- motorcycleENodeDistance = distanceBetweenPPoints cMotorcyclePoint cNodePoint
- motorcycleLineSegDistance = distanceBetweenPPoints cMotorcyclePoint $ justIntersectsIn $ plinesIntersectIn (outOf myMotorcycle) (eToPLine2 $ fst $ motorcycleIntersectsAt myContour myMotorcycle)
+ 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."
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]
- opposingNodes c m = filter (\eNode -> plinesIntersectIn (outOf eNode) (outOf 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])
@@ -166,7 +159,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
@@ -190,12 +183,12 @@ 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 -> 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) = 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
@@ -273,7 +266,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 +323,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 +344,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,10 +360,10 @@ 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 $ (\(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.
@@ -405,7 +398,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) (outOf m) == plinesIntersectIn (finalPLine nt2) (outOf m)
+ (DividingMotorcycles m (Slist _ 0)) -> d < 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.
@@ -414,12 +411,12 @@ 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 = eToPPoint2 $ 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
| 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 cac354479..ea2f54b53 100644
--- a/Graphics/Slicer/Math/Skeleton/Concave.hs
+++ b/Graphics/Slicer/Math/Skeleton/Concave.hs
@@ -26,20 +26,16 @@
-- 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, (.), (<=), (-), (/), 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)
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), 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))
@@ -50,19 +46,21 @@ import Slist as SL (head, last, tail)
import Graphics.Implicit.Definitions (ℝ)
+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, distance)
+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, intersectionBetween, isCollinear, isParallel, isAntiCollinear, noIntersection)
+import Graphics.Slicer.Math.Intersections (intersectionOf, intersectionBetweenArcsOf, intersectionsAtSamePoint, isAntiCollinear, isAntiParallel, isCollinear, isParallel, noIntersection)
-import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, distanceBetweenPPoints, distancePPointToPLine, eToPLine2, getInsideArc, join2CPPoint2, normalizePLine2)
+import Graphics.Slicer.Math.Lossy (distanceBetweenPPointsWithErr)
-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(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, 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)
@@ -103,21 +101,23 @@ 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
- [] -> INodeSet $ slist [[makeINode [getInsideArc (flipPLine2 $ eToPLine2 firstSeg) (eToPLine2 lastSeg), getInsideArc (eToPLine2 firstSeg) (flipPLine2 $ eToPLine2 lastSeg)] Nothing]]
+ [] -> INodeSet $ slist [[makeINode [getInsideArc firstLineFlipped lastLine, getInsideArc firstLine lastLineFlipped] 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)]]
+ 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"
@@ -137,7 +137,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.
@@ -163,70 +163,22 @@ 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.
-averageNodes :: (Arcable a, Pointable a, Show a, Arcable b, Pointable b, Show 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 (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
- | 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) = distanceBetweenPPointsWithErr (intersectionOf (outOf n1) (outOf n2)) (canonicalizePPoint2 $ pPointOf n1)
- (n2Distance, UlpSum n2Err) = distanceBetweenPPointsWithErr (intersectionOf (outOf n1) (outOf n2)) (canonicalizePPoint2 $ pPointOf n2)
- dumpInput = "Node1: " <> show n1
- <> "\nNode2: " <> show n2
- <> "\nNode1Out: " <> show (outOf n1)
- <> "\nNode2Out: "<> show (outOf n2)
- <> "\nNode1PPoint: " <> show (pPointOf n1)
- <> "\nNode2PPoint: " <> show (pPointOf n2) <> "\n"
+-- | 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 (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]
-sortedPair n1 n2 = sortedPLines [outOf n1, outOf 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 :: 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
- | l2TowardPoint = getInsideArc pline1 pline2
- | otherwise = getInsideArc pline1 (flipPLine2 pline2)
- where
- pline1 = (\(NPLine2 v) -> PLine2 v) npline1
- pline2 = (\(NPLine2 v) -> PLine2 v) npline2
- intersectionPoint = intersectionOf pline1 pline2
- 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.
--- FIXME: shouldn't we be given an error component in our inputs?
-towardIntersection :: PPoint2 -> 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
+sortedPair :: (Arcable a, Arcable b) => a -> b -> [(PLine2, PLine2Err)]
+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
-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
+ (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]
@@ -239,7 +191,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)
@@ -260,10 +212,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 (outOf node1) (outOf 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.
@@ -275,17 +226,17 @@ 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]
+ maybePLineOut :: INode -> [(PLine2,PLine2Err)]
maybePLineOut myINode = if hasArc myINode
- then [outOf myINode]
+ then [outAndErrOf 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]
| otherwise = -- must be an INode. recurse.
@@ -294,8 +245,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 -> outOf a == myPLine) newLastGen of
+ lastGenWithOnlyMyINode = case filter (\a -> hasArc a && outAndErrOf a == myPLine) newLastGen of
[] -> []
a -> [[first a]]
where
@@ -305,7 +257,7 @@ findENodesInOrder eNodeSet@(ENodeSet (Slist [(_,_)] _)) generations = findENodes
where
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"
@@ -420,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
@@ -469,10 +421,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 inode2 = hasArc inode1 && hasIn inode2 (outAndErrOf inode1)
where
- hasIn :: INode -> PLine2 -> Bool
- hasIn iNode pLine2 = case filter (==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."
@@ -493,12 +445,12 @@ 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 $ 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
+ 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.
@@ -518,7 +470,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
@@ -535,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
@@ -555,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
@@ -566,20 +518,21 @@ 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 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] -> [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 (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.
-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.
@@ -597,7 +550,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 [makeINode [outAndErrOf eNode, outAndErrOf eNode] Nothing]
[iNode] -> handleTwoNodes eNode iNode
(_:_) -> handleThreeOrMoreNodes
[eNode1,eNode2] -> case iNodes of
@@ -610,80 +563,63 @@ 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"
+ | 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.
- Right $ INodeSet $ one [makeINode (sortedPLines [outOf node1,outOf node2]) Nothing]
- | intersectsInPoint node1 node2 = Right $ INodeSet $ one [averageNodes 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]
+ | 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
- | endsAtSamePoint && contourLooped = Right $ INodeSet $ one [makeINode (sortedPLines $ (outOf <$> eNodes) <> (outOf <$> iNodes)) Nothing]
+ | 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 (sortedPLines $ (outOf <$> eNodes) <> (outOf <$> iNodes)) Nothing]
- | hasShortestNeighboringPair = Right $ INodeSet $ averageOfShortestPairs `cons` inodesOf (errorIfLeft (skeletonOfNodes remainingLoop remainingLineSegs (remainingINodes <> averageOfShortestPairs)))
- | otherwise = errorLen3
+ | 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 = 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 averageNodes <$> shortestPairs eNodes) <> "\n"
<> show (isSomething shortestEPairDistance) <> "\n"
<> "iPairDistance: " <> show shortestIPairDistance <> "\n"
<> "shortestIPairs: " <> show (shortestPairs iNodes) <> "\n"
- <> "iPairResults: " <> show (uncurry averageNodes <$> shortestPairs iNodes) <> "\n"
<> show (isSomething shortestIPairDistance) <> "\n"
<> "mixedPairDistance: " <> show shortestMixedPairDistance <> "\n"
<> "shortestMixedPairs: " <> show shortestMixedPairs <> "\n"
- <> "MixedPairResults: " <> show (uncurry averageNodes <$> 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"
- -- | 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
- | and $ isJust <$> intersections = and $ pointsCloseEnough <> linesCloseEnough
- | otherwise = False
+ endsAtSamePoint = intersectionsAtSamePoint nodeOutsAndErrs
where
- intersections = mapWithFollower intersectionBetween ((outOf <$> nonAntiCollinearNodes eNodes (antiCollinearNodePairsOf eNodes) <> firstAntiCollinearNodes (antiCollinearNodePairsOf eNodes)) <>
- (outOf <$> nonAntiCollinearNodes iNodes (antiCollinearNodePairsOf iNodes) <> firstAntiCollinearNodes (antiCollinearNodePairsOf iNodes)))
- pointIntersections = rights $ catMaybes intersections
- lineIntersections = lefts $ catMaybes intersections
- pointsCloseEnough = mapWithFollower pairCloseEnough pointIntersections
+ nodeOutsAndErrs = nonAntiCollinearOutErrPairs allOuts (antiCollinearOutErrPairsOf allOuts)
+ <> firstofAntiCollinearOutErrPairs (antiCollinearOutErrPairsOf allOuts)
where
- pairCloseEnough a b = res < realToFrac errRes
- where
- (res, UlpSum errRes) = distanceBetweenPPointsWithErr 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 ((\(CPPoint2 v) -> PPoint2 v) x) a
- (_:_) -> error
- $ "detected multiple lines?\n"
- <> show lineIntersections <> "\n"
- <> show pointIntersections <> "\n"
+ 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 :: (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.
hasShortestNeighboringPair :: Bool
@@ -705,15 +641,14 @@ 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
+ mapMaybe isTooShort $ case eNodesIn of
+ (Slist [] _) -> [lineSegs]
+ (Slist (oneENode:moreENodes) _) -> concatMap (removeENodeFromSegList oneENode) $ removeENodesFromSegList (slist moreENodes) lineSegs
where
- filterTooShorts sets = catMaybes $ isTooShort <$> sets
isTooShort set = case set of
[] -> Nothing
[val] -> Just [val]
@@ -741,7 +676,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
@@ -750,21 +685,25 @@ skeletonOfNodes connectedLoop inSegSets iNodes =
mixedPairsFound =
if isSomething shortestMixedPairDistance && shortestMixedPairDistance == shortestPairDistance
- then filterINodesOf shortestMixedPairs
+ then removeFoundINodesOf 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)))
+ -- | Filter out any node pairs in our list that contain an INode from the iPairsFound list.
+ removeFoundINodesOf :: [(ENode, INode)] -> [(ENode, INode)]
+ removeFoundINodesOf = filter withoutINodes
+ where
+ 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 node 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)
@@ -779,14 +718,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]
+ [(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.
- 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
@@ -794,15 +733,34 @@ 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 :: (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" <> 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 <= 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 intersectionPoint (cPPointAndErrOf n1)
+ (n2Distance, (_,_, n2Err)) = distance2PP intersectionPoint (cPPointAndErrOf n2)
+
-- | 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
@@ -828,41 +786,39 @@ 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 = filter (uncurry intersectsInPoint) $ 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, Show a) => [a] -> [(a, a)]
- intersectingNodePairsOf inNodes = catMaybes $ (\(node1, node2) -> if intersectsInPoint node1 node2 then Just (node1, node2) else Nothing) <$> getPairs inNodes
+ intersectingNodePairsOf :: (Arcable a, Pointable a) => [a] -> [(a, a)]
+ 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, Show 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.
- 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
+ intersectingNeighboringNodePairsOf :: (Arcable a, Pointable a) => [(a,a)] -> [(a, a)]
+ 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, 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
+ && hasArc node1
+ && hasArc node2
&& intersectsInPoint node1 node2 =
- Just $ distanceBetweenPPoints (canonicalizePPoint2 $ pPointOf node1) (intersectionOf (outOf node1) (outOf node2))
+ Just $ distanceBetweenPPointsWithErr (cPPointAndErrOf node1) (intersectionOf (outAndErrOf node1) (outAndErrOf node2))
`max`
- distanceBetweenPPoints (canonicalizePPoint2 $ pPointOf node2) (intersectionOf (outOf node1) (outOf 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, 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)
- && (dist2 >= realToFrac dist2Err)
+ | hasArc node1 && hasArc node2 = not (noIntersection (outAndErrOf node1) (outAndErrOf node2))
+ && 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, UlpSum dist1Err) = distanceBetweenPPointsWithErr (intersectionOf (outOf node1) (outOf node2)) (canonicalizePPoint2 $ pPointOf node1)
- (dist2, UlpSum dist2Err) = distanceBetweenPPointsWithErr (intersectionOf (outOf node1) (outOf node2)) (canonicalizePPoint2 $ pPointOf 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 3f9f28acd..f06f7df74 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:
+ To 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
-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
-
-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), ($), (<$>), (==), (/=), (||), (<>), (<), (*), (&&), any, error, fst, mempty, not, otherwise, show, snd)
import Prelude as PL (head, last)
@@ -43,101 +41,117 @@ 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)
+import Slist (isEmpty, safeLast, slist)
import Slist as SL (last, head, init)
import Slist.Type (Slist(Slist))
-import Graphics.Implicit.Definitions (ℝ)
+import Graphics.Slicer.Math.Definitions (Contour, LineSeg(LineSeg), Point2, distance, endPoint, fudgeFactor, lineSegsOfContour, makeLineSeg, mapWithFollower, startPoint)
-import Graphics.Slicer.Math.Lossy (eToPLine2, eToPPoint2, canonicalizePPoint2)
+import Graphics.Slicer.Math.GeometricAlgebra (addVecPair)
-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.Intersections (intersectionsAtSamePoint, noIntersection)
-import Graphics.Slicer.Math.Definitions (Contour, LineSeg(LineSeg), Point2, mapWithFollower, fudgeFactor, startPoint, distance, endPoint, lineSegsOfContour, makeLineSeg)
+import Graphics.Slicer.Math.Lossy (eToPLine2)
-import Graphics.Slicer.Math.GeometricAlgebra (UlpSum(UlpSum), addVecPair)
+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.
--- FIXME: provide our own Eq instance, cause floats suck? :)
-data ENode = ENode { _inPoints :: !(Point2, Point2, Point2), _arcOut :: !PLine2, _arcULP :: UlpSum, _arcUlpMag :: ℝ}
- deriving Eq
+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, 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
deriving stock Show
+-- | 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
- -- an ENode always has an arc.
+ errOfOut (ENode _ _ outErr) = outErr
hasArc _ = True
- outOf (ENode _ outArc _ _) = outArc
- ulpOfOut (ENode _ _ outUlp _) = outUlp
- outUlpMag (ENode _ _ _ ulpMag) = ulpMag
+ outOf (ENode _ outArc _) = outArc
+-- | An ENode is always resolvable to a point.
instance Pointable ENode where
- -- an ENode always contains a point.
canPoint _ = True
- pPointOf a = eToPPoint2 $ ePointOf a
- 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) }
- deriving Eq
+ cPPointOf a = eToPP $ ePointOf a
+ ePointOf (ENode (_,centerPoint,_) _ _) = centerPoint
+ errOfCPPoint _ = mempty
+
+-- | A point in our straight skeleton where arcs intersect, resulting in the creation of another arc.
+data INode = INode
+ -- 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)
+ -- The second input arc.
+ !(PLine2, PLine2Err)
+ -- More input arcs.
+ !(Slist (PLine2, PLine2Err))
+ -- 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.
+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."
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."
- 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."
+-- | 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@(INode firstPLine secondPLine morePLines _) = len allPLines > 1 && hasIntersectingPairs allPLines
- where
- allPLines = if hasArc iNode
- then cons (outOf 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
- -- 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 _) _)
- | allPointsSame = case results of
- [] -> error $ "cannot get a PPoint of this iNode: " <> show iNode <> "/n"
- [a] -> a
- (a:_) -> a
- -- 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
+ canPoint iNode = hasIntersectingPairs (allPLinesOfINode iNode)
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) = distanceBetweenPPointsWithErr (canonicalizePPoint2 a) (canonicalizePPoint2 b)
- allPLines = if hasArc iNode
- then slist $ nub $ outOf iNode : firstPLine : secondPLine : rawPLines
- else slist $ nub $ firstPLine : secondPLine : rawPLines
- intersectionsOfPairs (Slist pLines _) = catMaybes $ (\(pl1, pl2) -> saneIntersect $ plinesIntersectIn pl1 pl2) <$> getPairs pLines
- where
- saneIntersect (IntersectsIn a _) = Just $ (\(CPPoint2 v) -> PPoint2 v) a
- saneIntersect _ = Nothing
- ePointOf a = pToEPoint2 $ pPointOf a
-
--- Produce a list of the inputs to a given INode.
-insOf :: INode -> [PLine2]
+ 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 $ cPPointOf 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
+
+-- | 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
lastINodeOf :: INodeSet -> INode
@@ -148,39 +162,49 @@ 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 :: ℝ }
- deriving Eq
+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 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
+
+-- | A Motorcycle always has an arc, which is it's path.
instance Arcable Motorcycle where
- -- A Motorcycle always has an arc, which is it's path.
+ errOfOut (Motorcycle _ _ outErr) = outErr
hasArc _ = True
- outOf (Motorcycle _ outArc _ _) = outArc
- ulpOfOut (Motorcycle _ _ outUlp _) = outUlp
- outUlpMag (Motorcycle _ _ _ outMag) = outMag
+ outOf (Motorcycle _ outArc _) = outArc
+-- | A motorcycle always contains a point.
instance Pointable Motorcycle where
- -- A motorcycle always contains a point.
canPoint _ = True
- pPointOf a = eToPPoint2 $ ePointOf a
- ePointOf (Motorcycle (_, LineSeg point _) _ _ _) = point
+ cPPointOf a = eToPP $ ePointOf a
+ ePointOf (Motorcycle (_, LineSeg point _) _ _) = point
+ errOfCPPoint _ = mempty
-- | The motorcycles that are involved in dividing two cells.
data DividingMotorcycles = DividingMotorcycles { firstMotorcycle :: !Motorcycle, moreMotorcycles :: !(Slist 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 Eq
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
@@ -188,17 +212,15 @@ 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]))
- 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) }
+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.
@@ -209,18 +231,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.
@@ -232,7 +256,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
@@ -242,15 +266,15 @@ 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
+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
+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?
@@ -263,27 +287,27 @@ 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"
+ [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
-- | 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
+ | 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) = outOf $ 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
+ | 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
@@ -292,7 +316,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."
@@ -305,7 +329,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."
@@ -313,16 +337,16 @@ 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 (eToPLine2 seg1) (eToPLine2 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
- (PLine2 pv2) = flipPLine2 $ eToPLine2 seg2
+ (PLine2 pv2) = flipL $ eToPLine2 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
@@ -330,22 +354,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 `pLineIsLeft` n2) == 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)
--- | 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]
+-- | 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` a /= Just False)
- pLinesAfterIndex myFirstPLine = filter (\a -> myFirstPLine `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
+-- | Find the last PLine of an INode.
+lastInOf :: INode -> (PLine2, PLine2Err)
lastInOf (INode _ secondPLine morePLines _)
- | len morePLines == 0 = secondPLine
- | otherwise = SL.last morePLines
+ | isEmpty morePLines = secondPLine
+ | otherwise = SL.last morePLines
--- | find the first PLine of an INode.
-firstInOf :: INode -> PLine2
+-- | Find the first PLine of an INode.
+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 f2dc7b8db..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 ((==), 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, 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."
@@ -130,7 +130,7 @@ 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.
+ -- Make a list of the PLines of an INode's input arcs.
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.
@@ -145,44 +145,41 @@ 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 = sortedPLines $ 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 = 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
+ <> 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)
+ <> 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
@@ -201,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"
@@ -219,57 +216,57 @@ intraNodeFace nodeTree1 nodeTree2
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/Line.hs b/Graphics/Slicer/Math/Skeleton/Line.hs
index 2b46ab6a8..31e9fd0d8 100644
--- a/Graphics/Slicer/Math/Skeleton/Line.hs
+++ b/Graphics/Slicer/Math/Skeleton/Line.hs
@@ -22,11 +22,11 @@
-- | 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)
-import Data.Maybe (Maybe(Just,Nothing), catMaybes, fromMaybe)
+import Data.Maybe (Maybe(Just,Nothing), fromMaybe, mapMaybe)
import Safe (lastMay, initSafe)
@@ -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 (distancePPointToPLineWithErr, eToPLine2, pToEPoint2)
-import Graphics.Slicer.Math.PGA (PLine2, cPToEPoint2, pLineIsLeft)
+import Graphics.Slicer.Math.PGA (PLine2, eToPL, pLineIsLeft, translateL)
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 (fst $ eToPL edge) firstArc of
(Just True) -> (-v)
(Just False) -> v
Nothing -> error "cannot happen: edge and firstArc are the same line?"
@@ -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 (cPToEPoint2 $ intersectionOf newSide firstArc) (cPToEPoint2 $ intersectionOf newSide lastArc) | 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 (cPToEPoint2 $ intersectionOf finalLine firstArc) (cPToEPoint2 $ intersectionOf finalLine lastArc)
+ 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) -> distanceCPPointToNPLine (intersectionOf firstArc lastArc) (eToNPLine2 edge)
+ (Slist [] 0) -> distancePPointToPLineWithErr (intersectionOf (firstArc, mempty) (lastArc, mempty)) (eToPL edge)
(Slist [oneArc] 1) -> if firstArcLonger
- then distanceCPPointToNPLine (intersectionOf firstArc oneArc) (eToNPLine2 edge)
- else distanceCPPointToNPLine (intersectionOf oneArc lastArc) (eToNPLine2 edge)
+ then distancePPointToPLineWithErr (intersectionOf (firstArc, mempty) (oneArc, mempty)) (eToPL edge)
+ else distancePPointToPLineWithErr (intersectionOf (oneArc, mempty) (lastArc, mempty)) (eToPL 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 -> (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 distanceCPPointToNPLine (intersectionOf firstArc midArc) (eToNPLine2 edge) /= distanceCPPointToNPLine (intersectionOf midArc lastArc) (eToNPLine2 edge)
+ 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 = distanceCPPointToNPLine (intersectionOf firstArc midArc) (eToNPLine2 edge) > distanceCPPointToNPLine (intersectionOf midArc lastArc) (eToNPLine2 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.
----------------------------------------------
@@ -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 db328e5a0..264c5f3f6 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, notElem, null, otherwise, realToFrac, 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)
-import Data.Maybe( Maybe(Just,Nothing), catMaybes, fromMaybe)
+import Data.Maybe( Maybe(Just,Nothing), fromMaybe, mapMaybe)
import Data.List (sortBy)
@@ -42,19 +42,21 @@ import Slist.Type (Slist(Slist))
import Graphics.Slicer.Definitions (ℝ)
-import Graphics.Slicer.Math.Contour (pointsOfContour)
+import Graphics.Slicer.Math.Arcs (getInsideArc)
-import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, distance, mapWithNeighbors, startPoint, endPoint, makeLineSeg)
+import Graphics.Slicer.Math.ContourIntersections (getMotorcycleContourIntersections, getMotorcycleSegSetIntersections)
-import Graphics.Slicer.Math.Intersections (getMotorcycleSegSetIntersections, getMotorcycleContourIntersections, intersectionOf, isAntiCollinear, noIntersection)
+import Graphics.Slicer.Math.Definitions (Contour, LineSeg, Point2, mapWithNeighbors, startPoint, endPoint, makeLineSeg, pointsOfContour)
-import Graphics.Slicer.Math.Lossy (canonicalizePPoint2, pPointBetweenPPoints, distanceBetweenPPoints, eToNPLine2, eToCPPoint2, eToPLine2, normalizePLine2, pLineFromEndpoints, translatePLine2)
+import Graphics.Slicer.Math.Intersections (intersectionOf, isAntiCollinear, noIntersection, outputIntersectsLineSeg, outputIntersectsPLineAt)
-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.Lossy (pPointBetweenPPoints, distanceBetweenPPoints, distanceBetweenPPointsWithErr, eToPLine2, join2PPoint2, pToEPoint2)
-import Graphics.Slicer.Math.Skeleton.Definitions (Motorcycle(Motorcycle), ENode(ENode), getFirstLineSeg, linePairs, CellDivide(CellDivide), DividingMotorcycles(DividingMotorcycles), MotorcycleIntersection(WithLineSeg, WithENode, WithMotorcycle))
+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.GeometricAlgebra (addVecPair, UlpSum(UlpSum))
+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 (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 }
@@ -75,26 +77,29 @@ 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
-motorcycleDivisor motorcycle target = pPointBetweenPPoints (canonicalizePPoint2 $ pPointOf motorcycle) pointOfTarget (tSpeedOf target) (mSpeedOf motorcycle)
+motorcycleDivisor motorcycle target = pPointBetweenPPoints (cPPointOf motorcycle) (fst pointOfTarget) (tSpeedOf target) (mSpeedOf motorcycle)
where
- pointOfTarget :: CPPoint2
pointOfTarget = case target of
- (WithLineSeg lineSeg) -> case outputIntersectsLineSeg motorcycle (lineSeg, ulpOfLineSeg lineSeg) of
- (Right (IntersectsIn p _)) -> p
+ (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) -> canonicalizePPoint2 $ pPointOf eNode
- (WithMotorcycle motorcycle2) -> canonicalizePPoint2 $ pPointOf motorcycle2
+ (WithENode eNode) -> (cPPointAndErrOf eNode)
+ (WithMotorcycle motorcycle2) -> (cPPointAndErrOf 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) -> 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 (canonicalizePPoint2 $ pPointOf myMotorcycle) (justIntersectsIn $ plinesIntersectIn (translatePLine2 (eToPLine2 seg1) 1) (outOf 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
@@ -140,64 +145,52 @@ 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
+ | 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
-- 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 (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
_ -> Nothing
where
- intersectionPPoint = intersectionOf (outOf mot1) (outOf mot2)
- intersectionIsBehind m = angleFound < realToFrac angleErr
- where
- (angleFound, UlpSum angleErr) = angleBetweenWithErr (normalizePLine2 $ outOf m) (eToNPLine2 $ lineSegToIntersection m)
- lineSegToIntersection m = makeLineSeg (ePointOf m) (cPToEPoint2 intersectionPPoint)
+ intersectionPPoint = intersectionOf (outAndErrOf mot1) (outAndErrOf mot2)
+ 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.
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, 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
+ pl1 = fst $ eToPL $ makeLineSeg p1 p2
+ pl2 = fst $ eToPL $ makeLineSeg p2 p3
--- | generate the un-normalized PLine2 of a motorcycle created by the three points given.
-motorcycleFromPoints :: Point2 -> Point2 -> Point2 -> PLine2
-motorcycleFromPoints p1 p2 p3 = getOutsideArc (pLineFromEndpoints p1 p2) (pLineFromEndpoints p2 p3)
+-- | generate the PLine2 of a motorcycle created by the three points given.
+motorcycleFromPoints :: Point2 -> Point2 -> Point2 -> (PLine2, PLine2Err)
+motorcycleFromPoints p1 p2 p3 = (flipL res, resErr)
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 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 = flipPLine2 $ PLine2 $ addVecPair flippedNPV1 npv2
+ (res, resErr) = getInsideArc firstLine secondLine
where
- (PLine2 flippedNPV1) = flipPLine2 $ (\(NPLine2 a) -> PLine2 a) $ normalizePLine2 pline1
- (NPLine2 npv2) = normalizePLine2 pline2
+ 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.
@@ -226,23 +219,23 @@ 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
+ motorcyclePoint = cPPointOf motorcycle
compareDistances i1 i2 = case i1 of
(_, Right intersectionPPoint1) ->
case i2 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)
filterIntersection :: (LineSeg, Either Point2 CPPoint2) -> Maybe (LineSeg, Either Point2 CPPoint2)
filterIntersection intersection = case intersection of
(_, Right intersectionCPPoint) -> if intersectionCPPointIsBehind intersectionCPPoint
@@ -252,14 +245,8 @@ motorcycleMightIntersectWith lineSegs motorcycle
then Nothing
else Just intersection
where
- intersectionPointIsBehind point = angleFound < realToFrac angleErr
- where
- (angleFound, UlpSum angleErr) = angleBetweenWithErr (normalizePLine2 $ outOf motorcycle) (eToNPLine2 $ lineSegToIntersection point)
- intersectionCPPointIsBehind pPoint = angleFound < realToFrac angleErr
- where
- (angleFound, UlpSum angleErr) = angleBetweenWithErr (normalizePLine2 $ outOf motorcycle) (eToNPLine2 $ lineSegToIntersectionP pPoint)
- lineSegToIntersection myPoint = makeLineSeg (ePointOf motorcycle) myPoint
- lineSegToIntersectionP myPPoint = makeLineSeg (ePointOf motorcycle) (cPToEPoint2 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.
@@ -270,7 +257,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) ->
@@ -278,13 +265,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
@@ -295,28 +282,24 @@ motorcycleIntersectsAt contour motorcycle = case intersections of
then Nothing
else Just intersection
where
- intersectionPointIsBehind point = angleFound < realToFrac angleErr
- where
- (angleFound, UlpSum angleErr) = angleBetweenWithErr (normalizePLine2 $ outOf motorcycle) (eToNPLine2 $ lineSegToIntersection point)
- intersectionPPointIsBehind pPoint = angleFound < realToFrac angleErr
- where
- (angleFound, UlpSum angleErr) = angleBetweenWithErr (normalizePLine2 $ outOf motorcycle) (eToNPLine2 $ lineSegToIntersectionP pPoint)
- lineSegToIntersection myPoint = makeLineSeg (ePointOf motorcycle) myPoint
- lineSegToIntersectionP myPPoint = makeLineSeg (ePointOf motorcycle) (cPToEPoint2 myPPoint)
- motorcyclePoint = canonicalizePPoint2 $ pPointOf motorcycle
+ 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
-- | 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
+{-# INLINABLE intersectionSameSide #-}
+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 (cPPointOf node) pp1 path
| otherwise = error $ "cannot resolve provided item to a point: " <> show node <> "\n"
-
+ where
+ (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 (outOf motorcycle1) (outOf motorcycle2) == PAntiCollinear
+motorcyclesAreAntiCollinear motorcycle1 motorcycle2 = plinesIntersectIn (outAndErrOf motorcycle1) (outAndErrOf motorcycle2) == PAntiCollinear
-- | Return the total set of motorcycles in the given CellDivide
motorcyclesInDivision :: CellDivide -> [Motorcycle]
diff --git a/Graphics/Slicer/Math/Skeleton/NodeTrees.hs b/Graphics/Slicer/Math/Skeleton/NodeTrees.hs
index 8cac1a028..9e8b74f98 100644
--- a/Graphics/Slicer/Math/Skeleton/NodeTrees.hs
+++ b/Graphics/Slicer/Math/Skeleton/NodeTrees.hs
@@ -31,9 +31,11 @@ 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.Intersections (isCollinear)
-import Graphics.Slicer.Math.PGA (PLine2, Arcable(hasArc, outOf))
+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, PLine2Err, Arcable(hasArc, outOf), outAndErrOf)
lastSegOf :: NodeTree -> LineSeg
lastSegOf nodeTree = getLastLineSeg $ lastENodeOf nodeTree
@@ -55,24 +57,23 @@ 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 [] _) -> error "looking for a first ENode in an empty ENodeSet."
- (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 = case direction of
Head -> firstPLine
@@ -81,7 +82,7 @@ pathTo (NodeTree eNodeSet@(ENodeSet eNodeSides) iNodeSet@(INodeSet generations))
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
@@ -97,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
@@ -108,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
@@ -131,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) -> a == Just 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
@@ -180,8 +181,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/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
diff --git a/hslice.cabal b/hslice.cabal
index 6fb2e55d4..907379242 100644
--- a/hslice.cabal
+++ b/hslice.cabal
@@ -26,8 +26,10 @@ 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.ContourIntersections
Graphics.Slicer.Math.Definitions
Graphics.Slicer.Math.Facet
Graphics.Slicer.Math.Ganja
@@ -36,6 +38,8 @@ library
Graphics.Slicer.Math.Lossy
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 9cd279214..49086e085 100644
--- a/tests/Math/PGA.hs
+++ b/tests/Math/PGA.hs
@@ -22,10 +22,16 @@
{-# LANGUAGE DataKinds #-}
+-- 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.
-import Prelude (($), Bool(True, False), (<$>), (==), (>=), error, (/=), (<=), mempty, otherwise, abs, (&&), (+), show, length, (<>), fst, not, length, realToFrac, sqrt, (<), (>), (-), (/), (||), (*))
+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)
@@ -35,34 +41,40 @@ 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 Numeric.Rounded.Hardware (Rounded, RoundingMode(TowardInf))
+import Data.Maybe (fromJust, fromMaybe, isNothing, Maybe(Just, Nothing))
import Data.Set (singleton, fromList)
+import Numeric.Rounded.Hardware (Rounded, RoundingMode(TowardInf))
+
import Slist (slist, len)
-- The numeric type in HSlice.
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, 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)
-import Graphics.Slicer.Math.Lossy (angleBetween, canonicalizePPoint2, distanceBetweenPPoints, distanceBetweenNPLine2s, distancePPointToPLine, eToCPPoint2, eToPLine2, eToPPoint2, getFirstArc, join2PPoint2, makeCPPoint2, makePPoint2, 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), 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), 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)
@@ -71,11 +83,13 @@ 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.Definitions (Motorcycle(Motorcycle), RemainingContour(RemainingContour), 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))
import Graphics.Slicer.Math.Skeleton.Skeleton (findStraightSkeleton)
@@ -83,11 +97,23 @@ 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 (dumpGanjas, toGanja)
+
+-- Our Geometry generation library. For random shaped geometry.
+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 (ℝ)
+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
@@ -328,7 +354,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) $ 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
@@ -337,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)" $
@@ -362,12 +397,14 @@ 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" $
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))]
@@ -376,16 +413,16 @@ 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) (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)) --> 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)) (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
prop_perpAt90Degrees x y rawX2 y2 rawD
- | angle2 < realToFrac errTotal4 = True
+ | angle2 < errTotal4 = True
| otherwise = error
$ "wrong angle?\n"
<> "pline3Err: " <> show pline3Err <> "\n"
@@ -399,18 +436,18 @@ prop_perpAt90Degrees x y rawX2 y2 rawD
<> "angle2: " <> show angle2 <> "\n"
<> "angle2Err: " <> show angle2Err <> "\n"
where
- (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
- (pline3, UlpSum pline3Err) = join2CPPoint2WithErr (CPPoint2 rawBisectorStart) bisectorEnd
- (normedPLine3, UlpSum norm3Err) = normalizePLine2WithErr pline3
- (sourceStart, PPoint2PosErr sourceStartErr) = makeCPPoint2WithErr x y
- (sourceEnd, PPoint2PosErr sourceEndErr) = makeCPPoint2WithErr x2 y2
- (pline4, UlpSum pline4Err) = join2CPPoint2WithErr sourceStart sourceEnd
- (normedPLine4, UlpSum norm4Err) = normalizePLine2WithErr pline4
- errTotal3 = angle2Err + norm3Err + pline3Err + pline4Err + norm4Err + bisectorStartErr + bisectorEndRawErr + bisectorEndErr + sourceStartErr + sourceEndErr
- errTotal4 = angle2Err + norm3Err + pline3Err + pline4Err + norm4Err + bisectorStartErr + bisectorEndRawErr + bisectorEndErr + sourceStartErr + sourceEndErr
+ (angle2, (_,_, angle2Err)) = angleBetween2PL normedPLine3 normedPLine4
+ (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 = makeCPPoint2 x y
+ sourceEnd = makeCPPoint2 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
x2 :: ℝ
x2 = coerce rawX2
d :: ℝ
@@ -419,18 +456,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
@@ -443,33 +480,28 @@ 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
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"
<> "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) = normalizePLine2WithErr resPLine
- (origNPLine, UlpSum origNErr) = normalizePLine2WithErr 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)
+ (res, (_,_, resErr)) = distance2PL resPLine origPLine
+ (resPLine, _) = translateL translatedPLine (-t)
+ (translatedPLine, _) = translateL origPLine t
+ (origPLine, _) = randomPLineWithErr x y dx dy
+ t :: ℝ
t = coerce rawT
pgaSpec :: Spec
@@ -489,7 +521,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
@@ -507,17 +539,17 @@ 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 (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, UlpSum bisectorUlp) = pLineFromEndpointsWithErr (Point2 (0,0)) (Point2 (x3,y3))
- (NPLine2 bisector1, UlpSum bisector1Ulp) = normalizePLine2WithErr bisector
- bisector1Err = bisectorUlp + bisector1Ulp
+ (bisector, bisectorRawErr) = eToPL $ makeLineSeg (Point2 (0,0)) (Point2 (x3,y3))
+ (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).
+ -- X1, Y1 and X2 forced uniqueness. additionally, forced "not 180 degree" opposition.
x1,y1,x2,y2 :: ℝ
x1
| coerce rawX1 == y1 = coerce rawX1 /2
@@ -533,8 +565,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
@@ -556,20 +588,17 @@ 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 bisector1Err <> "\n"
- <> show (ulpOfOut eNode) <> "\n"
+ <> show (angleBetween2PL (outOf eNode) bisector1) <> "\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 (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, UlpSum bisector1Ulp) = normalizePLine2WithErr bisector
- (bisector, UlpSum bisectorUlp) = pLineFromEndpointsWithErr (Point2 (0,0)) (Point2 (x3,y3))
- bisector1Err = bisectorUlp + bisector1Ulp
+ (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 :: ℝ
@@ -591,8 +620,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,13 +653,13 @@ 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,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 (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,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
+ (pLineThroughOriginNotX1Y1NotOther,_) = randomPLineThroughOrigin x2 y2
x1y1LineSegToOrigin = randomX1Y1LineSegToOrigin d1
lineSegFromOrigin = randomLineSegFromOriginNotX1Y1 x1 y1
isEndPoint (Left (HitEndPoint _)) = True
@@ -670,17 +699,17 @@ 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,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 (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, 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 (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, 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
+ (pLineThroughPointNotX1Y1NotOther,_) = randomPLineThroughPoint x2 y2 d2
x1y1LineSegToPoint = randomX1Y1LineSegToPoint d1 d2
lineSegFromPointNotX1Y1 = randomLineSegFromPointNotX1Y1 x1 y1 d2
isEndPoint (Left (HitEndPoint _)) = True
@@ -708,9 +737,9 @@ 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 + resErr >= 1.0-resErr = True
+ | realToFrac res + (ulpRaw resErr) >= 1.0-(ulpRaw resErr) = True
| otherwise = error
$ "angle wrong?\n"
<> show a <> "\n"
@@ -718,7 +747,7 @@ myAngleBetween a b
<> show res <> "\n"
<> show resErr <> "\n"
where
- (res, UlpSum resErr) = angleBetweenWithErr a b
+ (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.
@@ -746,16 +775,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
@@ -767,16 +796,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
@@ -789,24 +818,24 @@ 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 (
- 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))))
+ | 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 (
- 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))))
+ | 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 (
- 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))))
+ | 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 (
- 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))))
+ | 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`
NPLine2 (GVec [GVal 0.7071067811865475 (singleton (GEPlus 1)), GVal (-0.7071067811865475) (singleton (GEPlus 2))])
where
@@ -820,24 +849,24 @@ 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 (
- 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))))
+ | 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 (
- 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))))
+ | 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 (
- 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))))
+ | 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 (
- 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))))
+ | 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`
NPLine2 (GVec [GVal 0.3826834323650899 (singleton (GEPlus 1)), GVal (-0.9238795325112867) (singleton (GEPlus 2))])
where
@@ -849,16 +878,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
@@ -870,16 +899,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
@@ -891,16 +920,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
@@ -921,15 +950,14 @@ prop_TriangleNoDivides centerX centerY rawRadians rawDists = findDivisions trian
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,_) = 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
+ (myMidPoint,_) = interpolate2PP (eToPP p1) (eToPP p2) 0.5 0.5
+ 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
@@ -1187,22 +1215,22 @@ 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, PPoint2PosErr p1Err) = makeCPPoint2WithErr x y
- (p2, PPoint2PosErr p2Err) = makeCPPoint2WithErr (x + realToFrac p1Err) (y + realToFrac p1Err)
+ (res, (_,_,UlpSum resErr)) = distance2PP (p1,mempty) (p2,mempty)
+ p1 = makeCPPoint2 x y
+ p2 = makeCPPoint2 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)
@@ -1223,22 +1251,20 @@ 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"
+ <> "PLine1Err: " <> show pLineErr <> "\n"
<> "NPLine: " <> show nPLine <> "\n"
<> "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
- (pPoint1, PPoint2PosErr ulpSumP1) = makeCPPoint2WithErr x1 y1
- (pPoint2, PPoint2PosErr ulpSumP2) = makeCPPoint2WithErr x2 y2
- (nPLine, UlpSum nPLineErr) = normalizePLine2WithErr pLine
- (pLine, UlpSum ulpPLine) = pLineFromEndpointsWithErr (Point2 (x1,y1)) (Point2 (x2,y2))
- ulpTotal1 = ulpSumP1 + ulpPLine + distance1Err + nPLineErr
- ulpTotal2 = ulpSumP2 + ulpPLine + distance2Err + nPLineErr
+ (distance1, (_,_,_,_,_,UlpSum distance1Err)) = distancePPToPL (pPoint1, mempty) (nPLine, nPLineErr)
+ (distance2, (_,_,_,_,_,UlpSum distance2Err)) = distancePPToPL (pPoint2, mempty) (nPLine, nPLineErr)
+ pPoint1 = makeCPPoint2 x1 y1
+ pPoint2 = makeCPPoint2 x2 y2
+ (nPLine, nPLineErr) = normalizeL pLine
+ (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
@@ -1248,8 +1274,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 > 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"
@@ -1258,23 +1284,20 @@ 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"
- <> "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, 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
- ulpTotal1 = ulpSumP1 + ulpPLine + distance1Err
- ulpTotal2 = ulpSumP2 + ulpPLine + distance2Err
+ (distance1, (_,_,_,_,_,distance1Err)) = distancePPToPL (pPoint1, mempty) (pLine1, pLine1Err)
+ (distance2, (_,_,_,_,_,distance2Err)) = distancePPToPL (pPoint2, mempty) (pLine1, pLine1Err)
+ 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
-- make sure we do not try to create a 0 length line segment.
(x2,y2)
| x1 == rawX2 && y1 == rawY2 = if x1 == 0 && y1 == 0
@@ -1293,21 +1316,18 @@ prop_PPointOnPerpWithinErrRange x1 y1 rawX2 rawY2 rawD
<> "distance1: " <> show res1 <> "\n"
<> "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.
- (res1,UlpSum res1Err) = distancePPointToPLineWithErr perp1 pLine
- (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
- (pLine, UlpSum ulpPLine) = join2CPPoint2WithErr (CPPoint2 pPoint1) (CPPoint2 pPoint2)
- ulpTotal1 = ulpSumP1 + ulpPLine + res1Err + ulpSumPerp1
- ulpTotal2 = ulpSumP2 + ulpPLine + res2Err + ulpSumPerp2
+ (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 = makeCPPoint2 x1 y1
+ pPoint2 = makeCPPoint2 x2 y2
+ (pLine, _) = join2PP pPoint1 pPoint2
+ ulpTotal1 = res1Err + ulpSumPerp1
+ ulpTotal2 = res2Err + ulpSumPerp2
d :: ℝ
d = coerce rawD
-- make sure we do not try to create a 0 length line segment.
@@ -1322,42 +1342,42 @@ prop_obtuseBisectorOnBiggerSide_makeENode x y d1 rawR1 d2 rawR2 testFirstLine
| testFirstLine = pLineIsLeft bisector pl1 --> Just True
| otherwise = pLineIsLeft pl2 bisector --> Just True
where
- pl1 = eToPLine2 $ getFirstLineSeg eNode
- pl2 = flipPLine2 $ eToPLine2 $ getLastLineSeg eNode
+ pl1 = fst $ eToPL $ getFirstLineSeg 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)
+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, UlpSum angleErr) = angleBetweenWithErr 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 = normalizePLine2 $ outOf iNode
- bisector2 = normalizePLine2 $ flipPLine2 $ 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
where
- l1TowardIntersection = towardIntersection (eToPPoint2 $ startPoint l1) pl1 eNodePoint
- (eNodePoint, _) = canonicalizePPoint2WithErr $ pPointOf eNode
+ l1TowardIntersection = towardIntersection (eToPP $ startPoint l1, mempty) pl1 eNodePoint
+ eNodePoint = cPPointAndErrOf 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 (eToPPoint2 $ endPoint l2) pl2 eNodePoint
- (eNodePoint, _) = canonicalizePPoint2WithErr $ pPointOf eNode
+ l2TowardIntersection = towardIntersection (eToPP $ endPoint l2, mempty) pl2 eNodePoint
+ eNodePoint = cPPointAndErrOf eNode
l2 = getLastLineSeg eNode
- pl2 = eToPLine2 l2
+ pl2 = eToPL l2
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 (fst $ translateRotatePPoint2WithErr pPoint d r) cPPoint /= 0 --> True
where
- pPoint = eToPPoint2 $ Point2 (x,y)
+ pPoint = eToPP $ Point2 (x,y)
cPPoint = makeCPPoint2 x y
r,d::ℝ
r = coerce rawR
@@ -1365,22 +1385,21 @@ prop_translateRotateMoves x y rawD rawR = distanceBetweenPPoints (canonicalizePP
-- |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)
+ fst ( normalizeL $ randomPLine x y dx dy)
prop_PLinesIntersectAtOrigin :: NonZero ℝ -> ℝ -> NonZero ℝ -> ℝ -> Bool
prop_PLinesIntersectAtOrigin rawX y rawX2 rawY2
- | foundDistance < realToFrac errSum = True
- | otherwise = error "wtf"
- where
- (originPPoint2, PPoint2PosErr originErr) = makeCPPoint2WithErr 0 0
- (foundDistance, UlpSum distanceErr) = distanceBetweenPPointsWithErr originPPoint2 intersectionCPPoint2
- (intersectionCPPoint2, UlpSum canonicalizationErr) = canonicalizePPoint2WithErr 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
+ | foundDistance <= ulpVal distanceErr = True
+ | otherwise = error $ "wtf"
+ <> show intersectionErr <> "\n"
+ where
+ originPPoint2 = makeCPPoint2 0 0
+ (foundDistance, (_,_,distanceErr)) = distance2PP (originPPoint2, mempty) (intersectionPPoint2, intersectionErr)
+ (intersectionPPoint2, (_,_,intersectionErr)) = intersect2PL randomPLine1 randomPLine2
+ (randomPLine1, _) = randomPLineThroughOrigin x y
+ (randomPLine2, _) = randomPLineThroughOrigin x2 y2
x,x2,y2 :: ℝ
x = coerce rawX
x2
@@ -1398,17 +1417,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, PPoint2PosErr targetErr) = makeCPPoint2WithErr (coerce targetX) (coerce targetY)
- (foundDistance, UlpSum distanceErr) = distanceBetweenPPointsWithErr targetPPoint2 intersectionCPPoint2
- (intersectionCPPoint2, UlpSum canonicalizationErr) = canonicalizePPoint2WithErr 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
+ <> show intersectionErr <> "\n"
+ where
+ (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
+ (randomPLine2, _) = randomPLineWithErr x2 y2 targetX targetY
+ errSum = distanceErr -- + canonicalizationErr
x,x2,y2 :: ℝ
x = coerce rawX
x2
@@ -1418,6 +1436,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 < 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)) = distance2PP (axisIntersectionPoint, mempty) (intersectionPPoint2, intersectionErr)
+ axisIntersectionErr = snd $ fromJust axisIntersection
+ axisIntersectionPoint = eToPP $ Point2 ((fromRight (error "not right?") $ fst $ fromJust axisIntersection), 0)
+ axisIntersection = xIntercept (randomPLine1, pline1Err)
+ (intersectionPPoint2, (_,_,intersectionErr)) = intersect2PL randomPLine1 axisPLine
+ (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))
+
+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 < 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)) = distance2PP (axisIntersectionPoint,mempty) (intersectionPPoint2, intersectionErr)
+ axisIntersectionErr = snd $ fromJust axisIntersection
+ axisIntersectionPoint = eToPP $ Point2 (0,(fromRight (error "not right?") $ fst $ fromJust axisIntersection))
+ axisIntersection = yIntercept (randomPLine1, pline1Err)
+ (intersectionPPoint2, (_,_,intersectionErr)) = intersect2PL randomPLine1 axisPLine
+ (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 :: ℝ
+ y2 = coerce rawY2
+
facetFlakeySpec :: Spec
facetFlakeySpec = do
describe "Stability (Points)" $ do
@@ -1459,6 +1534,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
@@ -1579,29 +1659,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 []) -->
@@ -1747,17 +1867,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:
@@ -1780,11 +1900,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
@@ -1792,7 +1912,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)]
diff --git a/tests/golden/C0-Cell1-NodeTree.ganja.js b/tests/golden/C0-Cell1-NodeTree.ganja.js
index 942a95888..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 adb = -0.3826834323650897e1-0.9238795325112867e2+0.541196100146197e0;
- var adc = -0.9807852804032305e1-0.19509032201612822e2+0.48706362218573185e0;
+ var ada = -1.0e1+1.0e2+0.0e0;
+ var adb = -0.7071067811865475e1-1.7071067811865475e2+1.0e0;
+ 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 5c6b6d674..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 aeb = -0.3826834323650897e1-0.9238795325112867e2+0.541196100146197e0;
- var aec = -0.9807852804032305e1-0.19509032201612822e2+0.48706362218573185e0;
- var afa = -0.9807852804032305e1-0.19509032201612822e2+0.48706362218573185e0;
+ var aea = -1.0e1+1.0e2+0.0e0;
+ var aeb = -0.7071067811865475e1-1.7071067811865475e2+1.0e0;
+ 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 8685410d8..379678c2a 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 adb = 0.7071067811865475e1+0.7071067811865475e2+0.0e0;
- var adc = 0.9807852804032305e1-0.19509032201612822e2-0.48706362218573185e0;
+ var ada = 0.7071067811865475e1-1.7071067811865475e2-1.0e0;
+ 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 fdc2be194..e969d21a5 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 aeb = 0.7071067811865475e1+0.7071067811865475e2+0.0e0;
- var aec = 0.9807852804032305e1-0.19509032201612822e2-0.48706362218573185e0;
+ var aea = 0.7071067811865475e1-1.7071067811865475e2-1.0e0;
+ 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 = 0.9807852804032305e1-0.19509032201612822e2-0.48706362218573185e0;
+ 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 5d876db80..8bf69423d 100644
--- a/tests/golden/C0-Faces-Default.ganja.js
+++ b/tests/golden/C0-Faces-Default.ganja.js
@@ -13,18 +13,18 @@ Algebra(2,0,1,()=>{
var aeb = point(-1.0,1.0);
var af = 0.0e1-1.414213562373095e2+0.0e0;
var ag = -0.4142135623730951e1-0.17157287525381e2+0.24264068711928521e0;
- 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 ah = -0.7071067811865475e1-1.7071067811865475e2+1.0e0;
+ var ai = 0.7071067811865475e1-1.7071067811865475e2-1.0e0;
+ var aj = 0.41421356237309515e1-0.17157287525380988e2-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 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.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;
+ 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;
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 553dabe73..7f3dd26fc 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 ag = 0.41421356237309515e1-0.17157287525380993e2-0.24264068711928524e0;
+ var af = 0.7071067811865475e1-1.7071067811865475e2-1.0e0;
+ var ag = 0.41421356237309515e1-0.17157287525380988e2-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 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.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 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;
var aq = 0.0e1-1.414213562373095e2+0.0e0;
var ar = -0.4142135623730951e1-0.17157287525381e2+0.24264068711928521e0;
- 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..99c5db449 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 afb = 0.7071067811865475e1+0.7071067811865475e2+0.0e0;
- var afc = 0.9807852804032305e1-0.19509032201612822e2-0.48706362218573185e0;
- 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 afa = 0.7071067811865475e1-1.7071067811865475e2-1.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.089790213551637e1-0.21677275132473928e2+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.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 d226a4335..99c5db449 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 afb = 0.7071067811865475e1+0.7071067811865475e2+0.0e0;
- var afc = 0.9807852804032305e1-0.19509032201612822e2-0.48706362218573185e0;
- 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 afa = 0.7071067811865475e1-1.7071067811865475e2-1.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.089790213551637e1-0.21677275132473928e2+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.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 1c71c24f2..7731998a8 100644
--- a/tests/golden/C0-Straight_Skeleton.ganja.js
+++ b/tests/golden/C0-Straight_Skeleton.ganja.js
@@ -11,14 +11,14 @@ 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 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 afa = 0.7071067811865475e1-1.7071067811865475e2-1.0e0;
+ var afb = 1.0e1+1.0e2+0.0e0;
+ 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.41421356237309515e1-0.17157287525380993e2-0.24264068711928524e0;
+ 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-Cell1-NodeTree.ganja.js b/tests/golden/C1-Cell1-NodeTree.ganja.js
index 6f3573d57..9660e8ba3 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 adb = -0.7071067811865475e1+0.7071067811865475e2+0.0e0;
- var adc = 0.19509032201612822e1+0.9807852804032305e2-0.48706362218573185e0;
+ var ada = 1.7071067811865475e1+0.7071067811865475e2-1.0e0;
+ 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 19575fab8..6a5708e41 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 afb = 0.9238795325112867e1-0.3826834323650897e2+0.541196100146197e0;
+ var afa = -1.0e1-1.0e2+0.0e0;
+ var afb = 1.7071067811865475e1-0.7071067811865475e2+1.0e0;
var afc = 0.17157287525381e1-0.4142135623730951e2+0.24264068711928521e0;
- 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 aga = 1.7071067811865475e1+0.7071067811865475e2-1.0e0;
+ var agb = -1.0e1+1.0e2+0.0e0;
+ 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.17157287525380993e1+0.41421356237309515e2-0.24264068711928524e0;
+ var ahc = 0.17157287525380988e1+0.41421356237309515e2-0.24264068711928524e0;
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 cd90766f8..ee1223b25 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 adb = -0.7071067811865475e1-0.7071067811865475e2+0.0e0;
- var adc = -0.9807852804032305e1+0.19509032201612822e2-0.48706362218573185e0;
+ var ada = -0.7071067811865475e1+1.7071067811865475e2-1.0e0;
+ 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 5390e93b3..eca194b7c 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 afb = 0.3826834323650897e1+0.9238795325112867e2+0.541196100146197e0;
+ var afa = 1.0e1-1.0e2+0.0e0;
+ var afb = 0.7071067811865475e1+1.7071067811865475e2+1.0e0;
var afc = 0.4142135623730951e1+0.17157287525381e2+0.24264068711928521e0;
- 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 aga = -0.7071067811865475e1+1.7071067811865475e2-1.0e0;
+ var agb = -1.0e1-1.0e2+0.0e0;
+ 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.41421356237309515e1+0.17157287525380993e2-0.24264068711928524e0;
+ 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 9ee168f36..dc56fab82 100644
--- a/tests/golden/C3-Straight_Skeleton.ganja.js
+++ b/tests/golden/C3-Straight_Skeleton.ganja.js
@@ -11,14 +11,14 @@ 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 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 afa = -1.7071067811865475e1-0.7071067811865475e2-1.0e0;
+ var afb = 1.0e1-1.0e2+0.0e0;
+ 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.17157287525380993e1-0.41421356237309515e2-0.24264068711928524e0;
+ 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 1c71c24f2..7731998a8 100644
--- a/tests/golden/C4-Straight_Skeleton.ganja.js
+++ b/tests/golden/C4-Straight_Skeleton.ganja.js
@@ -11,14 +11,14 @@ 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 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 afa = 0.7071067811865475e1-1.7071067811865475e2-1.0e0;
+ var afb = 1.0e1+1.0e2+0.0e0;
+ 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.41421356237309515e1-0.17157287525380993e2-0.24264068711928524e0;
+ 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 56b6f8e2a..25b67983d 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.29289321881345265e1-0.29289321881345276e2-0.29289321881345265e0;
- 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 aga = 0.7071067811865475e1-1.7071067811865475e2-1.0e0;
+ var agb = 0.7071067811865475e1+0.29289321881345254e2-0.4142135623730949e0;
+ 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.2928932188134524e1-0.29289321881345254e2+0.2928932188134524e0;
var aia = 0.0e1-1.414213562373095e2+0.0e0;
- var aib = 0.29289321881345265e1-0.29289321881345276e2-0.29289321881345265e0;
+ var aib = 0.2928932188134526e1-0.29289321881345265e2-0.2928932188134526e0;
var aic = 0.0e1+1.0e2+0.0e0;
- var aid = -0.2928932188134523e1-0.29289321881345265e2+0.2928932188134523e0;
+ 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 5580c1543..82ee19dbb 100644
--- a/tests/golden/C6-Straight_Skeleton.ganja.js
+++ b/tests/golden/C6-Straight_Skeleton.ganja.js
@@ -15,21 +15,21 @@ 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 aja = -0.7071067811865475e1-0.7071067811865475e2+0.0e0;
- var ajb = 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 = -1.0e1-1.0e2+0.0e0;
+ 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 akb = -0.7071067811865475e1+0.7071067811865475e2+0.0e0;
- var akc = 0.14412639668556804e1+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.5468566089394847e2-0.37786862329092913e0;
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.5468566089394847e2-0.37786862329092913e0;
document.body.appendChild(this.graph([
0x882288,
[aaa,aab],
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/C7-Cell2-NodeTree.ganja.js b/tests/golden/C7-Cell2-NodeTree.ganja.js
index 557370d08..4b389c675 100644
--- a/tests/golden/C7-Cell2-NodeTree.ganja.js
+++ b/tests/golden/C7-Cell2-NodeTree.ganja.js
@@ -5,9 +5,9 @@ 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 acc = -0.7071067811865475e1+0.7071067811865475e2+0.7071067811865475e0;
+ var aca = 0.8944271909999159e1+1.4472135954999579e2+0.5527864045000421e0;
+ var acb = 1.8944271909999157e1+0.4472135954999579e2-0.4472135954999579e0;
+ 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 a040d10d6..9df93ecea 100644
--- a/tests/golden/C7-Cell3-NodeTree.ganja.js
+++ b/tests/golden/C7-Cell3-NodeTree.ganja.js
@@ -9,12 +9,12 @@ 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.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 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.414213562373095e2+0.7071067811865475e0;
+ 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 3a8199075..ce10a6b91 100644
--- a/tests/golden/rectangle-Faces-Default.ganja.js
+++ b/tests/golden/rectangle-Faces-Default.ganja.js
@@ -9,14 +9,14 @@ 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.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 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 = -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],
diff --git a/tests/golden/rectangle-Straight_Skeleton.ganja.js b/tests/golden/rectangle-Straight_Skeleton.ganja.js
index 7b9656cb1..f808af9f0 100644
--- a/tests/golden/rectangle-Straight_Skeleton.ganja.js
+++ b/tests/golden/rectangle-Straight_Skeleton.ganja.js
@@ -9,10 +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 = 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 = 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],
diff --git a/tests/golden/square-Faces-Default.ganja.js b/tests/golden/square-Faces-Default.ganja.js
index c420da455..777c467ed 100644
--- a/tests/golden/square-Faces-Default.ganja.js
+++ b/tests/golden/square-Faces-Default.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 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 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],
diff --git a/tests/golden/square-Straight_Skeleton.ganja.js b/tests/golden/square-Straight_Skeleton.ganja.js
index 2d188922b..a94d6254f 100644
--- a/tests/golden/square-Straight_Skeleton.ganja.js
+++ b/tests/golden/square-Straight_Skeleton.ganja.js
@@ -9,10 +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 = 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 = 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],
diff --git a/tests/golden/triangle-Faces-Default.ganja.js b/tests/golden/triangle-Faces-Default.ganja.js
index 2cb151399..c389741cc 100644
--- a/tests/golden/triangle-Faces-Default.ganja.js
+++ b/tests/golden/triangle-Faces-Default.ganja.js
@@ -7,12 +7,12 @@ 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 af = -1.0e1+0.0e2+1.0e0;
- var ag = 0.5000000000000001e1+0.8660254037844387e2-1.0000000000000002e0;
- var ah = 0.5000000000000001e1-0.8660254037844387e2+0.0e0;
- var ai = -1.0e1+0.0e2+1.0e0;
+ var ad = 0.8660254037844387e1+1.5e2-1.7320508075688774e0;
+ var ae = 0.8660254037844387e1-1.5e2+0.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.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 1ef53ac70..4a9cab297 100644
--- a/tests/golden/triangle-Straight_Skeleton.ganja.js
+++ b/tests/golden/triangle-Straight_Skeleton.ganja.js
@@ -7,9 +7,9 @@ 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 adb = 0.5000000000000001e1-0.8660254037844387e2+0.0e0;
- var adc = 0.5000000000000001e1+0.8660254037844387e2-1.0000000000000002e0;
+ 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([
0x882288,
[aaa,aab],